chiark / gitweb /
Break out code for dbw_lookup_string; support capacity adjustments in terms of commod...
[ypp-sc-tools.db-live.git] / yarrg / web / check_capacitystring
index 13403b1..3c77972 100644 (file)
  This Mason component simply defines how to interpret capacities.
 
 </%doc>
-
-<%attr>
-maxambig => 2
-abbrev_initials => 1
-</%attr>
-
-<%method preparse>
+<%method execute>
 <%args>
-$h
+$string
+$dbh
+$debugf
 </%args>
 <%perl>
 
-my $parse_numeric= sub {
-       # returns (mass,volume,emsg)
-       my ($string,$default)= @_;
+my $commodsth;
 
-       my @mve= (undef,undef,undef);
+my @mv_names= qw(mass volume);
+my @mv_units= qw(kg l);
 
-       if ($string !~ m/\d/) {
-               return (undef,undef,
-                       'Adjustments to capacity must contain digits.');
-       }
+my (@mv)= (undef,undef);
+return ('',@mv) unless $string =~ m/\S/;
 
-       my $def= sub {
-               my ($ix,$what,$val) = @_;
-               if (defined $h->{$what}) {
-                       $mve[2]= "\`$string' specifies $what more than once.";
-               }
-               print STDERR "SET $what $val\n";
-               $mve[$ix]= $val;
-       };
-
-print STDERR "PAN \`$string'\n";
-       local $_;
-       foreach $_ (split /\s+/, $string) {
-               print STDERR "ITEM \`$_'\n";
-               next unless length;
-               if (m/^([1-9]\d{0,8})l$/) {
-                       $def->(1, 'volume', $1);
-               } elsif (m/^([1-9]\d{0,8})kg$/) {
-                       $def->(0, 'mass', $1);
-               } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
-                       $def->(1, 'volume', $1 * 1000);
-               } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
-                       $def->(0, 'mass', $1 * 1000);
-               } else {
-                       $mve[2]= "Cannot understand item \`$_'".
-                               " in numeric capacity";
-               }
-       }
-#      foreach my $ix (qw(0 1)) {
-#              $mve[$ix]= $default unless defined $mve[$ix];
-#      }
-       return @mve;
+my @canon= ();
+my ($signum,$signopstr)= (+1,undef);
+my $show_answer=0;
+my $first_term=1;
+my $last_signopstr= 'NONE';
+
+my $canon_numeric= sub {
+       my ($val,$mvi) = @_;
+       sprintf "%g%s", $val, $mv_units[$mvi];
 };
 
