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
  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 # $sources = 's[l]b';
  23 #       's' = Special Circumstances; 'l' = local ; B = with Bleach
  24
  25 our (%pctb_commodmap,@pctb_commodmap);
  26
  27 my %colours; # eg $colours{'c'}{'black'}= $sources
  28 my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
  29
  30 sub parse_master_master1 ($$) {
  31     my ($mmfn,$src)= @_;
  32     my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!";
  33     my @ctx= ();
  34     while (<$mm>) {
  35         next if m/^\s*\#/;
  36         next unless m/\S/;
  37         s/\s+$//;
  38         if (m/^\%(\w+)$/) {
  39             my $colourkind= $1;
  40             @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
  41         } elsif (m/^commods$/) {
  42             @ctx= (sub { push @rawcm, lc $_; });
  43         } elsif (m/^ocean (\w+)$/) {
  44             my $ocean= $1;
  45             @ctx= (sub {
  46                 $ocean or die; # ref to $ocean needed to work
  47                                # around a perl bug
  48                 my $arch= $_;
  49                 $ctx[1]= sub {
  50                     $oceans{$ocean}{$arch}{$_} .= $src;
  51                 };
  52             });
  53         } elsif (s/^ +//) {
  54             my $indent= length $&;
  55             die "wrong indent $indent" unless defined $ctx[$indent-1];
  56             &{ $ctx[$indent-1] }();
  57         } else {
  58             die "bad syntax";
  59         }
  60     }
  61     $mm->error and die $!;
  62     close $mm or die $!;
  63
  64 #print Dumper(\%oceans);
  65 #print Dumper(\@rawcm);
  66
  67     %commods= ();
  68     my $ca;
  69     $ca= sub {
  70         my ($s,$ss) = @_;
  71 #print "ca($s)\n";
  72         if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; }
  73         die "unknown $&" unless defined $colours{$1};
  74         foreach my $c (keys %{ $colours{$1} }) {
  75             &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c});
  76         }
  77     };
  78     foreach (@rawcm) { &$ca($_,$src); }
  79 }
  80
  81 sub parse_masters () {
  82     parse_master_master1('master-master.txt','s');
  83 }
  84
  85 sub parse_pctb_commodmap () {
  86     undef %pctb_commodmap;
  87     foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; }
  88
  89     my $c= new IO::File '_commodmap.tsv' or die $!;
  90     if (!$c) { $!==&ENOENT or die $!; return 0; }
  91
  92     while (<$c>) {
  93         m/^(\S.*\S)\t(\d+)\n$/ or die "$_";
  94         die if defined $pctb_commodmap{$1};  $pctb_commodmap{$1}= $2;
  95         die if defined $pctb_commodmap[$2];  $pctb_commodmap[$2]= $1;
  96         $commods{$1} .= 'b';
  97     }
  98     $c->error and die $!;
  99     close $c or die $!;
 100     return 1;
 101 }
 102
 103 1;