#!/perl   # just to get emacs into perl mode when editing this

package packets;

use strict;
use English '-no_match_vars';
use GameConfig;
use Getopt::Long;

local $WARNING = 1;     # same as usual -w option
local $OUTPUT_AUTOFLUSH = 1;



#############################################################################
# Command-line options and configuration file.
# We do a first pass through the command-line options since that
# might give a non-default config file, then we parse the config file,
# then we parse the command line leftovers using that data.

### First pass through command line:

Getopt::Long::config("default");
Getopt::Long::config(qw( auto_abbrev bundling permute ));

my @argv = ();  # @ARGV "leftovers" to re-process

my %opt;
# defaults:
$opt{config} = "bin/packets.config";

Getopt::Long::GetOptions
  (\%opt,
   qw( extract|e latex|l xdvi|x dvips|d gv|g print|p ),    # actions
   qw( all-characters|a ingame|i:s config=s ), # flags
   "only" => \&later, "except" => \&later,
   "help|h" => sub { die "\n" },
   "<>" => \&later)
  or &usage;

sub later { 
  my $arg = shift;
  defined shift and $arg = "--$arg";
  push @argv, $arg;
}

sub usage { 
  die "Syntax: gmX packets [options] [charfiles] [--only|--except fieldlist]
     [charfiles] is one or more Charsheets/ files (.tex suffix optional),
       unless --all-characters was used, for whom to do packets.
     By default all extractable fields are used.
       --only uses only the listed ones.
       --except uses all except the listed ones.
     Non-options after --only or --except are fieldnames; before that
       they are charfile names.  Otherwise, options may occur in any order,
       and the single-character versions may be bundled (-abc).
     --help, -h             print this usage message and exit
     --config=configfile    use 'configfile' instead of bin/packets.config
     --all-characters, -a   do not specify [charfiles]; do (almost) all present
     --extract, -e          extract fields from charsheets
     --latex, -l            latex tex-type extractables (must --extract first)
     --xdvi, -x             preview results of --latex
     --dvips, -d            generate ps for all material (must --latex first)
     --gv, -g               preview results of --dvips
     --print, -p            lpr results of --dvips
     --ingame, -i[=mode]    do initial read and/or write ingame (see html doc)
   See html/printing-packets.html for details.\n";
}

### Now that we know what the config file is, read it:
my %config;  # misc config file information, like extra dvips headers
my %extract; # config file defns of extractable fields (incl charsheets)
GameConfig::packets_config($opt{config}, \%config, \%extract);


### Second (and last) pass through command line:

my $characters_in = GAME::path "Charsheets";  # .structure translation
GAME::chdir "Charsheets";  # will want to look at what charfiles exist

my %optstate = ();
my @char = ();

@ARGV = @argv;  # parsing leftovers saved from first pass
Getopt::Long::GetOptions
  ("only" => \&inclusion, "except" => \&inclusion, 
   "<>" => \&process)
  or &usage;

defined $optstate{"inclusion"} or inclusion("except"); # do all if nothing said


sub inclusion {
  my ($flag, $val) = @_;
  &usage if defined $optstate{"inclusion"};  # can't do it twice
  $optstate{"inclusion"} = $flag eq "except"; # default "do this extract?"
  for (keys %extract) { 
    $extract{$_}{"do"} = $optstate{inclusion};  # set to default
  } 
}

sub process {
  my $arg = shift;
  if (defined $optstate{"inclusion"}) {  # treat as extractable field name
    my $field = GameConfig::match_extractable(\%extract, $arg);
    $extract{$field}{"do"} = !$optstate{"inclusion"};  # switch to non-default
  }
  else {  # treat as character file
    $arg .= ".tex" unless $arg =~ /\.tex$/;
    -f $arg or die "no such character file $arg in $characters_in\n";
    $arg =~ s/\.tex$//;
    push @char, $arg;
  }
}



########################################################################
# Remaining state setup based on results of parsing command line.

if (exists $opt{"all-characters"}) {
  @char and die "may not give specific chars when using --all-characters\n";
  @char = sort grep { !/^\./ && -f && s/\.tex$// && !/^template$/
		    } GM::contents;
}
@char or die "no chars!\n";

