package Commods;
use IO::File;
+use HTTP::Request::Common ();
use strict;
use warnings;
@ISA = qw(Exporter);
@EXPORT = qw(&parse_masters %oceans %commods %clients
&parse_pctb_commodmap %pctb_commodmap @pctb_commodmap
- &get_our_version);
+ &get_our_version
+ &pipethrough_prep &pipethrough_run
+ &pipethrough_run_gzip
+ &cgipostform);
%EXPORT_TAGS = ( );
@EXPORT_OK = qw();
return 1;
}
-sub get_our_version ($) {
- my ($prefix);
- {
- no strict (qw(refs));
- ${ "${prefix}name" }= 'ypp-sc-tools yarrg';
- ${ "${prefix}fixes" }= 'lastpage';
- ${ "${prefix}version" }= `git-describe --tags HEAD`;
- $? and die $?;
+sub get_our_version ($$) {
+ my ($aref,$prefix) = @_;
+ $aref->{"${prefix}name"}= 'ypp-sc-tools yarrg';
+ $aref->{"${prefix}fixes"}= 'lastpage';
+ $aref->{"${prefix}version"}= `git-describe --tags HEAD`; $? and die $?;
+ return $aref;
+}
+
+sub pipethrough_prep () {
+ my $tf= IO::File::new_tmpfile() or die $!;
+ return $tf;
+}
+
+sub pipethrough_run ($$$@) {
+ my ($tf, $childprep, $cmd, @a) = @_;
+ $tf->flush or die $!;
+ $tf->seek(0,0) or die $!;
+ my $child= open GZ, "-|"; defined $child or die $!;
+ if (!$child) {
+ open STDIN, "<&", $tf;
+ &$childprep() if defined $childprep;
+ exec $cmd @a; die $!;
+ }
+ my $r;
+ { undef $/; $!=0; $r= <GZ>; }
+ defined $r or die $!;
+ close GZ or die "$! $?"; die $? if $?;
+ return $r;
+}
+sub pipethrough_run_gzip ($) {
+ pipethrough_run($_[0],undef,'gzip','gzip');
+}
+
+sub cgipostform ($$$) {
+ my ($ua, $url, $form) = @_;
+ my $req= HTTP::Request::Common::POST($url,
+ Content => $form,
+ Content_Type => 'form-data');
+ if ($url =~ m,^\.?/,) {
+ my $tf= pipethrough_prep();
+ print $tf $req->content() or die $!;
+#print STDERR "[[[",$req->content(),"]]]";
+ my $out= pipethrough_run($tf, sub {
+ $ENV{'REQUEST_METHOD'}= 'POST';
+ $ENV{'QUERY_STRING'}= '';
+ $ENV{'PATH_TRANSLATED'}= $url;
+ $ENV{'PATH_INFO'}= '';
+ $ENV{'HTTP_HOST'}= 'localhost';
+ $ENV{'REMOTE_ADDR'}= '127.0.0.1';
+ $ENV{'GATEWAY_INTERFACE'}= 'CGI/1.1';
+ $ENV{'DOCUMENT_ROOT'}= '.';
+ $ENV{'SCRIPT_FILENAME'}= $url;
+ $ENV{'SCRIPT_NAME'}= $url;
+ $ENV{'HTTP_USER_AGENT'}= 'Commods.pm local test';
+
+ foreach my $f (qw(Content_Length Content_Type)) {
+ $ENV{uc $f}= $req->header($f);
+ }
+#system 'printenv >&2';
+ }, "$url", "$url");
+ $out =~ m,^Content-Type: text/plain.*\n\n, or die "$out ?";
+ return $';
+ } else {
+ my $resp= $ua->request($url,$req);
+ die $resp->status_line unless $resp->is_success;
+ return $resp->content();
}
}
}
}
-sub bs_p_tsv ($) {
- my ($bs) = @_;
+sub bs_p_tsv ($$) {
+ my ($f, $bs) = @_;
if (exists $current->{$bs}{$stall}) {
my $si= $current->{$bs}{$stall};
- printf("\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!;
+ printf($f "\t%d\t%s", $si->{Price}, $si->{Qty}) or die $!;
} else {
- printf("\t\t") or die $!;
+ printf($f "\t\t") or die $!;
}
}
-sub main__tsv () {
+sub write_tsv ($) {
+ my ($f) = @_;
foreach $commod (sort keys %commod) {
$current= $commod{$commod};
my %stalls;
map { $stalls{$_}=1; } keys %{ $current->{Buy} };
map { $stalls{$_}=1; } keys %{ $current->{Sell} };
foreach $stall (sort keys %stalls) {
- printf("%s\t%s", $commod, $stall) or die $!;
- bs_p_tsv(Buy);
- bs_p_tsv(Sell);
- print("\n") or die $!;
+ printf($f "%s\t%s", $commod, $stall) or die $!;
+ bs_p_tsv($f, Buy);
+ bs_p_tsv($f, Sell);
+ print($f "\n") or die $!;
}
}
+ $f->error and die $!;
+ $f->flush or die $!;
+}
+
+sub main__tsv () {
+ write_tsv(\*STDOUT);
}
sub gzip ($) {
my ($raw) = @_;
- my $tf= IO::File::new_tmpfile() or die $!;
+ my $tf= pipethrough_prep();
print $tf $raw or die $!;
- $tf->flush or die $!;
- $tf->seek(0,0) or die $!;
- my $child= open GZ, "-|"; defined $child or die $!;
- if (!$child) {
- open STDIN, "<&", $tf;
- exec 'gzip'; die $!;
- }
- my $r;
- { undef $/; $!=0; $r= <GZ>; }
- defined $r or die $!;
- close GZ or die "$! $?"; die $? if $?;
- return $r;
+ return pipethrough_run($tf,undef,'gzip','gzip');
}
sub main__uploadyaarg () {
- my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean;
- my $island= $ENV{'YPPSC_ISLAND'}; die unless $island;
- my $content= {
- 'data' => [ undef, 'deduped.tsv.gz',
+ my %o;
+ $o{'ocean'}= $ENV{'YPPSC_OCEAN'} or die;
+ $o{'island'}= $ENV{'YPPSC_ISLAND'} or die;
+ $o{'timestamp'}= 10;
+ get_our_version(\%o, 'client');
+
+ my $tf= pipethrough_prep();
+ write_tsv($tf);
+ my $oz= pipethrough_run_gzip($tf);
+ $o{'data'}= [ undef, 'deduped.tsv.gz',
Content_Type => 'application/octet-stream',
- Content => ''
-]};
+ Content => $oz ];
+
+ my $dest= $ENV{'YPPSC_YAARG_SUBMIT'};
+
+ my $respcontent= cgipostform($ua, "$dest/commod-update-receiver", \%o);
+
+ print $respcontent();
}
sub main__uploadpctb () {
use strict (qw(vars));
use POSIX;
+use MIME::Entity;
use Commods;
$CGI::POST_MAX= 3*1024*1024;
-$CGI::DISABLE_UPLOADS= 1;
use CGI qw/:standard -private_tempfiles/;
return $1;
}
-my $clientname= must_param('clientname',$re_any);
-my $clientinfo= $clients{$clientname};
+my %o;
+
+$o{'clientname'}= must_param('clientname',$re_any);
+my $clientinfo= $clients{$o{'clientname'}};
fail('unknown client') unless defined $clientinfo;
my $clientfixes= must_param('clientfixes', "^([-0-9a-z ]*)\$");
my @clientfixes= sort grep { m/./ } split /\s+/, $clientfixes;
-$clientfixes= "@clientfixes";
+$o{'clientfixes'}= "@clientfixes";
foreach my $bug (@$clientinfo) {
fail("client out of date - missing bugfix \`$bug'")
unless grep { $_ eq $bug } @clientfixes;
}
-my $clientversion= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$");
+$o{'clientversion'}= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$");
-my $ocean= must_param('ocean', $re_any);
-my $island= must_param('island', $re_any);
+$o{'ocean'}= must_param('ocean', $re_any);
+$o{'island'}= must_param('island', $re_any);
-my $arches= $oceans{$ocean};
+my $arches= $oceans{$o{'ocean'}};
fail("unknown ocean") unless $arches;
my $island_found= 0;
foreach my $islands (values %$arches) {
- my $sources= $islands->{$island};
+ my $sources= $islands->{$o{'island'}};
next unless $sources;
die if $island_found;
$island_found= $sources;
}
fail("unknown island") unless $island_found;
-my $timestamp= must_param('timestamp', "^([1-9]\\d{1,20})\$");
+$o{'timestamp'}= must_param('timestamp', "^([1-9]\\d{1,20})\$");
my $now= time; defined $now or die $!;
-fail("clock skew") if $timestamp >= $now;
+fail("clock skew") if $o{'timestamp'} >= $now;
-die if $ocean =~ m/\=/;
-die if $island =~ m/\=/;
+die if $o{'ocean'} =~ m/\=/;
+die if $o{'island'} =~ m/\=/;
my $indatafh= upload('data');
defined $indatafh or fail("data is not a file");
my $datafile= must_param('data',"^(deduped\\.tsv\\.gz)\$");
-our %done;
-
my $mcontent= MIME::Entity->build(To => 'yarrg-commod-updates',
Type => 'multipart/mixed',
Boundary => '=',
Charset => 'utf-8');
-our ($servername,$serverversion,$serverfixes);
-get_our_version('::server');
-
-my $clientspec= "$clientname $clientversion $clientfixes";
-my $serverspec= "$servername $serverversion $serverfixes";
+get_our_version(\%o, 'server');
+foreach my $cs (qw(client server)) {
+ $o{"${cs}spec"}= join ' ', map { $o{$cs.$_} } qw(name version fixes);
+}
-foreach my $vn (qw(ocean island timestamp
- clientspec clientname clientversion clientfixes
- serverspec servername serverversion serverfixes)) {
+foreach my $vn (sort keys %o) {
my $mpart= MIME::Entity->build(Type => 'text/plain',
Charset => 'utf-8',
Disposition => 'inline',
- Data => $$vn);
+ Data => $o{$vn});
$mcontent->add_part($mpart);
}
-my $gunzchild= open(GZ, "-|") or die $!;
+my $gunzchild= open(GZ, "-|"); defined $gunzchild or die $!;
if (!$gunzchild) {
open STDIN, "<&=", $indatafh or die $!;
- execlp 'gunzip'; die $!;
+ exec 'gunzip'; die $!;
}
+sub bad_data ($) { fail("bad data: line $.: $_[0]"); }
+
+our %done;
+
while (<GZ>) {
!m/\P{IsPrint}/ or die bad_data('nonprinting char(s)');
!m/\\/ or bad_data('data contains backslashes');
@v==6 or bad_data('wrong number of fields');
my ($commod,$stall) = @v;
defined $commods{$commod} or bad_data("unknown commodity \`$commod'");
- $stall =~ m/^\p{IsUpper}/ or bad_data("stall not capitalised");
+ $stall =~ m/^\p{IsUpper}|^[0-9]/ or bad_data("stall not capitalised");
!exists $done{$commod,$stall} or bad_data("repeated data");
$done{$commod,$stall}= 1;
foreach my $i (2..5) {
my $f= $v[$i];
- $f =~ m/^(0|[1-9][0-9]{0,5}|\>1000)$/ or bad_data("bad field");
- ($i % 1) or ($f !~ m/\>/) or bad_data("> in price");
+ $f =~ m/^(|0|[1-9][0-9]{0,5}|\>1000)$/ or bad_data("bad field $i");
+ ($i % 2) or ($f !~ m/\>/) or bad_data("> in field $i price");
}
}
GZ->error and die $!;
Remora Island
Vernal Equinox
-client ypp-sc-tools yarr
+client ypp-sc-tools yarrg
lastpage
~yarrgweb / ypp-sc-tools.db-test.git / commitdiff