@EXPORT = qw(&dbw_connect &ocean_list &sourcebasedir
&to_json_shim &to_json_protecttags
&set_ctype_utf8
+ &expected_error &dbw_lookup_string
&prettyprint_age &meta_prettyprint_age);
%EXPORT_TAGS = ( );
}
+sub dbw_lookup_string ($$$$$$$$) { # => ( $emsg, @dbresults )
+ my ($each,
+ $sth, $stmt_nqs, $abbrev_initials, $maxambig,
+ $em_nomatch, $em_manyambig, $emf_ambiguous) = @_;
+
+ $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g;
+ my %m;
+ my $results;
+ my @pats= ("$each", "$each\%", "\%$each\%");
+ if ($abbrev_initials) {
+ push @pats, join ' ', map { "$_%" } split //, $each;
+ }
+ foreach my $pat (@pats) {
+ $sth->execute(($pat) x $stmt_nqs);
+ $results= $sth->fetchall_arrayref();
+ last if @$results==1;
+ $m{ $_->[0] }=1 for @$results;
+ $results= undef;
+ }
+ if (!$results) {
+ if (!%m) {
+ return $em_nomatch;
+ } elsif (keys(%m) > $maxambig) {
+ return $em_manyambig;
+ } else {
+ return $emf_ambiguous->($each, join(', ', sort keys %m));
+ }
+ }
+ return (undef, @{ $results->[0] });
+}
+
+sub expected_error ($) {
+ my $r= { Emsg => $_[0] };
+ bless $r, 'CommodsWeb::ExpectedError';
+ die $r;
+}
+
+package CommodsWeb::ExpectedError;
+
+sub emsg ($) {
+ my ($self) = @_;
+ return $self->{Emsg};
+}
+
1;
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>
</%doc>
-<%attr>
-</%attr>
-
-<%method preparse>
+<%method execute>
<%args>
-$h
+$string
+$dbh
+$debugf
</%args>
<%perl>
-$_= ${ $h->{String} };
+$_= $string;
s/^\s+//; s/\s+$//;
-my $res= sub {
- my ($capital) = @_;
- push @{ $h->{Results} }, [ $capital ];
- ${ $h->{Canon} }= "$capital PoE";
-};
+my $capital;
+my $canon;
if (!m/\S/) {
+ $canon= '';
} elsif (m/^([1-9]\d*)( PoE)?$/i) {
- $res->( $1 );
+ $capital= $1;
+ $canon= "$capital PoE";
} else {
- ${ $h->{Emsg} }= "Cannot understand capital \`$_'.";
- return;
+ expected_error("Cannot understand capital \`$_'.");
}
+return ($canon,$capital);
+
</%perl>
</%method>
This Mason component simply defines how to interpret losses per league.
</%doc>
-
-<%attr>
-</%attr>
-
-<%method preparse>
+<%method execute>
<%args>
-$h
+$string
+$dbh
+$debugf
</%args>
<%perl>
-$_= ${ $h->{String} };
+$_= $string;
s/^\s+//; s/\s+$//;
-my $res= sub {
- my ($pct,$str) = @_;
- push @{ $h->{Results} }, [ $pct ];
- ${ $h->{Canon} }= "$str per league";
-};
+my ($pct,$str);
if (!m/\S/) {
+ $str= '';
} elsif (m/^(\d{1,2}(?:\.\d{0,5})?)\%$/) {
- $res->( $1 * 1.0, sprintf("%g%%", $1) );
+ $pct= $1 * 1.0;
+ $str= sprintf("%g%%", $1);
} elsif (m/^1\s*\/\s*([1-9]\d{0,4})/) {
- $res->( 100.0/$1, sprintf("1/%d", $1) );
+ $pct= 100.0/$1;
+ $str= sprintf("1/%d", $1);
} else {
- ${ $h->{Emsg} }= "Cannot understand loss per league \`$_'.";
- return;
+ expected_error("Cannot understand loss per league \`$_'.");
}
+return ("$str per league", $pct);
+
</%perl>
</%method>
<dd>The capacity of a war brig minus 1%
<dt>13t 20kl
<dd>13 tonnes (13,000kg), 20 kilolitres (20,000l)
-<dt>sloop - 100l 100kg
-<dd>The capacity of a sloop minus 100l, minus 100kg
+<dt>sloop - 10 small 40 rum
+<dd>The capacity of a sloop which remains after
+ 10 small shot and 40 rum are loaded
<dt>2t plus 500kg minus 200kg
<dd>2300kg, with no limit on volume
</dl>
<p>
-Formally, the capacity is a list of terms, all but the first preceded
-by one of <kbd>-</kbd>, <kbd>minus</kbd>, <kbd>+</kbd>,
-<kbd>plus</kbd>. Each term may specify a mass and/or a volume
-(separated by a space), as a number followed (without an intervening
-space) by a unit (<kbd>t</kbd>, <kbd>kg</kbd>, <kbd>kl</kbd> or
-<kbd>l</kbd>). Alternatively each term except the first may specify a
-percentage, which is applied as a percentage change to the answer from
-all the preceding terms. The first term may be a ship name or
-abbrevation instead. If the first term specifies only one of mass or
-volume, all the subsequent terms may only adjust that same value.
+More formally:
+<pre>
+ capacity-string := [ first-term term* ]
+ term := ('+' | '-' | 'plus' | 'minus') (value+ | number'%')
+ value := mass | volume
+ | integer commodity-name-or-abbreviation
+ mass := number ('t' | 'kg')
+ volume := number ('kl' | 'l')
+ first-term := mass | volume | mass volume | volume mass
+ | ship-name-or-abbreviation
+</pre>
+
+If the first term specifies only one of mass or volume, all the
+subsequent terms may only adjust that same value.
<h3><a name="losses">Expected losses</a></h3>
$dbh
$thingstring
$emsgstore
-$perresult
+$onresults
$prefix => 'ts';
$helpref => undef;
</%args>
<%perl>
if (length $thingstring) {
- my ($emsg,$canonstring,$results)= $m->comp('qtextstringcheck',
+ my ($emsg,$canonstring,@results)= $m->comp('qtextstringcheck',
what => $thingstring,
ocean => $qa->{Ocean},
string => $stringval,
$$emsgstore='' unless defined $$emsgstore;
$$emsgstore .= $emsg. ' ';
}
-
- foreach my $entry (@$results) {
-#print STDERR "qts entry perresult \`@$entry'\n";
- $perresult->(@$entry);
- }
+ $onresults->(@results);
}
</%perl>
$string
$what
$dbh => undef
+$debug => 0
</%args>
<%flags>
use Data::Dumper;
use HTML::Entities;
use CommodsWeb;
+use Scalar::Util qw(blessed);
die if $what =~ m/[^a-z]/;
my $chk= $m->fetch_comp("check_${what}");
my $mydbh;
$dbh ||= ($mydbh= dbw_connect($ocean));
-#print STDERR "qtsc string=\`$string'\n";
+my $debugf= !$debug ? sub { } : sub {
+ print "@_\n";
+};
-my ($sth, @sqlstmt_qs);
-if ($chk->method_exists('sqlstmt')) {
- my $sqlstmt= $chk->scall_method("sqlstmt");
- $sth= $dbh->prepare($sqlstmt);
- @sqlstmt_qs= $sqlstmt =~ m/\?/g;
-}
+$debugf->("QTSC STRING '$string'");
my $emsg= '';
my @results;
-my @specs;
my $canontext;
-my $hooks = { Emsg => \$emsg, String => \$string,
- Results => \@results, Specs => \@specs,
- Canon => \$canontext
- };
-if ($chk->method_exists('preparse')) {
- $chk->call_method('preparse', h => $hooks);
-} else {
- @specs= $chk->attr('multiple') ? (split m#[/|,]#, $string) : ($string);
-}
+$string =~ s/^\s*//;
+$string =~ s/\s$//;
+$string =~ s/\s+/ /g;
-no warnings qw(exiting);
-
-foreach my $each (@specs) {
- $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g;
- next if !length $each;
- my $err= sub { $emsg= $_[0]; last; };
- my %m;
- my $results;
- my @pats= ("$each", "$each\%", "\%$each\%");
- if ($chk->attr_exists('abbrev_initials')) {
- push @pats, join ' ', map { "$_%" } split //, $each;
- }
- foreach my $pat (@pats) {
- $sth->execute(($pat) x @sqlstmt_qs);
- $results= $sth->fetchall_arrayref();
- last if @$results==1;
- map { $m{ $_->[0] }=1 } @$results;
- $results= undef;
+if ($chk->method_exists('execute')) {
+ ($canontext, @results)= eval {
+ $chk->call_method('execute',
+ dbh => $dbh, string => $string,
+ debugf => $debugf);
+ };
+ if ($@) {
+ die unless blessed $@ && $@->isa('CommodsWeb::ExpectedError');
+ $emsg= $@->emsg();
}
- if (!$results) {
- if (!%m) {
- $err->($chk->scall_method("nomatch",
- spec => $each));
- } elsif (keys(%m) > $chk->attr('maxambig')) {
- $err->($chk->scall_method("manyambig"));
- } else {
- $err->($chk->scall_method("ambiguous",
- spec => $each,
- couldbe => join(', ', sort keys %m)));
+} else {
+ my $sqlstmt= $chk->scall_method("sqlstmt");
+ my $sth= $dbh->prepare($sqlstmt);
+ my @sqlstmt_nqs= $sqlstmt =~ m/\?/g;
+ my $sqlstmt_nqs= @sqlstmt_nqs;
+
+ my @specs= $chk->attr('multiple')
+ ? (split m#[/|,]#, $string)
+ : ($string);
+
+ foreach my $each (@specs) {
+ next unless $each =~ m/\S/;
+ my ($temsg, @tresults) =
+ dbw_lookup_string($each,
+ $sth, $sqlstmt_nqs,
+ $chk->attr_exists('abbrev_initials'),
+ $chk->attr('maxambig'),
+ $chk->scall_method("nomatch", spec => $each),
+ $chk->scall_method("manyambig"),
+ sub {
+ $chk->scall_method("ambiguous",
+ spec => $each, couldbe => $_[0])
+ });
+ if (defined $temsg) {
+ $emsg= $temsg;
+ last;
}
- }
- push @results, $results->[0];
-};
+ push @results, [ @tresults ];
+ };
+}
if (!defined $canontext) {
$canontext= join ' | ', map { $_->[0] } @results;
}
-if ($chk->method_exists('postquery')) {
- $chk->call_method('postquery', h => $hooks);
-}
$emsg='' if !defined $emsg;
@results=() if length $emsg;
-#print STDERR "qtsc emsg=\`$emsg' results=\`@results'\n";
+$debugf->("QTSC EMSG='$emsg' RESULTS='@results'");
if ($format =~ /json/) {
$r->content_type($ctype or $format);
return $emsg,
$canontext,
- [ @results ];
+ @results;
</%perl>
<&| qtextstring, qa => $qa, dbh => $dbh,
thingstring => 'routestring', emsgstore => \$emsg,
- perresult => sub {
- my ($canonname, $island, $arch) = @_;
- push @islandids, $island;
- push @archipelagoes, defined $island ? undef : $arch;
+ onresults => sub {
+ foreach (@_) {
+ my ($canonname, $island, $arch) = @$_;
+ push @islandids, $island;
+ push @archipelagoes, defined $island ? undef : $arch;
+ }
}
&>
size=80
<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'cs',
thingstring => 'capacitystring', emsgstore => \$emsg,
helpref => 'capacity',
- perresult => sub {
- ($max_mass,$max_volume) = @_;
- }
+ onresults => sub { ($max_mass,$max_volume) = @_; }
&>
size=40
</&>
<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
thingstring => 'lossperleague', emsgstore => \$emsg,
helpref => 'losses',
- perresult => sub { ($lossperleaguepct)= @_; }
+ onresults => sub { ($lossperleaguepct)= @_; }
&>
size=9
</&>
<&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'ac',
thingstring => 'capitalstring', emsgstore => \$emsg,
helpref => 'capital',
- perresult => sub { ($capital)= @_; }
+ onresults => sub { ($capital)= @_; }
&>
size=9
</&>
~yarrgweb / ypp-sc-tools.web-live.git / commitdiff