my @dofield = sort grep { $extract{$_}{'do'} } keys %extract
  or die "no extractable fields specified to extract\n";

my @action = grep { exists $opt{$_} } qw( extract latex xdvi dvips gv print )
  or die "no actions specified to perform\n";

my $anylists = grep { $extract{$_}{"type"} eq "list" } @dofield;


# determine whether reading, writing, both, or neither should be
# in game dir ("") instead of the usual tmp dir ("/")
my ($readfrom, $writeto) = qw( / / );
if (exists $opt{ingame}) {
  $opt{ingame} =~ /\A[rw]?\Z/ or die 
    "valid -i,--ingame args are --ingame --ingame=r --ingame=w -i -ir -iw\n";
  $opt{ingame} =~ /\Ar?\Z/ and $readfrom = "";
  $opt{ingame} =~ /\Aw?\Z/ and $writeto = "";
}
#
# make sure the dirs we might need to write to exist
for my $sub (qw( / Extracts DVI PS )) {
  my @relative = split "/", GAME::path "Charsheets/$sub";
  my $need = $writeto;
  while (defined (my $step = shift @relative)) {
    $need .= "/$step";
    my $dir = GM::path $need;
    -d $dir or GM::mkdir ($dir, 0700) or die "Unable to create $dir: $!\n";
  }
}
# after the first write-to, we reset $readfrom to $writeto.
# that is, with -ld you read the latex from somewhere, write the
# dvi to somewhere else, then read the dvi from the latter and write ps.



############################################################################
# Perform requested actions, in order.

# only really nasty conditions will make us die immediately; usually we
# will attempt to continue to the end of the current action as much as
# possible.  at that point, we'll abort if anything sufficiently bad happened.
#
my $abort = 0;


if (exists $opt{"extract"}) {
  print "\tExtracting fields\n";

  # clean up previous extracts first
  GAME::chdir "${writeto}Charsheets/Extracts";
  my @old = GM::contents;
  for my $char (@char) {
    GM::unlink grep /^\Q$char\E\^/, @old;
  }
  
  # regardless of $readfrom, we get charsheets themselves from actual game dir
  my $truechar = GM::path "Charsheets";
  GAME::chdir "${writeto}Charsheets/DVI";
  @old = GM::contents;
  for my $char (@char) {
    print "\t\t$char\n";
    # a little cleanup here too
    GM::unlink grep /^\Q$char\E\....\Z/, @old;
    # and then latex with extraction activated
    my $sendto = GM::path "${writeto}Charsheets/Extracts";
    GM::latex 
      "\\def\\WriteGameExtractsAlongPath{$sendto} \\input $truechar/$char",
      "$char.tex to extract fields",
      $writeto;
  }
  $readfrom = $writeto;
  $abort and die "Fatal errors while extracting\n"
}



if (exists $opt{"latex"}) {
  print "\tLatex'ing tex-type extractables\n";
  GAME::chdir "${writeto}Charsheets/DVI";
  my @old = GM::contents;
  for my $char (@char) { 
    print "\t\t$char\n";
    for my $field (@dofield) {
      if ($extract{$field}{"type"} eq "tex") {
	print "\t\t\t$field ";
	my $base = "$char^$extract{$field}{'compress'}";
	GM::unlink grep /^\Q$base\E\....\Z/, @old;  # cleanup of old stuff
	my $file = GM::path "${readfrom}Charsheets/Extracts/$base";
	if (-e "$file.tex") {
	  print "\n";
	  GM::latex $file, "${char}'s $field"; 
	}
	else {
	  print "not present - presumed not in charsheet\n";
	}
	# if necessary, make zero-length dvi file as a placeholder
	-e "$base.dvi" or close GM::open ">$base.dvi";
      }
    }
    if ($readfrom ne $writeto) {
      # things created by -e and used by -d must be copied over
      local $INPUT_RECORD_SEPARATOR = undef;
      local $OUTPUT_RECORD_SEPARATOR = undef;
      for my $special ("Extracts/$char^.Lists", "Extracts/$char^.Name.tex",
		       "DVI/$char.dvi") {
	my $rd = GAME::open "${readfrom}Charsheets/$special";
	my $wr = GAME::open ">${writeto}Charsheets/$special";
	print $wr (<$rd>);
	close $rd;
	close $wr;
      }
    }
  }
  $readfrom = $writeto;
  $abort and die "Fatal errors while latex'ing tex-type extractables\n";
}



