pctb/Commods.pm

   1
   2 package Commods;
   3 use IO::File;
   4 use HTTP::Request::Common ();
   5
   6 use strict;
   7 use warnings;
   8
   9 BEGIN {
  10     use Exporter ();
  11     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  12     $VERSION     = 1.00;
  13     @ISA         = qw(Exporter);
  14     @EXPORT      = qw(&parse_masters %oceans %commods %clients
  15                       &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap
  16                       &get_our_version
  17                       &pipethrough_prep &pipethrough_run
  18                       &pipethrough_run_gzip
  19                       &cgipostform);
  20     %EXPORT_TAGS = ( );
  21
  22     @EXPORT_OK   = qw();
  23 }
  24
  25 our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources;
  26 our %commods; # eg $commods{'Fine black cloth'}= $sources;
  27 our %clients; # eg $clients{'ypp-sc-tools'}= [ qw(last-page) ];
  28 # $sources = 's[l]b';
  29 #       's' = Special Circumstances; 'l' = local ; B = with Bleach
  30
  31 our (%pctb_commodmap,@pctb_commodmap);
  32
  33 my %colours; # eg $colours{'c'}{'black'}= $sources
  34 my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
  35
  36 sub parse_master_master1 ($$) {
  37     my ($mmfn,$src)= @_;
  38     my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
  39     my @ctx= ();
  40     while (<$mm>) {
  41         next if m/^\s*\#/;
  42         next unless m/\S/;
  43         s/\s+$//;
  44         if (m/^\%(\w+)$/) {
  45             my $colourkind= $1;
  46             @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
  47         } elsif (m/^commods$/) {
  48             @ctx= (sub { push @rawcm, lc $_; });
  49         } elsif (m/^ocean (\w+)$/) {
  50             my $ocean= $1;
  51             @ctx= (sub {
  52                 $ocean or die; # ref to $ocean needed to work
  53                                # around a perl bug
  54                 my $arch= $_;
  55                 $ctx[1]= sub {
  56                     $oceans{$ocean}{$arch}{$_} .= $src;
  57                 };
  58             });
  59         } elsif (m/^client (\S+.*\S)$/) {
  60             my $client= $1;
  61             $clients{$client}= [ ];
  62             @ctx= (sub {
  63                 my $bug= $_;
  64                 push @{ $clients{$client} }, $bug;
  65             });
  66         } elsif (s/^ +//) {
  67             my $indent= length $&;
  68             die "wrong indent $indent" unless defined $ctx[$indent-1];
  69             &{ $ctx[$indent-1] }();
  70         } else {
  71             die "bad syntax";
  72         }
  73     }
  74     $mm->error and die $!;
  75     close $mm or die $!;
  76
  77 #print Dumper(\%oceans);
  78 #print Dumper(\@rawcm);
  79
  80     %commods= ();
  81     my $ca;
  82     $ca= sub {
  83         my ($s,$ss) = @_;
  84 #print "ca($s)\n";
  85         if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
  86         die "unknown $&" unless defined $colours{$1};
  87         foreach my $c (keys %{ $colours{$1} }) {
  88             &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
  89         }
  90     };
  91     foreach (@rawcm) { &$ca($_,$src); }
  92 }
  93
  94 sub parse_masters () {
  95     parse_master_master1('master-master.txt','s');
  96 }
  97
  98 sub parse_pctb_commodmap () {
  99     undef %pctb_commodmap;
 100     foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; }
 101
 102     my $c= new IO::File '_commodmap.tsv' or die $!;
 103     if (!$c) { $!==&ENOENT or die $!; return 0; }
 104
 105     while (<$c>) {
 106         m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
 107         die if defined $pctb_commodmap{$1};  $pctb_commodmap{$1}= $2;
 108         die if defined $pctb_commodmap[$2];  $pctb_commodmap[$2]= $1;
 109         $commods{$1} .= 'b';
 110     }
 111     $c->error and die $!;
 112     close $c or die $!;
 113     return 1;
 114 }
 115
 116 sub get_our_version ($$) {
 117     my ($aref,$prefix) = @_;
 118     $aref->{"${prefix}name"}= 'ypp-sc-tools yarrg';
 119     $aref->{"${prefix}fixes"}= 'lastpage';
 120     $aref->{"${prefix}version"}= `git-describe --tags HEAD`; $? and die $?;
 121     return $aref;
 122 }
 123
 124 sub pipethrough_prep () {
 125     my $tf= IO::File::new_tmpfile() or die $!;
 126     return $tf;
 127 }
 128
 129 sub pipethrough_run ($$$@) {
 130     my ($tf, $childprep, $cmd, @a) = @_;
 131     $tf->flush or die $!;
 132     $tf->seek(0,0) or die $!;
 133     my $child= open GZ, "-|"; defined $child or die $!;
 134     if (!$child) {
 135         open STDIN, "<&", $tf;
 136         &$childprep() if defined $childprep;
 137         exec $cmd @a; die $!;
 138     }
 139     my $r;
 140     { undef $/; $!=0; $r= <GZ>; }
 141     defined $r or die $!;
 142     close GZ or die "$! $?";  die $? if $?;
 143     return $r;
 144 }
 145 sub pipethrough_run_gzip ($) {
 146     pipethrough_run($_[0],undef,'gzip','gzip');
 147 }
 148
 149 sub cgipostform ($$$) {
 150     my ($ua, $url, $form) = @_;
 151     my $req= HTTP::Request::Common::POST($url,
 152                                          Content => $form,
 153                                          Content_Type => 'form-data');
 154     if ($url =~ m,^\.?/,) {
 155         my $tf= pipethrough_prep();
 156         print $tf $req->content() or die $!;
 157 #print STDERR "[[[",$req->content(),"]]]";
 158         my $out= pipethrough_run($tf, sub {
 159             $ENV{'REQUEST_METHOD'}= 'POST';
 160             $ENV{'QUERY_STRING'}= '';
 161             $ENV{'PATH_TRANSLATED'}= $url;
 162             $ENV{'PATH_INFO'}= '';
 163             $ENV{'HTTP_HOST'}= 'localhost';
 164             $ENV{'REMOTE_ADDR'}= '127.0.0.1';
 165             $ENV{'GATEWAY_INTERFACE'}= 'CGI/1.1';
 166             $ENV{'DOCUMENT_ROOT'}= '.';
 167             $ENV{'SCRIPT_FILENAME'}= $url;
 168             $ENV{'SCRIPT_NAME'}= $url;
 169             $ENV{'HTTP_USER_AGENT'}= 'Commods.pm local test';
 170
 171             foreach my $f (qw(Content_Length Content_Type)) {
 172                 $ENV{uc $f}= $req->header($f);
 173             }
 174 #system 'printenv >&2';
 175         }, "$url", "$url");
 176         $out =~ m,^Content-Type: text/plain.*\n\n, or die "$out ?";
 177         return $';
 178     } else {
 179         my $resp= $ua->request($url,$req);
 180         die $resp->status_line unless $resp->is_success;
 181         return $resp->content();
 182     }
 183 }
 184
 185 1;