pctb/Commods.pm

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