if (exists $opt{"xdvi"}) {
  print "\tXdvi'ing material latex'd by packets\n";
  GAME::chdir "${readfrom}Charsheets/DVI";
  for my $char (@char) {
    print "\t\t$char\n";
    for my $field (@dofield) {
      print "\t\t\t$field";
      if ($extract{$field}{"type"} eq "list") {
	print " are list-type\n";
	next;
      }
      my $file = ($extract{$field}{"type"} eq "tex")
	? "$char^$extract{$field}{'compress'}.dvi"
	  : "$char.dvi";  # must be type "char"
      if (not -e $file) {
	print " file not found!\n";
      }
      elsif (-z $file) {
	print " (none; presumed none in charsheet)\n";
      }
      else {
	print "\n";
	GM::xdvi $file;
      }
    }
  }
  if (exists $opt{"dvips"}) {
    print "Abort to fix things? [n] ";
    <STDIN> =~ /^\s*y/i and exit 0;
  }
}
      


### Read in the ^.Lists file (if $anylists), parse the ones we're doing,
### return and cache anon hash of that info
my %listinfo;
sub read_lists {
  my $char = shift;
  exists $listinfo{$char} and return $listinfo{$char};
  $listinfo{$char} = {};
  $anylists or return;  # info should never get looked at in this case!
 
  my $fh = GAME::open "${readfrom}Charsheets/Extracts/$char^.Lists";
  my ($field, $base);
  while (<$fh>) {
    if (/^\s*EXTRACTABLE\s+(.*?)\s*$/) {
      $field = $1;
      exists $extract{$field}
	or die " nonexistent extractable '$field' listed!\n";
      $extract{$field}{"type"} eq "list"
	or die "non-list-type extractable '$field' listed!\n";
      if ($extract{$field}{"do"}) {
	my $compress = $extract{$field}{"compress"};
	my $path = GM::path "$compress/DVI";
	$listinfo{$char}{$field}{"path"} = $path;
	if (-d $path) {
	  $listinfo{$char}{$field}{"base"} = "$char^$compress";
	  $listinfo{$char}{$field}{"files"} = {};
	}
	else {
	  print "no $field source dir $path; will abort\n";
	  delete $listinfo{$char}{$field};
	  $abort = 1;
	}
      }
    }
    elsif (/^\s*(.*?):\s*(NORMAL|SECRET)\s+(\S+)\s*$/) {
      my ($f, $expose, $file) = ($1, $2, $3);
      if ($f ne $field) {
	print "$f listed in the $field section!  will abort\n";
	$abort = 1;
      }
      elsif (exists $listinfo{$char}{$field}) {
	$listinfo{$char}{$field}{"files"}{$file} = $expose;
      }
    }
    else {
      print "$char^.Lists has bad line; will abort:\n\t$_\n";
      $abort = 1;
    }
  }
  close $fh;
  return $listinfo{$char};
}


# When you dvips foo.dvi -o bar.ps, the bar.ps gets comments in it with
# that command line.  So if either "foo" or "bar" contains information,
# e.g. "traitorcop^Greensheets:eattheirbrains.dvi", it's bad if we want
# to give the postscript to players, e.g. with email parts.  So we
# make symlinks pointing blah1.dvi to foo.dvi and blah2.ps to bar.ps;
# then "dvips blah1.dvi -o blah2.ps" creates bar.ps out of foo.dvi but
# knows only that it's dealing with these meaningless blahs, so only
# those appear in the ps file comments.  Whee!
### mask_dvips (source.dvi, dest.ps, options)
sub mask_dvips {
  my ($dvi, $ps, @opt) = @_;
  my $mask = GM::path "/.gm.$PID/game-file-mask";
  GM::unlink "$mask.dvi", "$mask.ps";
  GM::symlink $dvi, "$mask.dvi";
  GM::symlink $ps, "$mask.ps";
  GM::dvips "$mask.dvi", "-q", @opt, "$mask.ps";
}