-my @mv_names= qw(mass volume);
-my $canon_numeric= $h->{'canon_numeric'}= sub {
-       print STDERR "CANNUM @_\n";
-       my $sep= '';
-       my $out= '';
-       foreach my $ix (qw(0 1)) {
-               next unless defined $_[$ix];
-               $out .= $sep; $sep= ' ';
-               $out .= sprintf "%g%s", $_[$ix], (qw(kg l))[$ix];
+my $parse_values= sub {
+  local ($_) = @_;
+  $debugf->("TERM VALUES '$_'");
+  $_ .= ' ';
+  my $def= sub {
+       my ($mvi,$val) = @_;
+       if ($first_term) {
+               expected_error("Initial term specifies".
+                               " $mv_names[$mvi] more than once.")
+                       if defined $mv[$mvi];
+               $mv[$mvi]= $val;
+       } else {
+               expected_error("Cannot add or subtract mass to/from volume")
+                       unless defined $mv[$mvi];
+               $mv[$mvi] += $signum * $val;
        }
-       return $out;
+       push @canon, $canon_numeric->($val,$mvi);
+  };
+  while (m/\S/) {
+       $debugf->("VALUE '$_'");
+       my $iqtyrex= '[1-9] \d{0,8}';
+       my $fqtyrex= '\d{1,9} \. \d{0,3} |' . $iqtyrex;
+       if    (s/^( $fqtyrex ) \s* kg \s+ //xo) { $def->(0, $1          ); }
+       elsif (s/^( $fqtyrex ) \s* t  \s+ //xo) { $def->(0, $1 * 1000.0 ); }
+       elsif (s/^( $fqtyrex ) \s* l  \s+ //xo) { $def->(1, $1          ); }
+       elsif (s/^( $fqtyrex ) \s* kl \s+ //xo) { $def->(1, $1 * 1000.0 ); }
+       elsif (s/^( $iqtyrex ) \s* ([a-z ]+) \s+ //xo) {
+               my ($qty,$spec) = ($1,$2);
+               $debugf->("VALUE COMMOD $qty '$spec'");
+               $commodsth ||=
+                   $dbh->prepare("SELECT commodname,unitmass,unitvolume
+                                    FROM commods WHERE commodname LIKE ?");
+               my ($emsg,$commod,@umv)=
+                   dbw_lookup_string($spec,$commodsth,1,0,0,
+                               "No commodity or unit matches \`$spec'",
+                               "Ambiguous commodity (or unit) \`$spec'",
+                               undef);
+               expected_error($emsg) if defined $emsg;
+               $debugf->("VALUE COMMOD FOUND '$commod' @umv");
+               foreach my $mvi (0,1) {
+                      next unless defined $mv[$mvi];
+                      $mv[$mvi] += $signum * $qty * $umv[$mvi] * 0.001;
+               }
+               push @canon, sprintf "%d", $qty;
+               push @canon, $commod;
+       } else {
+               s/\s+$//;
+               expected_error("Did not understand value \`$_'");
+       }
+  }
 };
 
-$h->{'deltas'}= [ ];
-print STDERR "NDELTA0 $#{ $h->{'deltas'} }\n";
-
-local ($_)= ${ $h->{String} };
-while (m/^(.*)(\bminus\b|-|\bplus\b|\+)/) {
-       my ($lhs,$rhs)= ($1,$');
-       print STDERR "TERM L=\`$1' M=\`$2' R=\`$''\n";
-       my ($signum,$signopstr)= 
-               $2 =~ m/^p|^\+/ ? (+1,'plus') : (-1,'minus');
-       my @mveco;
-       if ($rhs =~ m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
+my $parse_term= sub {
+       local ($_) = @_;
+       $debugf->("TERM '$_' signum=$signum");
+       s/^\s+//; s/\s+$//;
+       expected_error("empty term in capacity") unless m/\S/;
+       if (m/^\s*(\d{1,2}(?:\.\d{0,4})?)\%\s*$/) {
+               $debugf->("TERM PERCENT $1");
+               expected_error("percentage may not be first item")
+                       if $first_term;
                my $pct= 100.0 + $signum * $1;
-               @mveco= ($pct,$pct,undef);
-               push @mveco, sprintf "%s %g%%", $signopstr, $1;
-               push @mveco, sub {
-                       return undef unless defined $_[0];
-                       $_[0] * $_[1] / 100.0
-               };
-       } else {
-               @mveco= $parse_numeric->($rhs, 0);
-               if (!defined $mveco[2]) {
-                       push @mveco, $signopstr.' '.$canon_numeric->(@mveco);
-                       push @mveco, sub {
-                               ${ $h->{Emsg} }= "Cannot add or subtract".
-                                       " mass to/from volume"
-                                       unless defined $_[0];
-                               $_[0] + $_[1] * $signum
-                       };
+               foreach (@mv) {
+                       next unless defined;
+                       $_ *= $pct / 100.0;
                }
+               push @canon, sprintf "%g%%", $pct;
+       } elsif (!m/[^a-z]/) {
+               $debugf->("TERM NAME");
+               expected_error("Name (should be unit or commodity) \`$_'".
+                               " without preceding quantity")
+                       unless $first_term;
+               my $sth= $dbh->prepare("SELECT name,mass,volume".
+                                      "  FROM vessels WHERE name LIKE ?");
+               my ($emsg,$ship,@smv)=
+                   dbw_lookup_string($_,$sth,1,1,2,
+                               "Ship name `$_' not understood.",
+                               "Too many matching ship types.",
+                               sub { "Ambiguous - could be $_[0]" });
+               expected_error($emsg) if defined $emsg;
+               $debugf->("TERM NAME SHIP '$ship' @smv");
+               $show_answer= 1;
+               @mv = @smv;
+               push @canon, $ship;
+       } else {
+               $parse_values->($_);
        }
-       ${ $h->{Emsg} }= $mveco[2] if defined $mveco[2];
-       unshift @{ $h->{'deltas'} }, [ @mveco ];
-       print STDERR "NDELTA $#{ $h->{'deltas'} }\n";
-       $_= $lhs;
-}
+       $first_term= 0;
+};
 
-s/^\s+//; s/\s+$//;
-
-if (m/^[a-z ]+$/) {
-       push @{ $h->{Specs} }, $_;
-} elsif (m/\d/) {
-       my (@mve)= $parse_numeric->($_, undef);
-       if (defined $mve[2]) { ${ $h->{Emsg} }= $mve[2]; return; }
-       $h->{'initial'}= \@mve;
-} elsif (m/\S/) {
-       ${ $h->{Emsg} }= "Cannot understand capacity specification \`$_'.";
-} else {
-       $h->{'initial'}= [undef,undef];
+while ($string =~ s/^(.*?)(\bminus\b|-|\bplus\b|\+)//) {
+       my ($lhs)= ($1);
+       my @nextsign= $2 =~ m/^p|^\+/ ? (+1,'+') : (-1,'-');
+       $show_answer= 1;
+       $debugf->("GROUP S='$2'");
+       $parse_term->($lhs);
+       ($signum,$signopstr)= @nextsign;
+       push @canon, ($last_signopstr=$signopstr)
+               if $signopstr ne $last_signopstr;
 }
+$parse_term->($string);
 
-</%perl>
-</%method>
-
-<%method sqlstmt>
-SELECT name,mass,volume
-       FROM vessels WHERE name LIKE ?
-</%method>
-
-<%method nomatch>
-  Did not understand ship name.
-</%method>
-
-<%method ambiguous>
-  Ambiguous - could be <% $ARGS{couldbe} |h %>
-</%method>
-
-<%method manyambig>
-  Too many matching ship types.
-</%method>
-
-<%method postquery>
-<%args>
-$h
-</%args>
-<%perl>
-
-my $canon_numeric= $h->{'canon_numeric'};
+my $canon= join ' ', @canon;
 
-return if length ${ $h->{Emsg} };
-
-my @mv;
-my @mv_names= qw(mass volume);
-if (@{ $h->{Specs} }) {
-       @mv= @{ $h->{Results}[0] }[1,2];
-} else {
-       @mv= @{ $h->{'initial'} };
-       ${ $h->{Canon} }= $canon_numeric->(@mv);
-}
-print STDERR "INITIAL @mv\n";
-
-print STDERR "NDELTAE $#{ $h->{'deltas'} }\n";
-foreach my $delta (@{ $h->{'deltas'} }) {
-       print STDERR "DELTA @$delta\n";
-       die if defined $delta->[2]; # emsg
-       foreach my $ix (qw(0 1)) {
-               next unless defined $delta->[$ix];
-               print STDERR "DELTA I $ix\n";
-               $mv[$ix] = $delta->[4]->($mv[$ix], $delta->[$ix]);
-               return if length ${ $h->{Emsg} };
+if ($show_answer) {
+       $canon .= "  [=";
+       foreach my $mvi (0,1) {
+               next unless defined $mv[$mvi];
+               $canon .= ' '.$canon_numeric->($mv[$mvi], $mvi);
        }
-       ${ $h->{Canon} }.= ' '.$delta->[3];
+       $canon .= "]";
 }
 
-if (@{ $h->{Specs} } || @{ $h->{'deltas'} }) {
-       ${ $h->{Canon} }.= "  [= ". $canon_numeric->(@mv). "]";
-}
+$debugf->("FINISHING canon='$canon'");
 
-foreach my $ix (qw(0 1)) {
-       next unless defined $mv[$ix];
-       next if $mv[$ix] >= 0;
-       ${ $h->{Emsg} }= sprintf "%s limit is negative: %s",
-               ucfirst($mv_names[$ix]), $canon_numeric->(@mv);
-       return;
+foreach my $mvi (0,1) {
+       next unless defined $mv[$mvi];
+       next if $mv[$mvi] >= 0;
+       expected_error(sprintf "%s limit is negative: %s",
+               ucfirst($mv_names[$mvi]), $canon_numeric->($mv[$mvi], $mvi));
 }
 
-@{ $h->{Results} }= [ @mv ];
+return ($canon, @mv);
 
 </%perl>
 </%method>