/swignition/Swignition/uF/hMeasure.pm
Perl | 558 lines | 457 code | 85 blank | 16 comment | 71 complexity | ef0b7b645494e156144da378afa97533 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-3.0
- #!/usr/bin/perl
- ######################################################################
- package Swignition::uF::hMeasure;
- ######################################################################
- # This is a complete hodge-podge of a module, but it seems to work.
- use CGI::Util;
- use Swignition::GenericParser::Utils;
- use Swignition::MagicString;
- use Swignition::uF;
- use POSIX;
- use XML::LibXML qw(:all);
- use strict;
- use utf8;
- sub consume
- {
- my $page = shift;
- $page->{uF}->{hMeasure} = [ parse_all($page) ];
-
- if (defined $page->{uF}->{hMeasure}->[0])
- {
- $page->mergeNS($page->{uF}->{hMeasure}->[0]);
- }
- foreach my $a (@{ $page->{uF}->{hMeasure} })
- {
- $a->rdf_subject_merge($page);
- }
- }
- sub parse_all
- {
- my $page = shift;
- my $within = shift || $page->{DOM};
- my @rv;
-
- my @nodes1 = searchClass('hmeasure', $within);
- my @nodes2 = searchClass('hangle', $within);
- my @nodes3 = searchClass('hmoney', $within);
- my @nodes = (@nodes1, @nodes2, @nodes3);
- foreach my $a (@nodes)
- {
- next if ($a->getAttribute('class') =~ /\b(tolerance)\b/);
- my $A = parse($page, $a);
- push @rv, $A;
- }
-
- return @rv;
- } #/sub parse_all
- sub uri
- {
- my $this = shift;
- my $all = shift;
- my @rv;
- if (length $this->{_id})
- {
- push @rv, Swignition::uF::TDBURI($this->{_page}->uri.'#'.$this->{_id});
- }
- if (lc($this->{_dom}->tagName) eq 'body')
- {
- push @rv, Swignition::uF::TDBURI($this->{_page}->uri);
- }
- push @rv, Swignition::GenericParser::Utils::BNodeURI($this->{_dom}, 'Measurement')
- unless (@rv);
-
- return $rv[0] unless (defined $all);
- while ($all) { shift @rv; $all--; }
- return @rv;
- } #/sub uri
- sub qv_uri
- {
- my $this = shift;
- my $all = shift;
- my @rv;
- push @rv, Swignition::GenericParser::Utils::BNodeURI($this->{_dom}, 'QualifiedValue');
-
- return $rv[0] unless (defined $all);
- while ($all) { shift @rv; $all--; }
- return @rv;
- } #/sub qv_uri
- sub t_uri
- {
- my $this = shift;
- my $all = shift;
- my @rv;
- if (length $this->{tolerance}->{_id})
- {
- push @rv, Swignition::uF::TDBURI($this->{_page}->uri . '#' . $this->{tolerance}->{_id});
- }
- elsif ($this->{tolerance}->{_dom})
- {
- push @rv, Swignition::GenericParser::Utils::BNodeURI($this->{tolerance}->{_dom}, 'Tolerance');
- }
- else
- {
- push @rv, Swignition::GenericParser::Utils::BNodeURI($this->{_dom}, 'Tolerance');
- }
-
- return $rv[0] unless (defined $all);
- while ($all) { shift @rv; $all--; }
- return @rv;
- } #/sub t_uri
- sub item_uri
- {
- my $this = shift;
- my $all = shift;
- my @rv;
- if ($this->{item_object})
- {
- return $this->{item_object}->uri($all);
- }
- if (length $this->{item_link})
- {
- push @rv, Swignition::uF::TDBURI($this->{item_link});
- }
- if (length $this->{item_dom}->getAttribute('id'))
- {
- push @rv, Swignition::uF::TDBURI($this->{_page}->uri . '#' . $this->{item_dom}->getAttribute('id'));
- }
- push @rv, Swignition::GenericParser::Utils::BNodeURI($this->{item_dom}, 'MeasuredThing')
- unless (@rv);
-
- return $rv[0] unless (defined $all);
- while ($all) { shift @rv; $all--; }
- return @rv;
- } #/sub t_uri
- sub dim_uri
- {
- my $this = shift;
- return 'http://purl.org/commerce#costs'
- if ($this->{class} eq 'hmoney' && !length $this->{type});
- return unless (length $this->{type});
- my $dimension = lc($this->{type});
- $dimension =~ s/\s+/ /g;
- $dimension =~ s/[^a-z0-9 ]//g;
- $dimension =~ s/ ([a-z])/uc($1)/ge;
- return 'http://buzzword.org.uk/rdf/measure#'.$dimension;
-
- } #/sub dim_uri
- sub rdf_subject_merge
- {
- my $this = shift;
- my $page = shift;
- my $val;
-
- my $subject = Swignition::RDFModel::Subject->new($this->uri);
- $subject->addObject($this);
- $subject->setDom($this->{_dom});
- my $val = Swignition::RDFModel::Value->new('http://buzzword.org.uk/rdf/measure-aux#Measurement', 1);
- $subject->addVal("http://www.w3.org/1999/02/22-rdf-syntax-ns#type", $val);
-
- my $qv_subject = Swignition::RDFModel::Subject->new($this->qv_uri);
- my $val = Swignition::RDFModel::Value->new(
- ($this->{class} eq 'hmoney'
- ? 'http://purl.org/commerce#Price'
- : 'http://buzzword.org.uk/rdf/measure-aux#QualifiedValue')
- , 1);
- $qv_subject->addVal("http://www.w3.org/1999/02/22-rdf-syntax-ns#type", $val);
- $val = Swignition::RDFModel::Value->new($this->qv_uri, 1);
- $subject->addVal("http://buzzword.org.uk/rdf/measure-aux#hasValue", $val);
- if (length $this->{unit})
- {
- $val = Swignition::RDFModel::Value->new($this->{unit});
- $qv_subject->addVal(
- ($this->{class} eq 'hmoney'
- ?'http://purl.org/commerce#currency'
- :"http://buzzword.org.uk/rdf/measure-aux#unit"),
- $val);
- }
- if (length $this->{num})
- {
- $val = Swignition::RDFModel::Value->new($this->{num});
- $qv_subject->addVal(
- ($this->{class} eq 'hmoney'
- ?'http://purl.org/commerce#amount'
- :"http://www.w3.org/1999/02/22-rdf-syntax-ns#value"),
- $val);
- }
- if ($this->{class} eq 'hangle')
- {
- $val = Swignition::RDFModel::Value->new($this->{num_label});
- $qv_subject->addVal('http://www.w3.org/2000/01/rdf-schema#label', $val);
- }
-
- if ($this->{tolerance}->{class} eq 'percentage'
- || $this->{tolerance}->{unit} eq '%')
- {
- $val = Swignition::RDFModel::Value->new($this->{tolerance}->{num}.'%');
- $subject->addVal("http://buzzword.org.uk/rdf/measure-aux#hasTolerance", $val);
- }
- elsif ($this->{tolerance}->{num})
- {
- my $t_subject = Swignition::RDFModel::Subject->new($this->t_uri);
- my $val = Swignition::RDFModel::Value->new(
- ($this->{class} eq 'hmoney'
- ? 'http://purl.org/commerce#Price'
- : 'http://buzzword.org.uk/rdf/measure-aux#Tolerance')
- , 1);
- $t_subject->addVal("http://www.w3.org/1999/02/22-rdf-syntax-ns#type", $val);
- $val = Swignition::RDFModel::Value->new($this->t_uri, 1);
- $subject->addVal("http://buzzword.org.uk/rdf/measure-aux#hasTolerance", $val);
- if (length $this->{tolerance}->{unit})
- {
- $val = Swignition::RDFModel::Value->new($this->{tolerance}->{unit});
- $t_subject->addVal(
- ($this->{class} eq 'hmoney'
- ?'http://purl.org/commerce#currency'
- :"http://buzzword.org.uk/rdf/measure-aux#unit"),
- $val);
- }
- if (length $this->{tolerance}->{num})
- {
- $val = Swignition::RDFModel::Value->new($this->{tolerance}->{num});
- $t_subject->addVal(
- ($this->{class} eq 'hmoney'
- ?'http://purl.org/commerce#amount'
- :"http://www.w3.org/1999/02/22-rdf-syntax-ns#value"),
- $val);
- }
- $page->mergeSubject($t_subject);
- }
-
- if (length $this->dim_uri)
- {
- $val = Swignition::RDFModel::Value->new($this->dim_uri, 1);
- $subject->addVal("http://buzzword.org.uk/rdf/measure-aux#dimension", $val);
- }
- if ($this->{item_object} || $this->{item_dom})
- {
- my $item_subject = Swignition::RDFModel::Subject->new($this->item_uri);
- $item_subject->addVal(
- 'http://buzzword.org.uk/rdf/measure-aux#hasMeasurement',
- Swignition::RDFModel::Value->new($this->uri, 1)
- );
- $subject->addVal(
- 'http://buzzword.org.uk/rdf/measure-aux#item',
- Swignition::RDFModel::Value->new($this->item_uri, 1)
- );
- if (length $this->dim_uri)
- {
- $item_subject->addVal(
- $this->dim_uri,
- Swignition::RDFModel::Value->new($this->qv_uri, 1)
- );
- }
- if (!$this->{item_object})
- {
- $item_subject->addVal(
- 'http://www.w3.org/2000/01/rdf-schema#label',
- Swignition::RDFModel::Value->new($this->{item})
- );
- }
- $page->mergeSubject($item_subject);
- }
-
- $page->mergeSubject($subject);
- $page->mergeSubject($qv_subject);
-
- } #/sub rdf_subject
- sub metadata_ns
- {
- my $this = shift;
- return {
- 'commerce' => {
- nsurl=>'http://purl.org/commerce#',
- title=>'RDF Commerce Vocab'
- },
- 'measure' => {
- nsurl=>'http://buzzword.org.uk/rdf/measure#',
- title=>'RDF Measurements Vocab'
- },
- 'measurex' => {
- nsurl=>'http://buzzword.org.uk/rdf/measure-aux#',
- title=>'RDF Measurements Vocab (Auxiliary)'
- }
- };
- } #/sub metadata_ns
- sub parse
- {
- my $page = shift;
- my $rv = { '_dom'=>shift };
- my $pkg = __PACKAGE__;
- if (defined $page->{uF}->{_Shortcuts}->{$pkg}->{ $rv->{_dom}->getAttribute('_xpath') })
- { return $page->{uF}->{_Shortcuts}->{$pkg}->{ $rv->{_dom}->getAttribute('_xpath') }; }
- else
- { $page->{uF}->{_Shortcuts}->{$pkg}->{ $rv->{_dom}->getAttribute('_xpath') } = $rv; }
-
- my $root = $rv->{'_dom'}->cloneNode(1);
- my @RemoveTheseNodes;
-
- my $id = $root->getAttribute('id');
- $rv->{_id} = $id if (length $id);
- $rv->{_page} = $page;
-
- Swignition::uF::data_patterns($page, $root, 2);
-
- # Extract embedded hCards
- my @nested = searchClass('vcard', $root);
- foreach my $h (@nested)
- {
- if ($h->getAttribute('class') =~ / (^|\s) item (\s|$) /x)
- {
- $rv->{item_object} = Swignition::uF::hCard::parse($page, $h);
- push @RemoveTheseNodes, $h;
- last;
- }
-
- my $newClass = $h->getAttribute('class');
- $newClass =~ s/\b(item)\b//gix;
- $h->setAttribute('class', $newClass);
- }
- # Extract embedded hCalendar events
- my @nested = searchClass('vevent', $root);
- foreach my $h (@nested)
- {
- if ($h->getAttribute('class') =~ / (^|\s) item (\s|$) /x)
- {
- $rv->{item_object} = Swignition::uF::hEvent::parse($page, $h);
- push @RemoveTheseNodes, $h;
- last;
- }
-
- my $newClass = $h->getAttribute('class');
- $newClass =~ s/\b(item)\b//gix;
- $h->setAttribute('class', $newClass);
- }
- # Now that we have reached here, no other composite microformats have
- # any business being nested within this root element. So in the interest
- # of Microformat opacity, let's destroy them.
- Swignition::uF::destroyer($root);
- # We'll use these regular expressions later.
- my $_nonZeroDigit = '[1-9]';
- my $_digit = '\d';
- my $_natural = "($_nonZeroDigit)($_digit)*";
- my $_integer = "(0|(\\-|\x{2212})?($_natural)+)";
- my $_decimal = "($_integer)[\\.\\,]($_digit)*";
- my $_mantissa = "($_decimal|$_integer)";
- my $_sciNumber = "($_mantissa)[Ee]($_integer)";
- my $_number = "($_sciNumber|$_decimal|$_integer|\\x{00BC}|\\x{00BD}|\\x{00BE})";
-
- my $_degree = "($_number)(deg|\\x{00b0})";
- my $_minute = "($_number)(min|\\x{2032}|\\\')";
- my $_second = "($_number)(sec|\\x{2033}|\\\")";
-
- # Type
- $rv->{class} = 'hmeasure';
- $rv->{class} = 'hangle' if ($root->getAttribute('class') =~ /\b(hangle)\b/);
- $rv->{class} = 'hmoney' if ($root->getAttribute('class') =~ /\b(hmoney)\b/);
- # Number
- my @nodes = searchClass('num', $root);
- my $str = STRINGIFY($nodes[0], 'value');
- $rv->{num} = $str
- if (length $str);
- push @RemoveTheseNodes, $nodes[0] if ($nodes[0]);
-
- # Unit
- unless ($rv->{class} eq 'hangle')
- {
- @nodes = searchClass('unit', $root);
- $str = STRINGIFY($nodes[0], 'value');
- $rv->{unit} = $str
- if (length $str);
- push @RemoveTheseNodes, $nodes[0] if ($nodes[0]);
- }
- # Type
- @nodes = searchClass('type', $root);
- $str = STRINGIFY($nodes[0], 'value');
- $rv->{type} = $str
- if (length $str);
- push @RemoveTheseNodes, $nodes[0] if ($nodes[0]);
-
- # Item
- unless ($rv->{item_object})
- {
- @nodes = searchClass('item', $root);
- if (@nodes)
- {
- my $n = $nodes[0];
- my $link;
-
- $str = STRINGIFY($n, 'value');
-
- if (length $n->getAttribute('src'))
- { $link = $page->uri( $n->getAttribute('src') ); }
- elsif (length $n->getAttribute('href'))
- { $link = $page->uri( $n->getAttribute('href') ); }
- elsif (length $n->getAttribute('data'))
- { $link = $page->uri( $n->getAttribute('data') ); }
-
- $rv->{item} = $str
- if (length $str);
- $rv->{item_link} = $link
- if (length $link);
- $rv->{item_dom} = $n;
-
- push @RemoveTheseNodes, $n;
- }
- }
-
- # Tolerance
- @nodes = searchClass('tolerance', $root);
- my $str = STRINGIFY($nodes[0], 'value');
- if ($str =~ /^\s*($_number)\s*\%\s*$/)
- {
- $rv->{tolerence} = bless {
- 'class' => 'percentage' ,
- 'num' => $1 ,
- 'unit' => '%'
- };
- }
- elsif ($nodes[0])
- {
- my $tolerance = parse($nodes[0]);
- $rv->{tolerence} = $tolerance
- if (length $tolerance->{num});
- }
- push @RemoveTheseNodes, $nodes[0] if ($nodes[0]);
- foreach my $RemoveIt (@RemoveTheseNodes)
- { $RemoveIt->parentNode->removeChild($RemoveIt); }
- my $str = STRINGIFY($root, 'value');
-
- unless ($rv->{tolerance})
- {
- my $tol;
- ($str, $tol) = split /\x{2213}/, $str;
- $str =~ s/(^\s+)|(\s+$)//g;
- $tol =~ s/(^\s+)|(\s+$)//g;
-
- if (length $tol)
- {
- $tol =~ /$_number/;
- $rv->{tolerance} = bless {
- num => $1 ,
- class => $rv->{class}
- };
- $tol =~ s/$_number//;
- $rv->{tolerance}->{unit} = $tol;
- }
- }
-
- if ($rv->{class} eq 'hangle' && !length $rv->{num})
- {
- $rv->{num} = $str;
- }
- elsif (length $rv->{num} && !length $rv->{unit})
- {
- $rv->{unit} = $str;
- if ($rv->{class} eq 'hmoney')
- {
- $str =~ /(\b[A-Z]{3}\b|\x{20AC}|\x{00A3}|\x{00A5}|\x{0024})/i;
- $rv->{unit} = $1 if (length $1);
- }
- }
- elsif (length $rv->{unit} && !length $rv->{num})
- {
- $str =~ s/\s+//g;
- $str =~ /$_number/;
- $rv->{num} = $str;
- }
- elsif (!length $rv->{num} && !length $rv->{unit})
- {
- $str =~ /$_number/;
- $rv->{num} = $1;
- $str =~ s/\s*($_number)\s*//;
- $rv->{unit} = $str;
- if ($rv->{class} eq 'hmoney')
- {
- $str =~ /(\b[A-Z]{3}\b|\x{20AC}|\x{00A3}|\x{00A5}|\x{0024})/i;
- $rv->{unit} = $1 if (length $1);
- }
- }
-
- if ($rv->{class} eq 'hmoney')
- {
- $rv->{unit} = 'EUR' if ($rv->{unit} =~ /^\x{20AC}$/);
- $rv->{unit} = 'GBP' if ($rv->{unit} =~ /^\x{00A3}$/);
- $rv->{unit} = 'JPY' if ($rv->{unit} =~ /^\x{00A5}$/);
- $rv->{unit} = 'USD' if ($rv->{unit} =~ /^\x{0024}$/);
- }
- $rv->{num} =~ s/\,/\./g;
- $rv->{num} =~ s/\x{2212}/\-/g;
- if ($rv->{class} eq 'hangle')
- {
- $str = $rv->{num};
-
- $str =~ m/$_degree/; $rv->{num_degree} = $1 if (length $1);
- $str =~ m/$_minute/; $rv->{num_minute} = $1 if (length $1);
- $str =~ m/$_second/; $rv->{num_second} = $1 if (length $1);
- if ($rv->{num_degree} < 0)
- {
- $rv->{num_minute} *= -1;
- $rv->{num_second} *= -1;
- }
- elsif ($rv->{num_degree} == 0 && $rv->{num_minute} < 0)
- {
- $rv->{num_second} *= -1;
- }
-
- $rv->{num} = $rv->{num_degree}
- + ( $rv->{num_minute} / 60 )
- + ( $rv->{num_second} / 3600 );
- $rv->{num_label} = $str;
- }
-
- if ($rv->{class} ne 'hangle' && defined $rv->{tolerance} && !length $rv->{tolerance}->{unit})
- {
- $rv->{tolerance}->{unit} = $rv->{unit};
- }
-
- bless $rv;
- return $rv;
-
- } #/sub parse
- 1; #/package Swignition::uF::hMeasure