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+ //ixo) {
+ my ($qty,$spec) = ($1,$2);
+ $debugf->("VALUE COMMOD $qty '$spec'");
+ expected_error("Capacity specification must start with".
+ " ship size or amount with units")
+ if $first_term;
+ $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 ".escerrq($spec),
+ "Ambiguous commodity (or unit) ".escerrq($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 ".
+ escerrq($_));
+ }
+ }
};
-$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]/i) {
+ $debugf->("TERM NAME");
+ expected_error("Name (should be unit or commodity)".
+ escerrq($_).
+ " 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 ".escerrq($_)." not understood.",
+ "Too many matching ship types.",
+ sub { "Ambiguous - could be $_[1]" });
+ 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|\+)//i) {
+ 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>
~yarrgweb / ypp-sc-tools.db-live.git / blobdiff