if (exists $opt{"dvips"}) {
  print "\tDvips'ing to postscript files\n";
  GAME::chdir "/.gm.$PID";  # process-specific temporary storage
  # include @dvipsopt for all but special things
  my @dvipsopt = map { "-h $_" } split " ", $config{headers};
  for my $char (@char) {
    print "\t\t$char\n";

    my $list = read_lists($char);
    GM::unlink "charnameheader.eps";  # cleanup of old stuff for list-types
    GAME::latex ("${readfrom}Charsheets/Extracts/$char^.Name", 
		 "${char}'s name header");
    # no @dvipsopt for this one, it's a middleman
    mask_dvips("$char^.Name.dvi", "charnameheader.eps", "-E");

    # .Lists, .Name prep done; now do actual extracts
    for my $field (@dofield) {
      print "\t\t\t$field ";
      if ($extract{$field}{"type"} eq "char") {
	my $ps = GM::path "${writeto}Charsheets/PS/$char.ps";
	GM::unlink $ps;  # cleanup of old stuff
	my $file = GM::path "${readfrom}Charsheets/DVI/$char";
	if (-e (my $dvi = "$file.dvi")) {  # should never be zero-length
	  print "\n";
	  mask_dvips($dvi, $ps, @dvipsopt);  
	}
	else {
	  print ".dvi not found!  did you do -l?  will abort.\n";
	  $abort = 1;
	}
      }
      elsif ($extract{$field}{"type"} eq "tex") {
	my $base = "$char^$extract{$field}{'compress'}";
	GM::unlink "$base.ps";   # cleanup of old stuff
	my $file = GM::path "${readfrom}Charsheets/DVI/$base";
	my $to = GM::path "${writeto}Charsheets/PS/$base.ps";
	if (-e (my $dvi = "$file.dvi")) {
	  if (-s $dvi) {
	    print "\n";
	    mask_dvips($dvi, $to, @dvipsopt);
	  }
	  else {
	    print "(none; presumed none in charsheet)\n";
	    # make zero-length ps file as a placeholder
	    close GM::open ">$to";
	  }
	}
	else {
	  print ".dvi not found!  did you do -l?  will abort.\n";
	  $abort = 1;
	}
      }
      elsif ($extract{$field}{"type"} eq "list") {
	my $stuff = $list->{$field}
	  or print "absent\n" and next;
	print "\n";
	my @files = keys %{$stuff->{"files"}} 
	  or print "\t\t\t\t(none)\n" and next;
	my $base = $stuff->{"base"};
	my $path = $stuff->{"path"};
	for my $file (@files) {
	  print "\t\t\t\t$file ";
	  my $expose = $stuff->{"files"}{$file};
	  my $dvi = "$path/$file.dvi";
	  unless (-e $dvi) {
	    print ".dvi not found! will abort.\n";
	    $abort = 1;
	    next;
	  }
	  print "\n";
	  my @header = ($expose eq "SECRET") ? qw( -h charname_secret ) : ();
	  my $dest = GM::path "${writeto}Charsheets/PS/$base:$file.ps";
	  mask_dvips($dvi, $dest, @header, @dvipsopt);
	}
      }
    }
    GM::unlink "charnameheader.eps";  # so as not to screw up later dvipsing
  }
  $readfrom = $writeto;
  $abort and die "Fatal errors while dvips'ing\n";
}



