X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fweb%2Fcheck_capacitystring;h=b958dff46745e2ee4c4b3b8efdbaffce92c07c8b;hp=13403b19505bc9ae366c99b5f7a952280397cbb1;hb=53dfe71f6c510ee12bbf6bdaeb3984024d34a7be;hpb=166893c6f6bd3e9b382aca095dc5ac80a22f89b7

diff --git a/yarrg/web/check_capacitystring b/yarrg/web/check_capacitystring
index 13403b1..b958dff 100644
--- a/yarrg/web/check_capacitystring
+++ b/yarrg/web/check_capacitystring
@@ -32,191 +32,161 @@
  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>