chiark / gitweb /
Break out code for dbw_lookup_string; support capacity adjustments in terms of commod...
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 20 Sep 2009 17:27:21 +0000 (18:27 +0100)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 20 Sep 2009 17:27:21 +0000 (18:27 +0100)
yarrg/CommodsWeb.pm
yarrg/web/check_capacitystring
yarrg/web/check_capitalstring
yarrg/web/check_lossperleague
yarrg/web/docs
yarrg/web/qtextstring
yarrg/web/qtextstringcheck
yarrg/web/query_route

index 198185d..24ee53e 100644 (file)
@@ -51,6 +51,7 @@ BEGIN {
     @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 = ( );
 
@@ -151,4 +152,48 @@ BEGIN { eval '
 }
 
 
+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;
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>
index 90148c6..53aceec 100644 (file)
 
 </%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>
index 41ed4b3..9375355 100644 (file)
  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>
index c848709..e126970 100755 (executable)
@@ -119,8 +119,9 @@ like:
 <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>
@@ -128,16 +129,20 @@ Evaluation is strictly from left to right.
 
 <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>
 
index d57f863..c958915 100644 (file)
@@ -40,7 +40,7 @@ $qa => $m->caller_args(1)->{'qa'}
 $dbh
 $thingstring
 $emsgstore
-$perresult
+$onresults
 $prefix => 'ts';
 $helpref => undef;
 </%args>
@@ -104,7 +104,7 @@ register_onload(<%$p%>Needed);
 
 <%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,
@@ -114,10 +114,6 @@ if (length $thingstring) {
                $$emsgstore='' unless defined $$emsgstore;
                $$emsgstore .= $emsg. ' ';
        }
-
-       foreach my $entry (@$results) {
-#print STDERR "qts entry perresult \`@$entry'\n";
-               $perresult->(@$entry);
-       }
+       $onresults->(@results);
 }
 </%perl>
index 686a506..4adb606 100755 (executable)
@@ -44,6 +44,7 @@ $ctype => undef
 $string
 $what
 $dbh => undef
+$debug => 0
 </%args>
 
 <%flags>
@@ -55,6 +56,7 @@ use JSON;
 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}");
@@ -62,75 +64,69 @@ 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);
@@ -151,6 +147,6 @@ $mydbh->rollback() if $mydbh;
 
 return  $emsg,
        $canontext,
-       [ @results ];
+       @results;
 
 </%perl>
index 0f9447a..8b491d9 100644 (file)
@@ -81,10 +81,12 @@ Enter route (islands, or archipelagoes, separated by |s or commas;
 
 <&| 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
@@ -100,9 +102,7 @@ Vessel or capacity:
 <&| 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
 </&>
@@ -117,7 +117,7 @@ Expected losses:
 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'll',
     thingstring => 'lossperleague', emsgstore => \$emsg,
     helpref => 'losses',
-    perresult => sub { ($lossperleaguepct)= @_; }
+    onresults => sub { ($lossperleaguepct)= @_; }
  &>
  size=9
 </&>
@@ -129,7 +129,7 @@ Expected losses:
 <&| qtextstring, qa => $qa, dbh => $dbh, prefix => 'ac',
     thingstring => 'capitalstring', emsgstore => \$emsg,
     helpref => 'capital',
-    perresult => sub { ($capital)= @_; }
+    onresults => sub { ($capital)= @_; }
  &>
  size=9
 </&>