if (exists $opt{gv}) {
  print "\tGV'ing dvips output\n";
  GAME::chdir "${readfrom}Charsheets/PS";
  for my $char (@char) {
    print "\t\t$char\n";
    my $list = read_lists($char);
    for my $field (@dofield) {
      print "\t\t\t$field ";
      if ($extract{$field}{"type"} eq "list") {
	my $stuff = $list->{$field}
	  or print "absent\n" and next;
	print "\n";
	my @files = keys %{$stuff->{"files"}}
	  or print "\t\t\t\t(none)\n" and next;
	my $base = $stuff->{"base"};
	for my $file (@files) {
	  print "\t\t\t\t$file\n";
	  GM::gv "$base:$file";
	}
      }
      else {
	my $file = ($extract{$field}{"type"} eq "tex")
        ? "$char^$extract{$field}{'compress'}.ps"
          : "$char.ps";  # must be type "char"
	if (not -e $file) {
	  print " file not found!\n";
	}
	elsif (-z $file) {
	  print " (none; presumed none in charsheet)\n";
	}
	else {
	  print "\n";
	  GM::gv $file;
	}
      }
    }
  }
  if (exists $opt{"print"}) {
    print "Abort to fix things? [n] ";
    <STDIN> =~ /^s*y/i and exit 0;
  }
}


