This Mason component simply defines how to interpret capacities.
</%doc>
-
-<%attr>
-</%attr>
-
-<%method preparse>
+<%method execute>
<%args>
-$h
+$string
+$dbh
+$debugf
</%args>
<%perl>
-my $def= sub {
- my ($what,$val) = @_;
- if (defined $h->{$what}) {
- $h->{Emsg}= "Multiple definitions of maximum $what.";
+my $commodsth;
+
+my @mv_names= qw(mass volume);
+my @mv_units= qw(kg l);
+
+my (@mv)= (undef,undef);
+return ('',@mv) unless $string =~ m/\S/;
+
+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 $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;
+ }
+ 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'");
+ 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 \`$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 \`$_'");
}
- print STDERR "SET $what $val\n";
- $h->{$what}= $val;
+ }
};
-foreach $_ (split /\s+/, ${ $h->{String} }) {
- print STDERR "ITEM \`$_'\n";
- next unless length;
- if (m/^([1-9]\d{0,8})l$/) {
- $def->('volume', $1);
- } elsif (m/^([1-9]\d{0,8})kg$/) {
- $def->('mass', $1);
- } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)kl/) {
- $def->('volume', $1 * 1000);
- } elsif (m/^([1-9]\d{0,5}(?:\.\d{0,3})?)t/) {
- $def->('mass', $1 * 1000);
+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;
+ 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 {
- ${ $h->{Emsg} }= "Cannot understand capacity \`$_'.";
- last;
+ $parse_values->($_);
}
+ $first_term= 0;
+};
+
+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;
}
-</%perl>
-</%method>
+$parse_term->($string);
-<%method postquery>
-<%args>
-$h
-</%args>
-<%perl>
+my $canon= join ' ', @canon;
-if (defined $h->{'mass'} or defined $h->{'volume'}) {
- @{ $h->{Results} } = [ $h->{'mass'}, $h->{'volume'} ];
+if ($show_answer) {
+ $canon .= " [=";
+ foreach my $mvi (0,1) {
+ next unless defined $mv[$mvi];
+ $canon .= ' '.$canon_numeric->($mv[$mvi], $mvi);
+ }
+ $canon .= "]";
+}
- ${ $h->{Canon} }=
- 'mass limit: '.(defined $h->{'mass'} ? $h->{'mass'} .'kg' : 'none').'; '.
- 'volume limit: '.(defined $h->{'volume'} ? $h->{'volume'} .'l' : 'none').'.';
+$debugf->("FINISHING canon='$canon'");
+
+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));
}
+return ($canon, @mv);
+
</%perl>
</%method>
~yarrgweb / ypp-sc-tools.db-live.git / blobdiff