farnell/farnell-find

   1 #!/usr/bin/perl -w
   2
   3 # Usages:
   4 #   ./farnell-find [<options>] [describe] NNN-NNNN ....
   5 #       Prints info about the specified relevant part.
   6 #   ./farnell-find [<options>] order [<sid>|<url>] [NNN-NNNN <qty> ...]
   7 #       Add specified parts and quantities to the cart.
   8 #       If no parts and quantities specified on command line,
   9 #        will read from stdin (format is <item> <qty>).
  10 #       If no <sid> or <url> specified (ie thing with jsessionid)
  11 #        then will prompt and read a line from tty.
  12 #   ./farnell-find [<options>] bom <file> ...
  13 #       Processes input files and produces BOM parts list.
  14 #   ./farnell-find [<options>] order-bom <file> ...
  15 #       Processes input files and adds BOM parts to cart.
  16 #
  17 # Options:
  18 #   -S<sort>
  19 #       Specifies sort order for BOM.  Several may be specified, first
  20 #       one on the command line is least significant.  Can be `desc'
  21 #       `avail' `price'.  Default sort order is avail, then price,
  22 #       then desc (equivalent to -Sdesc -Sprice -Savail).
  23 #
  24 # Input format: lines, #-comments, blank lines ignored.
  25 # Indent level is relevant, but only 0, 1, >1 relevant.
  26 # Order of information in a file is not relevant unless explicitly
  27 # stated below.
  28 #
  29 #   <Circuit Name>
  30 #        Starts a circuit.
  31 #        Circuit names must start with an uppercase letter.
  32 #    per <Iteratable>
  33 #        Starts an iteratable (ends at start of next cct).
  34 #        Iteratable name must start with uppercase letter,
  35 #        may contain any non-ws chars.
  36 #     <item> <qty> [<use>]
  37 #     <part> <qty> [<use>]
  38 #        Specifies that the circuit contains that part
  39 #        in the quantity specified.  Quantity is scaled
  40 #        by the iteratable's count if we're in an iteratable.
  41 #        <use> is any string starting with a non-ws char.
  42 #        <qty> is <num>[=] or <num>/<denom>[=].  <num> is
  43 #        an integer.  = says not to order one extra.  <denom>
  44 #        is an integer (meaning the number of gates to
  45 #        a device) or an integer followed by / (meaning we
  46 #        can't mix this use with other uses or other circuits).
  47 #   <part> = <item> [<desc]>
  48 #        Defines <part>.  <part> is a sequence of words each separated
  49 #        by one space.  Each word consists of some non-ws chars.  The
  50 #        first word may not consist entirely of digits and hyphens; no
  51 #        other words may consist entirely of digits, slashes and
  52 #        equals signs.  <desc> is any string starting with non-ws.
  53 #   <part prefix> ? = <desc prefix>
  54 #        Gives a default description of parts which have <part prefix>
  55 #        as an initial subsequence of words.  <part prefix> has the
  56 #        syntax of a <part>.  The description is used only if there is
  57 #        no more specific description, and the constructed description
  58 #        is <desc prefix> with a space and the remainder of the part
  59 #        name appended.
  60 #
  61 #   suppress <item>
  62 #   suppress <part glob>
  63 #        Suppresses all processing for all parts matching the
  64 #        glob.
  65 #
  66 #   count <count> <iteratable>
  67 #   include <circuit>        ) use only one of
  68 #   exclude <circuit>        )  include and exclude
  69 #
  70 #   end
  71 #        Ends the file.  Optional.
  72
  73 use strict;
  74 use POSIX;
  75 use IO::Handle;
  76 use IO::File;
  77 use LWP::UserAgent;
  78 use HTTP::Request;
  79 use HTTP::Request::Common;
  80 use HTTP::Response;
  81 use HTML::Entities;
  82
  83 our(@warn);
  84 our(@fault);
  85 # neither @warn nor @fault entries have trailing \n
  86
  87 our(%pkinddesc);
  88 # $pkinddesc{'a b c'} => 'y'  after `a b c ? = y'
  89
  90 our(%parts);
  91 # $parts{"$circuit\n$iteratable"}[]{Part}       or item
  92 # $parts{"$circuit\n$iteratable"}[]{Qty}
  93 # $parts{"$circuit\n$iteratable"}[]{Use}
  94 # $parts{"$circuit\n$iteratable"}[]{FileLine}
  95
  96 our(%partdef);
  97 # $partdef{"part name"}= $item;
  98
  99 our(%count);
 100 # $count{"$iteratable"} is number of times iteratable is instantiated
 101 #   (no syntax for specifying this atm)
 102
 103 our(%iteminstances);
 104 # @{ $iteminstances{$item} }  one entry for every line which mentions it
 105 # $iteminstances{$item}[]{Use}   includes circuit
 106 # $iteminstances{$item}[]{Qty}
 107 # $iteminstances{$item}[]{Mult}   number of this iteratable
 108 # $iteminstances{$item}[]{FileLine}
 109
 110 our(%itemdesc);
 111 # $itemdesc{$item}[]= $desc;
 112
 113 our(%iteminfo);
 114 # $iteminfo{$item}= by_item(...);
 115
 116 our(%show);
 117 # $show{$item}{Head}      ) newline terminated
 118 # $show{$item}{Info}      )  strings ready to print
 119 # $show{$item}{Price}     calculated value
 120
 121 our(%suppress_item);
 122 our(@suppress_partre);
 123
 124 our($incexc); # 'include' or 'exclude'
 125 our(%incexc); # $incexc{$circuit}= 1;   for those mentioned
 126
 127 our(@sorthow);
 128 # list of desc price avail
 129
 130 our($useragent);
 131 our($jsessionid);
 132
 133 our($partfrac_unique)= 'aaaa'; # increments
 134
 135 our($partword1_re)= '\S*[^ \t0-9-]\S*';
 136 our($partword_re)= '\S*[^ \t0-9/=]\S*';
 137 our($part_re)= "$partword1_re(?: $partword_re)*";
 138 our($item_re)= '\d{3}\-\d{3,7}';
 139
 140 our(%stockmap)= ('In Stock' => 'Y',
 141                  'Awaiting Delivery' => 'A');
 142 our($urlbase)= 'http://uk.farnell.com';
 143
 144 sub get_useragent () {
 145     my ($whoami,$mailname);
 146     return if defined $useragent;
 147     die "want http_proxy\n" unless exists $ENV{'http_proxy'};
 148     chomp($whoami= `whoami`); $? and die $?;
 149     chomp($mailname= `cat /etc/mailname`); $? and die $?;
 150     $useragent= new LWP::UserAgent(env_proxy => 1, keep_alive =>1);
 151 }
 152
 153 sub check_response ($$) {
 154     my ($response,$url) = @_;
 155     $response->is_success or die "$url ".$response->as_string." ?";
 156 }
 157
 158 sub by_item ($;$) {
 159     my ($itemcode,$why) = @_;
 160     # looks up $itemcode (ddd-d...) at Farnell and returns
 161     # cat hash ref
 162     local ($_);
 163     my ($chr,$shortcode,$sc2,$url,$price);
 164     $url= "$urlbase/jsp/catalog/viewproductdetails.jsp?prodId=";
 165     $itemcode =~ m/^(\d\d\d)\-(\d{3,7})$/ or die "$itemcode ?";
 166     $chr->{Item}= $itemcode;
 167     $chr->{Shortcode}= $1.$2;
 168     $url .= $chr->{Shortcode};
 169     if (!-f "farn.$itemcode") {
 170         my ($response);
 171         get_useragent();
 172         $response= $useragent->get($url);
 173         check_response($response, $url);
 174         $_= $response->content;
 175         open N, ">tmp.farn.$itemcode" or die $!;
 176         print N or die $!;
 177         close N or die $!;
 178         rename "tmp.farn.$itemcode", "farn.$itemcode" or die $!;
 179         unlink "tmp.farnerr.$itemcode";
 180     } else {
 181         $_= `cat farn.$itemcode`; $? and die $?;
 182     }
 183     s/[^\n\t\x20-\x7e\£]/\?/g;
 184     if (!eval {
 185         $sc2= snarf('Order Code / Sku');
 186         die "wrong results $sc2 ?\n" unless $sc2 eq $chr->{Shortcode};
 187         1;
 188     }) {
 189         my ($emsg);
 190         $@ =~ s/\n$//;
 191         $emsg= "item $itemcode: $@";
 192         $emsg.= " ($why)" if defined $why;
 193         push @warn, $emsg;
 194         return undef;
 195     }
 196     $chr->{Description}= snarf('Description');
 197     eval {
 198         my ($partno)= snarf('Manufacturer Part Number');
 199         $chr->{Description}= "[$partno] $chr->{Description}";
 200     };
 201     $chr->{Avail}= snarf('Stock Availability');
 202     $chr->{MinOrder}= snarf('Minimum Order');
 203     $chr->{Multiple}= snarf('Order Multiple');
 204     $price= snarf('Unit Price', "\n\<!--.*--\\>");
 205     $price =~ m/\£(\d+\.\d\d+)$/ or die "price $price ?";
 206     $chr->{Price}= $1;
 207     # price
 208     return $chr;
 209 }
 210
 211 sub snarf ($;$) {
 212     my ($thing, $allowbefore) = @_;
 213     $allowbefore= defined $allowbefore ? "(?:$allowbefore)?" : '';
 214     m!
 215 \<td class="tabledata"(?: width="\d+%")?\>$thing</td>
 216 \<td class="tabledata"(?: width="\d+%")?\>$allowbefore
 217 (.+)(?:\n\&nbsp\;)*
 218 \</td>
 219 !
 220     or die "no $thing ?\n";
 221     return $1;
 222 }
 223
 224 sub cart_add (@) {
 225     my (@orderlist) = @_;
 226     my ($i, $url, $item, $qty, @submit, $request, $response);
 227     my ($page_output);
 228     local ($_);
 229     need_jsessionid();
 230     $url= "$urlbase/jsp/op/shoppingbasket.jsp;jsessionid=$jsessionid";
 231     get_useragent();
 232     $response= $useragent->get($url);
 233     check_response($response, $url);
 234     $_= $response->content;
 235     if (!eval {
 236         while (@orderlist) {
 237             ($item, $qty, @orderlist) = @orderlist;
 238             m!(
 239 ?)(\<tr class=\"tabledata)((?:_alt)?)(\"\>
 240 ?\<td\>
 241 ?\<input type=\"text\" name=\"k1\" value=\")(\"[^<>]*\>
 242 ?\<input type=\"hidden\" name=\"_D:k1\" value=\" \"\>
 243 ?\</td\>
 244 ?\<td\>\<input type=\"text\" name=\"k3\" value=\")1(\"[^<>]*\>
 245 ?\<input type=\"hidden\" name=\"_D:k3\" value=\" \"\>
 246 ?\</td\>\<td\b[^<>]*\>\&nbsp\;\</td\>
 247 ?\</tr\>
 248 ?)((?:\<tr class=\"tabledata(?:_alt)?\"\>
 249 ?\<td\>
 250 ?\<input type=\"text\" name=\"k1\" value=\"\"[^<>]*\>
 251 ?\<input type=\"hidden\" name=\"_D:k1\" value=\" \"\>
 252 ?\</td\>
 253 ?\<td\>\<input type=\"text\" name=\"k3\" value=\"1\"[^<>]*\>
 254 ?\<input type=\"hidden\" name=\"_D:k3\" value=\" \"\>
 255 ?\</td\>\<td\b[^<>]*\>\&nbsp\;\</td\>
 256 ?\</tr\>
 257 ?)*\<tr\>
 258 ?\<td [^<>]* class=\"tableheading\"\>
 259 ?\<\!--td inset--\>
 260 ?\<table [^<>]*\>
 261 ?\<tr\>
 262 ?\<td align=\"right\" class=\"tabletotal\"\>
 263 ?Sub Total
 264 ?)!
 265                 or die "no blanks\n";
 266
 267             my ($page_head)= $`.$1;
 268             my ($entry_2alt, $entry_alt2item, $entry_item2qty, $entry_qty2)
 269                 = ($2,$4,$5,$6);
 270             my ($this_alt)= !!length $3;
 271             my ($page_tail)= $7.$';
 272
 273             $_= $page_head.
 274                 $entry_2alt. ($this_alt ? '' : '_alt').
 275                 $entry_alt2item. $item. $entry_item2qty. $qty. $entry_qty2.
 276                 ($this_alt ?
 277                  $entry_2alt.
 278                  $entry_alt2item. $entry_item2qty. 1 . $entry_qty2.
 279                  $entry_2alt.'_alt'.
 280                  $entry_alt2item. $entry_item2qty. 1 . $entry_qty2
 281                  : '').
 282                 $page_tail;
 283         }
 284
 285         m!\</head\>! or die "no </head>\n";
 286         $page_output= $`. "<base href=\"$urlbase\">\n" . $& . $';
 287         1;
 288     }) {
 289         die "$_ huh $@ ?" unless m/\<body [^<>]*\>/;
 290         $page_output= $`.$&.
 291             "<h1><strong>ERRORS FROM FARNELL-FIND:</strong></h1>\n".
 292             "<p><strong>".
 293             encode_entities($@).
 294             "</strong>\n".
 295             "<h1>In output data:</h1>\n".
 296             $';
 297     }
 298     open N, ">tmp.farn.basket.html" or die $!;
 299     print N $page_output or die $!;
 300     close N or die $!;
 301     exec 'w3m','./tmp.farn.basket.html'; die $!;
 302 }
 303
 304 sub read_spec ($) {
 305     my ($filename) = @_;
 306     local ($_);
 307     my ($circuit,$iteratable,$desc);
 308     my ($part,$qty,$use,$f);
 309     $f= new IO::File $filename, 'r' or die "$filename: $!\n";
 310     for (;;) {
 311         $_=<$f>;
 312         die "$filename: read: $!\n" if $f->error;
 313         last unless defined $_;
 314         chomp; s/\s+$//;
 315         last if m/^end$/;
 316         next if m/^\#/ || !m/\S/;
 317         if (m/^[A-Z].*$/) {
 318             $circuit= $&;
 319             $iteratable= '';
 320         } elsif (m/^ per ([A-Z]\S+)$/) {
 321             $iteratable= $1;
 322         } elsif (m/^ \S/) {
 323             die "$_ ?";
 324         } elsif (m,^\s+($part_re|$item_re)\s+([0-9/=]+)(?:\s+(\S.*))?$,) {
 325             ($part,$qty,$use) = ($1,$2,$3);
 326             $qty .= $partfrac_unique++ if $qty =~ m,/$,;
 327             push @{ $parts{"$circuit\n$iteratable"} }, {
 328                 Part => $part, Qty => $qty, Use => $use,
 329                 FileLine => "$filename:$."
 330             };
 331         } elsif (m/^($part_re)\s+\?\s+\=\s+(\S.*)$/) {
 332             die if exists $pkinddesc{$1};
 333             $pkinddesc{$1}= $2;
 334         } elsif (m/^($part_re)\s+\=\s+($item_re)(?:\s+(\S.*))?$/) {
 335             die if exists $partdef{$1};
 336             $partdef{$1}= $2;
 337             if (defined $3) {
 338                 push @{ $itemdesc{$2} }, "$1: $3";
 339             }
 340         } elsif (m/^suppress\s+($item_re)$/) {
 341             $suppress_item{$1}= 1;
 342         } elsif (m/^suppress\s+(\S.*)$/) {
 343             $_= $1; s/\s+/ /g;
 344             s/\W/ ($& eq '*' ? '.*' :
 345                    $& eq '?' ? '.' :
 346                    "\\$&") /ge;
 347             push @suppress_partre, $_;
 348         } elsif (m/^count\s+(\d+)\s+([A-Z].*)$/) {
 349             $count{$2}= $1;
 350         } elsif (m/^(include|exclude)\s+([A-Z].*)$/) {
 351             die "both include and exclude\n" if
 352                 defined $incexc && $incexc ne $1;
 353             $incexc= $1;
 354             $incexc{$2}= 1;
 355         } else {
 356             die "$_ ?";
 357         }
 358     }
 359     $f->close;
 360 }
 361
 362 sub itemsortmap ($) {
 363     my ($item) = @_;
 364     my ($o, $bi, $how, $price,$title);
 365     $o= '';
 366     $bi= $iteminfo{$item};
 367     if (!defined $bi) {
 368         $bi= { Avail => '?U' };
 369         $bi->{Description} = $itemdesc{$item} ? $itemdesc{$item}[0] : '?U';
 370     }
 371     foreach $how (@sorthow) {
 372         if ($how eq 'price') {
 373             $price= exists $show{$item} ? $show{$item}{Price} : 0.0;
 374             $o .= sprintf "%030.20f ", 1.0 / ($price + 0.0001);
 375         } elsif ($how eq 'desc') {
 376             $title= $bi->{Description};
 377             $title .= "\n".$1 if $title =~ s/^(\[[^][]+\]) //;
 378             $o .= "$title\n";
 379         } elsif ($how eq 'avail') {
 380             $o .= $bi->{Avail};
 381         } else {
 382             die;
 383         }
 384     }
 385     return $o;
 386 }
 387
 388 sub hrule () { print '-'x79, "\n" or die $!; }
 389
 390 sub iteminstanceprint ($) {
 391     my ($ii) = @_;
 392     my ($ql,$qr);
 393
 394     $ql= $ii->{Qty}; $qr= '';
 395     if ($ql =~ s/\D\d+$//) { $qr= $&; }
 396     if ($ql =~ s,(\d+)/[a-z]+$,,) { $qr= "$1/"; }
 397     if ($ql =~ s/\=//) { $qr .= $&; }
 398     return sprintf("%*s %5s%-2s %s%s\n",
 399                    (4+1+4),'',
 400                    $ql,$qr,
 401                    $ii->{Mult} != 1 ? "(x$ii->{Mult}) " : '',
 402                    $ii->{Use});
 403 }
 404
 405 sub analyse_spec ($) {
 406     my ($op) = @_;
 407     my ($part,$pd,$try,@rhs,$sp,$circuit,$iteratable,$count,$pe,$use);
 408     my ($item,$totalqty,$ii,$bi,$toorder,$price,$total,$notechar,$desc);
 409     my ($avail,%avail,$desclen,$why,$suppress,%suppress,$pi);
 410     my ($iteminstance,@orderlist);
 411     $desclen= 42;
 412     foreach $part (sort keys %partdef) {
 413         $item= $partdef{$part};
 414         next if exists $itemdesc{$item};
 415
 416         $try= $part;
 417         @rhs= ();
 418         for (;;) {
 419             if ($try !~ s/\s+(\S+)$//) {
 420                 push @{ $itemdesc{$item} }, $part;
 421                 last;
 422             }
 423             unshift @rhs, $1;
 424             if (exists $pkinddesc{$try}) {
 425                 push @{ $itemdesc{$item} }, join(' ', $pkinddesc{$try}, @rhs);
 426                 last;
 427             }
 428         }
 429     }
 430     foreach $sp (sort keys %parts) {
 431         $sp =~ m/\n/ or die "$sp ?";
 432         $circuit= $`;
 433         $iteratable= $';
 434         next if
 435             (defined $incexc && $incexc eq 'include')
 436                 xor exists $incexc{$circuit};
 437         if (exists $count{$iteratable}) {
 438             $count= $count{$iteratable};
 439         } else {
 440             push @warn, "assuming only 1 $iteratable" if length $iteratable;
 441             $count= 1;
 442         }
 443         foreach $pe (@{ $parts{$sp} }) {
 444             $use= $pe->{Use};
 445             $use= defined $use ? "$circuit: $use" : $circuit;
 446             $part= $pe->{Part};
 447             $suppress= 0;
 448             if ($part =~ m/^$item_re$/) {
 449                 $item= $part;
 450             } elsif (exists $partdef{$part}) {
 451                 $suppress= 1 if grep { $part =~ m/^$_$/ } @suppress_partre;
 452                 $item= $partdef{$part};
 453             } else {
 454                 push @fault, "unknown part $part ($pe->{FileLine})";
 455                 next;
 456             }
 457             $suppress= 1 if exists $suppress_item{$item};
 458             $iteminstance= {
 459                 Use => $use,
 460                 Qty => $pe->{Qty},
 461                 Mult => $count,
 462                 FileLine => $pe->{FileLine},
 463             };
 464             if ($suppress) {
 465                 push @{ $suppress{$item} }, iteminstanceprint($iteminstance);
 466             } else {
 467                 push @{ $iteminstances{$item} }, $iteminstance;
 468             }
 469         }
 470     }
 471     $total= 0;
 472     foreach $item (sort keys %iteminstances) {
 473         $why= defined $itemdesc{$item} ? $itemdesc{$item}[0].'; ' : '';
 474         $why .= join ",", map { $_->{FileLine} } @{ $iteminstances{$item} };
 475         $bi= by_item($item, $why);
 476         $iteminfo{$item}= $bi;
 477     }
 478     foreach $item (keys %iteminstances) {
 479         $totalqty= { };
 480         foreach $ii (@{ $iteminstances{$item} }) {
 481             addqty($totalqty, $ii->{Qty}, $ii->{Mult}, $item, $ii->{FileLine});
 482         }
 483         $bi= $iteminfo{$item};
 484         next unless $bi;
 485         ($toorder,$notechar)= calcorder($totalqty, $bi);
 486         next unless $toorder > 0;
 487         $price= $toorder * $bi->{Price};
 488         $avail= $bi->{Avail};
 489         $avail{$avail}= 1;
 490         $avail= ' '.$stockmap{$avail} if exists $stockmap{$avail};
 491         $show{$item}{Head}=
 492             sprintf("%4d%1s %-10s %-${desclen}.${desclen}s".
 493                     " %7.3f %7.2f%1s %s\n",
 494                     $toorder, $notechar, $item, $bi->{Description},
 495                     $bi->{Price}, $price, $notechar, $avail);
 496         $show{$item}{Info}= '';
 497         $total += $price;
 498         $show{$item}{Price}= $price;
 499         $show{$item}{ToOrder}= $toorder;
 500         foreach $desc (@{ $itemdesc{$item} }) {
 501             $show{$item}{Info} .=
 502                 sprintf("%*s %s\n",
 503                         (4+1+1+10),'',
 504                         $desc);
 505         }
 506         foreach $ii (@{ $iteminstances{$item} }) {
 507             $show{$item}{Info} .= iteminstanceprint($ii);
 508         }
 509     }
 510     if ($op eq 'order-bom') {
 511         dump_warnerrs();
 512     } else {
 513         printf " Qty  %-10s %-*s (ex VAT) Each Total Stock?\n\n",
 514             'Item', $desclen-7, 'Part no. and Description'
 515                 or die $!;
 516     }
 517     foreach $item (sort { itemsortmap($a) cmp itemsortmap($b); }
 518                    keys %show) {
 519         if ($op eq 'order-bom') {
 520             push @orderlist, $item, $show{$item}{ToOrder};
 521         } else {
 522             print $show{$item}{Head}, $show{$item}{Info}, "\n"
 523                 or die $!;
 524         }
 525     }
 526     if ($op eq 'order-bom') {
 527         cart_add(@orderlist);
 528         die;
 529     }
 530     printf("%*s %11s %-*s %6.2f\n",
 531            (5+1), 'TOTAL',
 532            '',
 533            ($desclen+1+6), join(' / ', sort keys %avail),
 534            $total)
 535         or die $!;
 536     print "\n" or die $!;
 537     if (keys %suppress) {
 538         print "---------- suppressed ----------\n" or die $!;
 539         foreach $item (sort { itemsortmap($a) cmp itemsortmap($b); }
 540                        keys %suppress) {
 541             $pi= $item;
 542             foreach $ii (@{ $itemdesc{$item} }) {
 543                 printf " %-10s %s\n", $pi, $ii
 544                     or die $!;
 545                 $pi= '';
 546             }
 547             if (length $pi) {
 548                 print " $pi\n" or die $!;
 549             }
 550             foreach $ii (@{ $suppress{$item} }) {
 551                 print $ii or die $!;
 552             }
 553         }
 554         print "\n" or die $!;
 555     }
 556     dump_warnerrs();
 557     hrule();
 558 }
 559
 560 sub addqty ($$$$) {
 561     my ($totalqty, $q2, $m2, $item) = @_;
 562     if ($q2 !~ m!^(\d+)(?:/(\d+)(?:/(\w+))?)?(\=?)$!) {
 563         push @fault, "bad quantity $q2 x$m2 for item $item";
 564         return;
 565     }
 566     my ($numer,$denom,$uniq,$exact) = ($1,$2,$3,$4);
 567     if (!$exact) {
 568         $totalqty->{Inexact}= 1;
 569     }
 570     $denom=1 if !defined $denom;
 571     $numer *= $m2;
 572     if (defined $uniq) {
 573         die if exists $totalqty->{Uniques}{$uniq};
 574         $totalqty->{Uniques}{$uniq}{Numer}= $numer;
 575         $totalqty->{Uniques}{$uniq}{Denom}= $denom;
 576     } else {
 577         if (!exists $totalqty->{Denom}) {
 578             $totalqty->{Denom}= $denom;
 579             $totalqty->{Numer}= $numer;
 580         } elsif ($denom ne $totalqty->{Denom}) {
 581             push @fault, "denominator for item $item changes from".
 582                 " $totalqty->{Denom} to $denom";
 583         } else {
 584             $totalqty->{Numer} += $numer;
 585         }
 586     }
 587 }
 588
 589 sub calcorder ($$) {
 590     my ($totalqty, $bi) = @_; # => ($toorder, $notechar);
 591     my ($notechar, $exact, $need, $uniq);
 592     $notechar= '';
 593     $exact= 0;
 594     if (!exists $totalqty->{Inexact}) {
 595         $exact= 1;
 596         $notechar= '=';
 597     }
 598     $need= 0;
 599     foreach $uniq (keys %{ $totalqty->{Uniques} }) {
 600         $need += calcneed($totalqty->{Uniques}{$uniq}, undef);
 601     }
 602     $need += calcneed($totalqty, \$notechar) if exists $totalqty->{Numer};
 603     $need++ if $need && !$exact;
 604     if ($need % $bi->{Multiple}) {
 605         $need= floor(($need + $bi->{Multiple} - 1) / $bi->{Multiple})
 606             * $bi->{Multiple};
 607         $notechar= '*';
 608     }
 609     if ($need && $need < $bi->{MinOrder}) {
 610         $need= $bi->{MinOrder};
 611         $notechar= '>';
 612     }
 613     ($need, $notechar);
 614 }
 615
 616 sub calcneed($$) {
 617     my ($tqr, $notechar) = @_;
 618     my ($want, $must);
 619     $want= $tqr->{Numer} * 1.0 / $tqr->{Denom};
 620     $must= ceil($want);
 621     $$notechar= '/' if $must>$want && $notechar;
 622     return $must;
 623 }
 624
 625 sub dump_warnerrs () {
 626     my ($w);
 627     my (%r);
 628     foreach $w (@fault) { next if $r{$w}++; print("ERROR: $w\n") or die $!; }
 629     foreach $w (@warn) { next if $r{$w}++; print("WARNING: $w\n") or die $!; }
 630     STDOUT->flush or die $!;
 631     die "errors\n" if @fault;
 632 }
 633
 634 @sorthow= qw(avail price desc);
 635
 636 while (@ARGV && $ARGV[0] =~ m/^\-/) {
 637     $_= shift @ARGV;
 638     last if m/^\-\-$/;
 639     if (m/^\-S(avail|price|desc)$/) {
 640         unshift @sorthow, $1;
 641     } else {
 642         die "unknown option \`$_'\n";
 643     }
 644 }
 645
 646 sub is_jsessionid ($) {
 647     my ($a) = @_;
 648     return undef unless
 649         $a =~ m/\;jsessionid=([0-9A-Z]+)\b/ ||
 650         $a =~ m/^([0-9A-Z]+)$/;
 651     return $1;
 652 }
 653
 654 sub need_jsessionid () {
 655     local ($_);
 656     my ($newjsid);
 657     return if defined $jsessionid;
 658     open TTY, "+< /dev/tty" or die $!;
 659     select((select(TTY), $|=1)[0]);
 660     print TTY "URL or jsessionid: " or die $!;
 661     $_= <TTY>; TTY->error and die $!;
 662     length or die;
 663     $newjsid= is_jsessionid($_);
 664     defined $newjsid or die;
 665     $jsessionid= $newjsid;
 666 }
 667
 668 sub main () {
 669     my ($op);
 670     my ($item, $a);
 671
 672     die unless @ARGV;
 673     $op= $ARGV[0] =~ m/^\d/ ? 'describe' : shift @ARGV;
 674
 675     if ($op eq 'describe') {
 676         my ($chr, $k);
 677         foreach $item (@ARGV) {
 678             $chr= by_item($item);
 679             dump_warnerrs();
 680             foreach $k (sort keys %$chr) {
 681                 printf "%-20s %s\n", $k, $chr->{$k} or die $!;
 682             }
 683         }
 684     } elsif ($op eq 'order') {
 685         my ($qty, @orderlist, $newjsid);
 686         while (@ARGV) {
 687             $a= shift @ARGV;
 688             if (defined($newjsid= is_jsessionid($a))) {
 689                 die if defined $jsessionid;
 690                 $jsessionid= $newjsid;
 691             } elsif ($a =~ m/^$item_re$/) {
 692                 die unless @ARGV;
 693                 $qty= shift @ARGV;
 694                 push @orderlist, $a, $qty;
 695             } else {
 696                 die "$a ?";
 697             }
 698         }
 699         if (!@orderlist) {
 700             for (;;) {
 701                 defined($_= <STDIN>) or last;
 702                 chomp;
 703                 s/^\s+//; s/\s+$//;
 704                 next if m/^\#/;
 705                 m/^($item_re)\s+(\d+)$/ or die "$_ ?";
 706                 push @orderlist, $1, $2;
 707             }
 708             die $! if STDIN->error;
 709         }
 710         cart_add(@orderlist);
 711     } elsif ($op eq 'bom' || $op eq 'order-bom') {
 712         my ($filename);
 713         foreach $filename (@ARGV) {
 714             read_spec($filename);
 715         }
 716         analyse_spec($op);
 717         exit !!@fault;
 718     } else {
 719         die;
 720     }
 721 }
 722
 723 main();