my (%bychar, %byfile, %byprinter, %guild, %host, %ip, $jobid, %queuemap);
if (exists $opt{"print"}) {
  print "\tPrint: planning out what to print where\n";
  GAME::chdir "${readfrom}Charsheets/PS";
  for my $char (@char) {
    print "\t\t$char\n";
    my $list = read_lists($char);
    for my $field (@dofield) {
      print "\t\t\t$field ";
      my $base = "$char^$extract{$field}{'compress'}";
      if ($extract{$field}{"type"} eq "char") {
	$abort += intend($char, $field, "$char.ps");
      }
      elsif ($extract{$field}{"type"} eq "tex") {
	$abort += intend($char, $field, "$base.ps");
      }
      elsif ($extract{$field}{"type"} eq "list") {
	my $stuff = $list->{$field}
	  or print "absent\n" and next;
	print "\n";
	my @files = keys %{$stuff->{"files"}}
	  or print "\t\t\t\t(none)\n" and next;
	my $base = $stuff->{"base"};
	for my $file (@files) {
	  print "\t\t\t\t$file ";
	  $abort += intend($char, $field, "$base:$file.ps");
	}
      }
    }
  }
  $abort and die "Fatal errors while planning out printing\n";

  
  print "\tPrint: examining printers";
  # look at info for printers, set which are thought to be the Guild's;
  # see snmptranslate [-n or -d] on the dotted strings for info
  my $snmploc = ".1.3.6.1.2.1.1.6.0";   # location, w20-4xx* assumed Guild
  my $snmpcon = ".1.3.6.1.2.1.1.4.0";   # contact info
  for my $pr (keys %byprinter) {
    if (grep /^assassin\b/i, $pr, $host{$pr}) { # ok, these are obvious ones
      $guild{$pr} = 1;
    }
    else {
      my $ip = $ip{$pr};
      my $info = GM::snmpget "-v 1 $ip public $snmploc $snmpcon";
      $guild{$pr} = ($info =~ /sysLocation.*\"w20-4\d\d/i or
		     $info =~ /sysContact.*\"(high-council\@|assassin\b)/i);
    }
    print ".";
  }
  print "\n";
  # check for potential printer problems
  for (my $recheck = 1; $recheck; $recheck = <STDIN> !~ /\A\s*y\s*\Z/i) {
    for my $printer (sort keys %byprinter) {
      my $filterstatus;
      my $q = queue($printer, \$filterstatus);
      my $busy = ($$q{jobs} > 10 ? "($$q{jobs} jobs already)" : "");
      print "\t\t$printer $$q{status}  $busy\n";
      print "\t\t  $filterstatus\n";
    }
    print "\tAre those ok? Hit 'y' to go on, 'n' to recheck, ctrl-c to quit: ";
  }

  print "\tPrint: sending jobs to printers\n";
  my $qmapfile = GM::path "Charsheets/Q-$ENV{USER}-$PID";
  my $qmap = GM::open ">$qmapfile";
  select $qmap and $OUTPUT_AUTOFLUSH = 1 and select STDOUT;
  my @todo = @char;     # chars not finished yet
  my %sent = ();        # everything that's gone to the printers
  while (@todo) {
    my %current = ();   # what's currently thought to be in printers
    my %q = ();         # printer queue information
    for my $printer (keys %byprinter) {
      $q{$printer} = queue($printer);
      $q{$printer}{status} and
	warn "\t\tPRINTER TROUBLE: $printer status $q{$printer}{status}\n";
      if (my @gmfiles = @{$q{$printer}{gmfiles}}) {
	undef @current{@gmfiles};
      }
    }
    my @ps = ();  # things to lpr this round

    # char on top should be all in printers
    if (my @left = grep { not exists $sent{$_} } @{$bychar{$todo[0]}}) {
      push @ps, @left;
    }
    elsif (not grep { exists $current{$_} } @{$bychar{$todo[0]}}) {
      print "\t\tCharacter $todo[0] done\n";
      shift @todo;
    }
    else {
      # if a printer has no current game stuff, has a short queue, 
      # or is thought to be the Guild's, send more stuff
      for my $printer (keys %byprinter) {
	my %qp = %{$q{$printer}};
	my ($job) = grep { not exists $sent{$_} } @{$byprinter{$printer}};
	push @ps, $job if $job and 
	  ($guild{$printer} or not @{$qp{gmfiles}} or $qp{jobs} < 10);
	unless ($job or @{$qp{gmfiles}}) {
	  print "\t\tPrinter $printer done\n";
	  delete $byprinter{$printer};
	}
      }
    }
    
    for my $ps (@ps) {
      my ($printer, $lpropt) = @{$byfile{$ps}}{"printer", "lpropt"};
      print "\t\tSending $ps to $printer $lpropt\n";
      my $job = "$PID-" . ++$jobid . ".ps";
      $queuemap{$job} = $ps;
      print $qmap "$job\t$printer\t\t$ps\n";
      GM::lpr("-P$printer $lpropt -J$job $ps");
      undef $sent{$ps};
    }

    sleep 1;
  }
  print "\t\tEverything seems to be out of the printers now\n";
  GM::unlink $qmapfile;

  $readfrom = $writeto;
  $abort and die "Fatal errors while printing\n";
}
sub intend {
  my ($char, $field, $ps) = @_;
  unless (-e $ps) {
    print "file not found; will abort\n";
    return 1;
  }
  if (-z $ps) {
    print "file is empty; will skip\n";
    return 0;
  }
  my $printer = $extract{$field}{"printer"};
  my $lpropt = $extract{$field}{"lpropt"};
  unless ($ip{$printer}) {
    ($host{$printer}) = (GM::lpc("printcap $printer") =~ /:lp=(.*)%/, 
			 "$printer-p");
    if (my $addr = gethostbyname $host{$printer}) {
      $ip{$printer} = join ".", unpack('C4', $addr);
    }
    else {
      print "printer $printer not found; will abort\n";
      return 1;
    }
  }

  push @{$bychar{$char}}, $ps;        # list of jobs for each character
  push @{$byprinter{$printer}}, $ps;  # list of jobs for each printer
  $byfile{$ps} = { "printer" => $printer, "lpropt" => $lpropt };

  print "will go to $printer $lpropt\n";
  return 0;
}
sub queue {
  my $printer = shift;
  my @q = split "\n", GM::lpq("-P$printer");
  if (my $filter = shift) {  ($$filter) = map { /(Filter_status: .*)/ } @q  }
  my $x = "";
  # shift off everything before jobs header line
  $x = shift @q while @q and not 
    ($x =~ /rank/i and $x =~ /owner/i and $x =~ /job/i and $x =~ /files/i);

  # topmost job is usually rank "active" but may be "1" momentarily first
  my ($status) = split / /, (@q ? $q[0] : "active");
  $status = "" if $status =~ /^active/i or $status eq "1";
  
  my @gmfiles = @queuemap{ map { /\b($PID-\d+.ps)\b/o } 
			     grep { /\b\Q$ENV{USER}\E\b/io } @q };
 
  return { "status" => $status, "jobs" => scalar(@q), "gmfiles" => \@gmfiles };
}



print "Packets done.\n";