pctb/Commods.pm

   1
   2 package Commods;
   3 use IO::File;
   4
   5 use strict;
   6 use warnings;
   7
   8 BEGIN {
   9     use Exporter ();
  10     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  11     $VERSION     = 1.00;
  12     @ISA         = qw(Exporter);
  13     @EXPORT      = qw(&parse_masters %oceans %commods %clients
  14                       &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap);
  15     %EXPORT_TAGS = ( );
  16
  17     @EXPORT_OK   = qw();
  18 }
  19
  20 our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources;
  21 our %commods; # eg $commods{'Fine black cloth'}= $sources;
  22 our %clients; # eg $clients{'ypp-sc-tools'}= [ qw(last-page) ];
  23 # $sources = 's[l]b';
  24 #       's' = Special Circumstances; 'l' = local ; B = with Bleach
  25
  26 our (%pctb_commodmap,@pctb_commodmap);
  27
  28 my %colours; # eg $colours{'c'}{'black'}= $sources
  29 my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
  30
  31 sub parse_master_master1 ($$) {
  32     my ($mmfn,$src)= @_;
  33     my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
  34     my @ctx= ();
  35     while (<$mm>) {
  36         next if m/^\s*\#/;
  37         next unless m/\S/;
  38         s/\s+$//;
  39         if (m/^\%(\w+)$/) {
  40             my $colourkind= $1;
  41             @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
  42         } elsif (m/^commods$/) {
  43             @ctx= (sub { push @rawcm, lc $_; });
  44         } elsif (m/^ocean (\w+)$/) {
  45             my $ocean= $1;
  46             @ctx= (sub {
  47                 $ocean or die; # ref to $ocean needed to work
  48                                # around a perl bug
  49                 my $arch= $_;
  50                 $ctx[1]= sub {
  51                     $oceans{$ocean}{$arch}{$_} .= $src;
  52                 };
  53             });
  54         } elsif (m/^client (\S+)$/) {
  55             my $client= $1;
  56             $clients{$client}= [ ];
  57             @ctx= (sub {
  58                 my $bug= $_;
  59                 push @{ $clients{$client} }, $bug;
  60             });
  61         } elsif (s/^ +//) {
  62             my $indent= length $&;
  63             die "wrong indent $indent" unless defined $ctx[$indent-1];
  64             &{ $ctx[$indent-1] }();
  65         } else {
  66             die "bad syntax";
  67         }
  68     }
  69     $mm->error and die $!;
  70     close $mm or die $!;
  71
  72 #print Dumper(\%oceans);
  73 #print Dumper(\@rawcm);
  74
  75     %commods= ();
  76     my $ca;
  77     $ca= sub {
  78         my ($s,$ss) = @_;
  79 #print "ca($s)\n";
  80         if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
  81         die "unknown $&" unless defined $colours{$1};
  82         foreach my $c (keys %{ $colours{$1} }) {
  83             &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
  84         }
  85     };
  86     foreach (@rawcm) { &$ca($_,$src); }
  87 }
  88
  89 sub parse_masters () {
  90     parse_master_master1('master-master.txt','s');
  91 }
  92
  93 sub parse_pctb_commodmap () {
  94     undef %pctb_commodmap;
  95     foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; }
  96
  97     my $c= new IO::File '_commodmap.tsv' or die $!;
  98     if (!$c) { $!==&ENOENT or die $!; return 0; }
  99
 100     while (<$c>) {
 101         m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
 102         die if defined $pctb_commodmap{$1};  $pctb_commodmap{$1}= $2;
 103         die if defined $pctb_commodmap[$2];  $pctb_commodmap[$2]= $1;
 104         $commods{$1} .= 'b';
 105     }
 106     $c->error and die $!;
 107     close $c or die $!;
 108     return 1;
 109 }
 110
 111 1;