#!/usr/athena/bin/perl -w

=head1 NAME

  gm - wrapper script around Template perl files

=head1 SYNOPSIS

  alias gmfoo '~/gm --game=/mit/assassin/games/Foo'
  gmfoo pac -ae

=head1 DESCRIPTION

See html/gm.html for the user's point of view.

From the wrapped script's point of view, gm will do() it after
finishing checks and setup.  At that point it is in package main
and at the directory gm was started from.

All of gm's important state and safety features are kept in lexically
scoped variables.  It is therefore impossible for the wrapped script
to ever change or view them itself, being out of scope; it can only
do what gm-provided functions compiled in the same scope allow.

Two packages, GM and GAME, are written in by gm; they provide utilities 
for the wrapped script.  While the wrapped script is perfectly free
to change around the contents of these packages, this will never help it,
since restricted operations cannot be I<compiled> by the time the
wrapped script is in play, regardless of what package they are put into.
Wrapped scripts are advised to treat GM and GAME as read-only for
their own benefit.

=cut


package GM;  # stay out of the way, have subs in well-defined place

use strict;      # and don't make any global variables! lexical all the way!

# don't use any modules that allow unsafe operations, as those modules
# will be freely available to the later script, having been compiled here.

use English '-no_match_vars';
use Getopt::Long;
use Opcode;
use Symbol;
use Time::Local;


=head1 COMMAND LINE

See html/gm.html and/or gm --help for the options and their effects.
We use Getopt::Long to parse the command line.

=cut

######################################################################
# Deal with the command line.

Getopt::Long::config("no_auto_abbrev", "bundling", "require_order");

my %opt;
GetOptions(\%opt, qw( game=s help|h tmp=s unsafe version )) or &usage;
$opt{help} and &usage;
if ($opt{version}) {
  # We have the CVS tags for Id and Name planted here; CVS automatically
  # fills in the information.  The Name gets the tag when one is present;
  # this is blank on the mainline, but informative on a branch and,
  # more importantly, when a tag is exported.  The end result should
  # look like "Template v1-5 gm 1.8 last modified 1999/12/17".
  # The export will do -kv so that the dollar signs and keyword names
  # are stripped off, so use regexps that will work with and without them.
  my $id = 'gm,v 1.52 2004/03/22 21:06:11 jemorris Exp';
  my ($gmvers, $year, $mon, $mday, $hours, $min, $sec) =
    $id =~ m<\S+,v\s+(\d\S*)\s+(\d+)/(\d+)/(\d+)\s+(\d+):(\d+):(\d+)>;
  my ($d, $m, $y) =
    (localtime(timegm($sec, $min, $hours, $mday, $mon-1, $year-1900)))[3..5];
  my $date = sprintf "%4d/%02d/%02d", $y+1900, $m+1, $d;
  my $tag = 'v1-6-0';
  $tag =~ s/\$\S*//g;
  $tag =~ s/\s//g;
  length $tag or $tag = "mainline";
  print "Template $tag gm $gmvers last modified $date\n";
  exit 0;
}
$opt{game} or print("gm: --game=GAME argument is mandatory.\n") and &usage;
$opt{tmp} ||= join "-", "/tmp/$ENV{USER}", 
  (split "/+", "default/template/$opt{game}")[-2, -1];
$opt{unsafe} ||= 0;

sub usage {
  die "\nSyntax: gm [gm options] [script [script arguments]]
    Meant to be run out of your homedir via aliases that set --game,
    e.g. alias gmfoo '~/gm --game=/mit/assassin/games/foo';
    see html/dotfiles.html.

    The first non-option is taken as a script and sought in \$GAME/bin
    (subject to optional .structure; see html/structure.html) unless
    gm's options cause it to exit first.  If a file of that name exists
    there and is a readable, executable, non-empty plain file, it is
    read in and executed as Perl code with the remaining arguments on
    the command line as its command line.  If no file by that name is there
    gm will try to treat the name as an abbreviation and look for 
    matches (but you must supply at least three characters); if a unique
    match is found it is used.  If multiple matches are found (e.g. if
    no script is given and everything in bin/ matches) gm will list
    the candidates (readable, executable, non-empty plain files) and exit.

    See html/gm.html for details from the user's viewpoint;
    run perldoc on the gm script for info for writers of wrapped scripts,
    and see gm script comments and code for deeper details.

    --help, -h      Print this message and exit.

    --version       Print Template and gm version information and exit.

    --game=GAME     Specify directory path that \$GAME must agree with
                    (that is, they must result in the same dir; the strings 
                    can differ).  Mandatory unless --help or --version.

    --tmp=tmpdir    Instead of ensuring that /tmp/\$USER-foo-bar/
                    (where --game=/.../foo/bar) is available as working space
                    for the wrapped script, use tmpdir.  Must be absolute path.

    --unsafe        Turn off safety features around wrapped script;
                    this is not recommended.
  \n";   
}

my $script = shift;  # first non-option is on top and should be scriptname


=head1 OPERATION AND ENVIRONMENT RESTRICTIONS

Perl's base Opcode module is used to restrict what operations can be
performed by the wrapped script.  Quick sketch: there's a finite set
of possible Perl primitive operations, labelled by "opcodes".  When a
piece of Perl code is I<compiled>, it is tokenized with the operations
providing opcode information.  The Opcode module allows opcodes to
be masked out, after which code involving them will no longer compile.
Since the gm script itself has been compiled before the masking runs,
gm-provided functions are not at all affected.  Since the wrapped script
has not been compiled yet, it and everything it might possible do in
any way I<are> affected.  See the Opcode pod for full information.

There are a number of operations, such as opening files, that we wish
to allow in some cases (game files) but not in general.  Those opcodes
are masked out, and the GM and GAME packages provide calls to code
compiled in gm that execute the operation if they decide it is safe.

Spawning of other processes is obviously one of the masked operations.
Therefore, a number of the calls provided by GM and GAME spawn limited
versions of particularly necessary executables.  These are executed from
a specific locker (via athrun) if and only if users are not expected to
always have one in their path on reasonably modern Athena machines.

Because (la)tex is one such, we delete $ENV{shell_escape} which if
set to true allows TeX code to perform arbitrary system calls.
To avoid trojans, we also edit $ENV{PATH} to remove non-absolute
paths.  

If the --unsafe option is used, no opcode masking is performed and the
environment is not safety-edited.  (However, we do always edit LPROPT
to punt header pages.)  Otherwise, we store a copy of the edited %ENV
and restore it local()ly for all code called here, so that environment
changes made by the wrapped script are not potent in GM/GAME calls.

=cut

#######################################################################
# Make sure later-compile things (ie the script we will do()) are safe.
#
unless ($opt{unsafe}) {
  Opcode::opmask_add        # mask out (disallow)
    (Opcode::invert_opset   #   everything not in
     (Opcode::opset         #     this list:
      qw( :base_core :base_mem :base_loop :base_io :base_orig !dbmopen
	  :base_math :filesys_read :sys_db
	  !:filesys_open close closedir umask
	  exit time tms
	  sleep alarm sort tied pack unpack 
	  entereval require dofile
	  caller reset dbstate
	  !:filesys_write !:subprocess !:others !:dangerous
	))); 

  # no TeX shell escapes
  delete $ENV{"shell_escape"};  
  # get rid of relative things (e.g. ".") in PATH
  $ENV{PATH} = join ":", grep /^\//, split ":", $ENV{PATH}; 
}

# punt header pages
defined $ENV{LPROPT} or $ENV{LPROPT} = "";
$ENV{LPROPT} = join " ", $ENV{LPROPT}, "-h";

# keep a private (lexical) copy of clean environment to use while doing things
my %gmENV = %ENV unless $opt{unsafe};


#########################################################################
# Utility functions, lexically closed, will need to use right away.

my $die = sub {   # uncatchable, unstoppable die
  warn ("gm: " . shift() . "\n");
  exit -1;
};

my $pwd = sub {
  (my $ans = `pwd`) =~ s/\n\Z//;
  $? and $die->("can't get pwd");
  return $ans;
};


#########################################################################
# Basic sanity checks.

defined $ENV{GAME} 
  or die "GAME is not set\n";

my $game;  # full actual path, not /mit/foo/bar; this'll be saved
{
  for my $spec ({ -path => $opt{game}, -src => "--game" },
		{ -path => $ENV{GAME}, -src => "GAME"   })
    {
      $$spec{-path} =~ m(^/) or die
	"$$spec{-src} must be an absolute path; '$$spec{-path}' is relative\n";
      chdir $$spec{-path} or die
	"gm: unable to cd to ($$spec{-src}) $$spec{-path}\n";
      (my $here = $pwd->()) =~ s(/+\Z)();
      defined $game and $here ne $game and die
	"GAME and --game do not agree\n\t($here vs $game)\n";
      $game = $here;
    }
}

=head1 TEMP WORKING DIRS PROVIDED

See html/gm.html about the main temporary working dir provided to the
wrapped script (generally /tmp/username-foo-bar).

That directory is the same for every gm process by the same user
on the same machine with the same $GAME, barring use of --tmp.
To facilitate gm-wrapped scripts avoiding conflicts between multiple 
instances of themselves when for some reason they need a constant filename,
each gm process creates in the temp dir a .gm.$PID subdir.

=cut

$opt{tmp} =~ m(^/)
  or die "--tmp must be given absolute path; '$opt{tmp}' is relative\n";

chdir $opt{tmp} or (mkdir $opt{tmp}, 0700 and chdir $opt{tmp})
  or die "can neither go to nor create tmp directory $opt{tmp}\n";
my $tmp = $pwd->();   # full actual path, not /mit/foo/bar
$tmp =~ s(/+\Z)();
mkdir ".gm.$PID", 0700;  # for process-specific private temp storage




##########################################################################
# Read game's optional .structure configuration file. (see html/structure.html)

my %path;
if (open FH, ".structure") {
  while (<FH>) {
    s/%.*//;    # comments
    next unless /\S/;
    (my @data = split) == 2 or die "bad \$GAME/.structure line:\n\t$_\n";
    $path{$data[0]} = $data[1];
  }
  close FH;
}
$path{""} = "";


=head1 GAME PATH INTERPRETATION

Functions in package GM use exactly the paths they are given;
B<GM::chdir>(I<path>) does the same as perl's core B<chdir>(I<chdir>)
(beyond checking that the path is ingame; see section on functions).

Functions in package GAME typically map some or all of them (each function 
will document what it maps).  The mapping of I<path> involves two things.
If a $GAME/.structure exists and I<path> matches something in it, it
will be translated as per html/structure.html.  $GAME is then prepended to 
I<path>, unless I<path> starts with a slash, in which case the temporary 
directory is prepended.

Examples: assume that $GAME/.structure translates Foo/Bar to FB but does
nothing else; assume the temporary directory is /tmp/user-blah/.
Then 

  X/Y/Z                 maps to         $GAME/X/Y/Z
  /X/Y/Z                maps to         /tmp/user-blah/X/Y/Z
  Foo/Bar/Baz/Quux      maps to         $GAME/FB/Baz/Quux
  /Foo/Bar/Baz/Quux     maps to         /tmp/user-blah/FB/Baz/Quux

Note that the current directory is irrelevant to the mapping; if you
want to act relative to the current dir, use the non-mapping GM functions
instead of the GAME functions.

B<GM::path()> and B<GAME::path()> are provided for looking at mappings;
see below.


=head1 FUNCTIONS PROVIDED IN PACKAGE GM

These are prototyped, so parentheses around their args are usually optional.
Nothing is exported; call them with explicit package prefixes.

Many file and directory arguments are noted as "must be ingame"; this
means that they must be either under $GAME or in the temp dir provided
by gm.  It is an uncatchable fatal error for them not to be.  
If --unsafe is set, these checks automatically pass without looking.

If gm decides it cannot properly perform the function, it will usually die();
the wrapper may catch this as usual.  Particularly upsetting problems
will cause an uncatchable abort (warn and exit); in particular, this happens
for any failed "ingame" check, or if spawning a child doesn't work properly.
Functions will document their failure modes in those cases where they are
likely to result from bad data elsewhere (e.g. calling latex on a potentially
nonworking .tex file) but may not do so for lack of mandatory arguments and
other such errors from the calling script, since those must be fixed in
the caller regardless.

For internal consistency, functions run with $INPUT_RECORD_SEPARATOR
and $OUTPUT_RECORD_SEPARATOR locally set to undef; thus values returned from
spawned processes, for example, are a single string, not split on newline.


=head2 (string) B<GM::path> (I<path>)

Returns the mapping of I<path> according to the rules given above
under "Game Path Intepretation."  Compare with B<GAME::path()>.

=cut

# translate to game path; relatives in $game, "absolutes" in $tmp
sub paths ($) {
  my $base = shift;
  my $tail = "";
  $base =~ s(/+)(/)g;
  my $root = ($base =~ s(^/)()) ? $tmp : $game;
  while (not exists $path{$base}) {
    $base =~ s<(/|[^/]*)\Z><>;
    $tail = $1 . $tail;
  }
  return ($root, $path{$base} . $tail);
}
sub path ($) { return join "/", GM::paths shift }


##########################################################################
# Figure out what to run.

my $bin = GM::path "bin";
chdir $bin or die "gm: unable to go into $bin to seek scripts\n";

sub checkscript {
  local $_ = shift;
  -e or return "no such file";
  -f or return "not a plain file";
  -T or return "not a text file";
  -s or return "empty";
  # avoid having README and packets.config and so on look like options
  # by testing for user executable bit; but not with -x, it'd DTWT in AFS.
  (stat)[2] & 00100 or return "not executable";
  return undef;
}
if ($script and -e $script) {
  if (my $err = checkscript($script)) { die "$script: $err\n" }
  # otherwise we'll use $script
}
else {
  my @poss = grep { not /~$/ and not checkscript($_) } <*>;
  if ($script) {  # specified but not found exactly; might be abbrev
    length $script > 2 
      or die "'$script' not in $bin (and abbrevs must be 3+ chars)\n";
    my @match = grep { /^\Q$script\E/o } @poss;
    @match > 1 and die "'$script' ambiguous: ", (join ' or ', @match), "\n";
    @match < 1 and die "nothing matching '$script' in $bin\n";
    $script = $match[0];
  }
  else {  # wasn't specified
    die "No script specified to use; $bin has\n", map { "\t$_\n" } @poss;
  }
}


#######################################################################
# Key closure'd functions for checking that file/dir args are safe
# and for doing safe exec'ing for limited system calls.

# Change directories; die if this leaves game area.
# If $chdir_rebound has been set, go back whence it came
# (i.e. probe the given dir to see it is ingame, but stay put).
#
my $chdir_rebound = 0;
my $chdir = sub ($) {
  my $dest = shift;
  my $from = $pwd->() if $chdir_rebound;
  unless (CORE::chdir $dest) {
    warn "gm: unable to chdir $dest\n";
    exit 1;
  }
  unless ($opt{unsafe}) {
    my $here = $pwd->();
    $here =~ m(\A\Q$game\E(?![^/]))o or $here =~ m(\A\Q$tmp\E(?![^/]))o
      or $die->("$here is not in $game nor $tmp!");
  }
  $chdir_rebound and (CORE::chdir $from or $die->("Unable to reset dir"));
};

# $ingame->(integer skip, arguments)
# skips the first "skip" args, then treats the rest as files and dirs
# that must be in the game area.  this is an assertion, not a calculation,
# the return value isn't good for anything.
#
my $ingame = sub ($@) {
  return if $opt{unsafe};
  my @list = @_;
  $chdir_rebound = 1;
  my $skip = shift;
  shift while $skip--;
  for my $check (@list) {
    if (-e $check and -d $check) {   # directory
      $chdir->($check);
    }
    elsif (-l $check) {     # symlink
      my $symto = readlink $check;
      if ($symto !~ m(^/) and $check =~ s</+([^/]+)/*\Z></>) {
	$check .= $symto;
      }
      else {
	$check = $symto;
      }
      redo;  # if this puts you in infinite loop, you deserve it
    }
    else {    # plain file or nonexistent dir
      $check =~ s(/+[^/]*/*\Z)(/) or next;  # OK if in current dir
      $chdir->($check);
    }
  }
  $chdir_rebound = 0;
};

# $exec->() is used internally to spawn processes.
# Never let the shell get its hands on anything.
# Split all args on whitespace for convenience.
my %execopt = ();  # for optional behavior tweaks; cleared each time
my $exec = sub ($@) {
  my ($call, @arg) = @_;
  if (CORE::open EXEC, "-|") {  # implicit fork, parent here
    %execopt = ();  # child has tweaks; clear them here for later
    my $result = <EXEC>;
    close EXEC or $die->("fatal error in exec of $call @arg");
    return $result;
  }
  else {  # child
    $execopt{no_stderr} and close STDERR;
    # yes, that's really "exec $call $call" with no comma; this "lies"
    # to the program (2nd $call) that its name is really 1st $call,
    # and more importantly forces list interpretation even if no @arg,
    # so that the shell never gets to touch it.
    exec $call $call, @arg   # no shell interpretation!
      or               # should never return from exec
	$die->("gm exec of $call returned somehow (impossible; $!)");
  }
};




#######################################################################
# Set up limited calls to generally unsafe things.

# Predeclare them for compiler and for prototypes.
# Implementation and pod are below in %call, used by AUTOLOAD.

sub chdir ($);
sub chmod (@);
sub chown (@);
sub contents (;$);
sub dvips (@$);
sub gv ($@);
sub latex ($;$$);
sub link ($$);       # hard links! rarely want
sub lpc ($;$);
sub lpq ($@);
sub lpr ($@);
sub lynx (@$);
sub mkdir ($$);
sub open ($);  
sub opendir ($);
sub pager ();
sub pwd ();
sub rename ($$);
sub rmdir ($);  
sub snmpget ($@);
sub symlink ($$);
sub truncate ($$);
sub unlink (@);   
sub utime (@);    
sub xdvi (@$);

# define the subs as entries in %call; AUTOLOAD will call them.
# pod as we go.
my %call;

=head2 B<GM::> B<chdir>, B<chmod>, B<chown>, B<link>, B<mkdir>, B<rename>,
B<rmdir>, B<symlink>, B<truncate>, B<unlink>, B<utime>

These just check that their file and directory arguments are ingame and
then pass their args to the core Perl call.

=cut

# chdir is easy, since we need an internal safe one anyway
$call{"chdir"}    = sub { $chdir->(@_) };

# trivial "check everything is ingame and do it" funcs
$call{"link"}     = sub { $ingame->(0, @_); CORE::link shift, shift };
$call{"rename"}   = sub { $ingame->(0, @_); CORE::rename shift, shift };
$call{"rmdir"}    = sub { $ingame->(0, @_); CORE::rmdir @_ };
$call{"symlink"}  = sub { $ingame->(0, @_); CORE::symlink shift, shift };
$call{"unlink"}   = sub { $ingame->(0, @_); CORE::unlink @_ };

# teeny bit nontrivial, not every arg is a file/directory
$call{"chmod"}    = sub { $ingame->(1, @_); CORE::chmod @_ };
$call{"chown"}    = sub { $ingame->(2, @_); CORE::chown @_ };
$call{"utime"}    = sub { $ingame->(2, @_); CORE::utime @_ };
# args to skip are last here, not first
$call{"mkdir"}    = sub { $ingame->(0, $_[0]); CORE::mkdir shift, shift };

# can take either (open) filehandle or filename as first arg
$call{"truncate"} = sub {
  my ($target, $length) = @_;
  ref $target eq "GLOB" or $ingame->(0, $target);
  CORE::truncate $target, $length;
};

=head2 (filehandle reference) B<GM::open> (I<expression>)

I<expression> should be a suitable second argument for Perl's
core call of the same name.  It may not involve piping or FDs.
The file referred to must be ingame; if it is a dotfile, it
may not be written to.  If these calls all pass, an anonymous
glob is generated courtesy of Symbol, CORE::open(anon glob, I<expression>)
is executed, and the anon glob, now usable as a reference to an open 
filehandle, is returned.  $sym = GM::open "foo"; close $sym; is typical.

=cut

$call{"open"} = sub {
  my $full = shift;
  $full =~ m(\|) and $die->("open($full): piping not allowed");
  (my $name = $full) =~ s/^(\+?(<|>>?)(&(=\d+)?)?)//;
  my $mode = $1;
  -d $name and die "cannot open() a directory, use opendir()\n";
  if (defined $mode and not $opt{unsafe}) {
    $mode =~ /&=\d+/ and $die->("open($full): FDs disallowed"); 
    $mode =~ />/ and $name =~ m{(^|/)\s*\.[^/]*\Z} 
      and $die->("open($full): may not write to dotfiles");
  }
  $ingame->(0, $name);
  my $sym = Symbol::gensym;
  CORE::open $sym, $full or die "can't open $full: $!\n";
  return $sym;
};

=head2 (directory handle reference) B<GM::opendir> (I<expression>) 

Like B<GM::open> above; if the expression is an ingame directory,
a new symbol is generated, opendir'd on it, and returned.

=cut

$call{"opendir"} = sub {
  my $dir = shift;
  $ingame->(0, $dir);
  my $sym = Symbol::gensym;
  CORE::opendir $sym, $dir or die "can't open $dir: $!\n";
  return $sym;
};

=head2 (list) B<GM::contents> ([I<directory>])

Provides limited globbing.  I<directory> must be ingame if specified;
it defaults to ".".  The result of readdir() on a dir handle opened on
that directory are returned; this is equivalent to glob(directory/*) but 
never does shell interpretation.  Callers usually want to grep the results.

=cut

$call{"contents"} = sub {  
  # general globbing is too hard to keep `rm -rf` out of, so
  # contents("real_directory") gets <real_directory/*>
  # and you can just grep that
  my $dir = shift || ".";
  $ingame->(0, $dir);
  my $dh = Symbol::gensym;
  CORE::opendir $dh, $dir or die "can't open $dir to ls: $!\n";
  my @contents = readdir $dh;
  CORE::closedir $dh or die "GM::contents() closedir($dir) failed: $!\n";
  return @contents;
};

# Now things that aren't normal Perl ops.

=head2 B<GM::dvips> (I<dvips options list>..., I<outfile>)

If safe, executes "C<dvips -R I<dvips options list> -oI<outfile>>"
where I<dvips options list> has been split on whitespace.
Here I<outfile> must be ingame.

If a F<./config.ps> file is present, the operation aborts, as "E" lines
there bypass C<-R> and are therefore unsafe.

If --unsafe is set, the C<-R> is not added, I<outfile> may be arbitrary,
and F<./config.ps> may exist.

To print a .dvi, GM::dvips into postscript and GM::lpr the result.

If C<-q> is in the dvips options list, dvips will be spawned with STDERR
closed, as otherwise a dvips bug causes it to spew parts of header info.

=cut

$call{"dvips"} = sub {
  my $out = pop or die "dvips destination file missing\n";
  my @arg = map { split } @_;
  my $arg = join " ", @arg;
  "$arg $out" =~ /\s-P/ and die "GM::dvips does not take -P; go through lpr\n";
  unless ($opt{unsafe}) {
    unshift @arg, "-R";
    $ingame->(0, $out);
    $out =~ /^!/ and die "illegal escape in dvips $arg -o $out\n";
    -e "./config.ps" 
      and die "dvips not safe; ./config.ps exists (@{[&$pwd]})\n";
  }
  # -q is insufficient to get it to shut up 100%, so:
  $execopt{no_stderr} = grep { $_ eq "-q" } @arg;
  $exec->("dvips", @arg, "-o", $out);
};

=head2 B<GM::gv> (I<filename>, I<gvArgList...>)

I<gvArgList> is split on whitespace for convenience.
Unless --unsafe is set, I<filename> must be ingame, 
the C<-nosafer> option is not allowed, and C<-safer> is
added to the argument list.  Executes B<gv> (from sipb locker)
on I<filename> with the modified argument list.

=cut

$call{"gv"} = sub {
  my $file = shift or die "gm: gv: no file specified\n";
  my @arg = map { split } @_;
  unless ($opt{unsafe}) {
    for my $arg (@arg) {
      grep /^\Q$arg\E$/, qw( -nosafer )
	and die "gm: gv option $arg is not allowed\n";
    }
    push @arg, qw( -safer );
  }
  $exec->("athrun", "sipb", "gv", $file, @arg);
};

=head2 B<GM::latex> (I<target>, [I<errmsg>, [I<writeout>]])

If safety checks are passed, spawns "C<latex I<target>>"; 
I<target> is not split on whitespace and may contain TeX code
(or simply a filename, of course).  It may not contain latex
switches, such as C<-shell-escape>, unless --unsafe is set.

If I<writeout> is "/", $TEXMFOUTPUT will be set to $GAME first.
If I<writeout> is "", it will be set to the temporary directory.
This is only needful when the latex job has output into unusual places.
With I<writeout> undef the user's $TEXMFOUTPUT is left alone.
For other values the behavior is not defined.

Problems spawning latex cause a fatal error.
If the latex spawns but fails, a simple die() occurs (and can be caught)
containing latex's output followed by a complaint that [script name]
had a problem latex'ing I<errmsg>.
If the latex succeeds, its output is quietly returned.

=cut

$call{"latex"} = sub {
  my ($arg, $err, $writeto) = @_;
  $arg =~ /^[^\w\\]*-/ and $die->("can't use latex options: $arg")
    unless $opt{unsafe};
  # some complications are needed to get latex's output
  # while not having it hang waiting for input on an error
  if (CORE::open FROMEXEC, "-|") {  # implicit fork; parent here
    my $res = <FROMEXEC>;  # last char is success
    close FROMEXEC or $die->("Fatal error latex'ing $err");
    chop $res or die "$res\n$script: Failed latex'ing $err\n";
    return $res;
  }
  else {  # child
    if (CORE::open TOEXEC, "|-") {  # fork again! (hides stdin)
      # result of this close indicates success; send to parent
      print STDOUT (close TOEXEC ? 1 : 0);  
      exit;
    }
    else { # unto the second generation
      local $ENV{TEXMFOUTPUT} = ($writeto ? $tmp : $game)
	if defined $writeto;
      exec "latex", $arg  # no shell interpretation!
	or                # should never come back from exec
	  $die->("exec of latex returned somehow (impossible; $!)");
    }
  }
};

=head2 (string) B<GM::lpc> (I<command>, I<printer>)

Executes and returns the value of C<lpc I<command> I<printer>>.
Only "status" and "printcap" are legal I<command> values unless --unsafe.

Note that if the print server does not allow the user to do this query,
it will return something like "no permission to control server\n" but
no error will occur.

=cut

$call{"lpc"} = sub {
  my ($cmd, $printer) = map { split } @_;
  $cmd or die "gm: lpc: no command given\n";
  $printer =~ /\A[a-z]/i or die "gm: lpc $cmd bad/missing printer $printer\n";
  unless ($opt{unsafe}) {
    grep { $_ eq $cmd } qw( status printcap )
      or die "gm: lpc $cmd illegal\n";
  }
  return $exec->("lpc", $cmd, $printer);
};

=head2 B<GM::lpq> (arguments), B<GM::lpr> (arguments)

The arguments are each split on whitespace for convenience to
form a complete list.  No safety checks are necessary.
Executes the function and returns its output.

=cut

$call{"lpq"} = sub { return $exec->("lpq", map { split } @_) };
$call{"lpr"} = sub { return $exec->("lpr", map { split } @_) };

=head2 (string) B<GM::lynx> (I<lynx option list>..., I<url>)

Use lynx (from infoagents locker) to get the contents of I<url>,
which must be an ingame file or else start with http: unless
--unsafe is set.

The arguments in the lynx option list are each split on whitespace
for convenience to form a complete list.

Either C<-source> (raw page code) or C<-dump> (interpreted page code) 
must be given.  The other allowed lynx options are C<-force_html>,
C<-historical>, C<-minimal>, C<-nolist>, C<-noredir>, C<-underscore>;
the options C<-nolog> and C<-restrictions=all> are automaticaly added.
If --unsafe is set, the options list is neither checked nor edited.

If C<-dump> is used, the output is edited so that the list of links
at the end that look like 
"file://localhost/mit/assassin/games/FooBar/hmtl/xyz.html" (or worse) become
"file $GAME/html/xyz.html" for legibility.

It is suggested the results be printed through B<GM::pager()>.

=cut

$call{"lynx"} = sub {
  my $html = pop or die "gm: lynx: no file nor URL specified\n";
  my @arg = map { split } @_;
  my ($out) = grep /\A-(dump|source)$/, @arg;
  unless ($opt{unsafe}) {
    $out or die "gm: lynx must use -dump or -source\n";
    for my $arg (@arg) {
      grep /^\Q$arg\E$/, qw( -dump -force_html -historical -minimal
			     -nolist -noredir -source -underscore) 
	or die "gm: lynx option $arg is not allowed\n";
    }
    push @arg, qw( -nolog -restrictions=all );
    $ingame->(0, $html) unless $html =~ /\Ahttp:/i;
  }
  my $read = $exec->("athrun", "infoagents", "lynx", @arg, $html);
  $out eq "-dump" and  # shorten horribly long file:// names
    $read =~ s<^(\s*\d+\.\s*file)://localhost\Q$game\E(\S+)$><$1 \$GAME$2>gmo;
  return $read;
};

=head2 (filehandle reference) B<GM::pager> ()

If the user's PAGER environment variable is set (remember that changes
the wrapped script makes to the environment are not visible in these
functions), that pager is used.  Otherwise, "less" is used and
LESS is set to "C<-eMsX>" if not already set.

An anonymous symbol is created, opened as piping to the pager, and
returned as a filehandle reference.  Example:

  my $pager = GM::pager();
  print $pager "Hello, user.\n";
  print $pager GM::lynx("-dump", $url);
  close $pager;

=cut

$call{"pager"} = sub {
  my $pgr;
  if (defined $ENV{PAGER}) {
    $pgr = $ENV{PAGER};
  }
  else {
    $pgr = "less";
    defined $ENV{LESS} or $ENV{LESS} = "-eMsX";
  }
  my $sym = Symbol::gensym;
  CORE::open $sym, "|$pgr" or die "can't open pipe to $pgr: $!\n";
  return $sym;
};

=head2 B<GM::pwd> ()

Returns the current path according to the system call B<pwd> with
trailing newline stripped.

=cut

$call{"pwd"} = $pwd;  # Already had to write that function for internal use.

=head2 B<GM::snmpget> (I<arguments list>)

The arguments are each split on whitespace for convenience to form 
the complete list.  The environment variable MIBS is local'y set
to "HOST-RESOURCES-MIB" to keep things fast; this probably means
that resources should be specified numerically.  Then C<snmpget>
is executed (from outland locker) and its output returned.
See the snmpget manpage.

=cut

$call{"snmpget"} = sub {
  local $ENV{MIBS} = "HOST-RESOURCES-MIB";
  return $exec->("athrun", "outland", "snmpget", map { split } @_);
};

=head2 B<GM::xdvi> (I<xdvi options list>..., I<file>)

The file must be ingame (with .dvi suffix added first if not present)
unless --unsafe.

The xdvi options arguments are each split on whitespace for convenience
to form a complete list.  These options may not include C<-allowshell>,
C<-browser>, or C<-interpreter>.  The options C<-safer> and C<-hushspecials>
are added.  If --unsafe is set the options are neither checked nor edited.

xdvi is then executed with the options on I<file>.

=cut

$call{"xdvi"} = sub {
  my $file = pop or die "gm: xdvi: no file specified\n";
  my @arg = map { split } @_;
  unless ($opt{unsafe}) {
    $file .= ".dvi" unless $file =~ /\.dvi\Z/;
    $ingame->(0, $file);
    for my $arg (@arg) {
      grep /^\Q$arg\E$/, qw( -allowshell -browser -interpreter )
	and die "gm: xdvi option $arg is not allowed\n";
    }
    push @arg, qw( -safer -hushspecials );
  }
  $exec->("xdvi", @arg, $file);
};


sub AUTOLOAD {
  my $call = (split /::/, $GM::AUTOLOAD)[-1];
  my @arg = @_;

  local %ENV = %gmENV unless $opt{unsafe};
  local $INPUT_RECORD_SEPARATOR = undef;
  local $OUTPUT_RECORD_SEPARATOR = undef;

  exists $call{$call} or die "no such GM call $call";
  return $call{$call}->(@arg);
}



##########################################################################
# It's often useful to do some things purely relative to the game/tmp path.
# Provide some utilities in package GAME for that.

package GAME;

=head1 FUNCTIONS PROVIDED IN PACKAGE GAME

In general, these have exactly the same syntax as their counterparts
in package GM, and simply perform game area mapping on some of their
arguments --- those labelled as "interpreted" --- and pass them along 
to the GM call.  See I<Game Path Interpretation> above.  

Not all GM calls have GAME counterparts.  Calling B<GAME::func()>
for B<func> not documented here has undefined results.

=head2 B<GAME::chdir> (I<interpreted path>)

=head2 B<GAME::gv> (I<interpreted filename>, other args untouched)

=head2 B<GAME::latex> (I<interpreted filename>, I<[errmsg]>, I<[writeout]>)

Since the first arg gets mapped, it obviously has to be an actual filename
(with or without .tex).  To pass code you must call B<GM::latex> directly.
See B<GM::latex> above for the meaning of the other arguments.

=head2 B<GAME::opendir> (I<interpreted directory>)

=cut

# for many, just run the first arg (only) through GM::path and pass it on
#
sub chdir ($);
sub gv ($@);
sub latex ($;$$);  # don't use if arg has TeX commands in it, duh
sub opendir ($);
#
sub AUTOLOAD {
  my $call = (split /::/, $GAME::AUTOLOAD)[-1];
  my ($thing, @other) = @_;
  $thing = GM::path $thing;
  no strict 'refs';
  return &{"GM::$call"}($thing, @other);
}

# For a number of functions the default AUTOLOAD behavior is not correct.

=head2 B<GAME::contents> (I<interpreted-if-present optional path>)

=cut

# Argument is optional
sub contents (;$) {
  my $dir = GM::path shift if @_;
  return GM::contents $dir;
}

=head2 B<GAME::open> (I<interpreted expression>)

Any "mode" prefix in the expression is removed, the remaining filename
expression is mapped, the mode is stuck back on, and B<GM::open> is called.

=cut

# Argument needs parsing first
sub open ($) { 
  my $full = shift;
  my $mode = "";
  (my $name = $full) =~ s/^(\+?(<|>>?)(&(=\d+)?)?)// 
    and $mode = $1;
  return GM::open ($mode . GM::path $name);
}

=head2 (string) B<GAME::path> (I<path>)

This performs translations due to .structure, but does not alter the
prefix of the path.  That is, you get back a game-relative path,
this being the package of game-relative things.  Prepending $GAME,
or the temporary directory if I<path> starts with a slash, to the
result should always agree with the result of B<GM::path>(I<path>).

=cut

# Return only part of GM:: function's return
sub path ($) { return (GM::paths shift)[1] }

=head2 (string) B<GAME::pwd> ()

Return the game-relative path.  This is equivalent to the value
returned from B<GM::pwd> with the $GAME prefix removed or the
temporary directory prefix turned to a slash.  That is,
B<GAME::chdir> B<GAME::pwd> leaves you right where you were.
If you are not ingame the results are undefined.

=cut

# Return only *relative* part, with appropriate prefix
sub pwd () {
  my $where = $pwd->();
  $where =~ s(^\Q$game\E/?)()o or $where =~ s(^\Q$tmp\E\?)(/)o;
  return $where;
}

=head2 B<GAME::rename> (I<interpreted path, interpreted path>)

Note that perl's native rename() doesn't move across filesystem boundaries.
This implies that you want both paths to be in $GAME or both in the
temp area.  Failure to rename across filesystems (or for other reasons)
is not fatal; it simply returns zero, like the native perl call.

=cut

sub rename ($$) { return GM::rename (GM::path shift, GM::path shift) }

=head2 B<GAME::xdvi> (I<untouched xdvi options list>..., I<interpreted file>)

=cut

# Last arg is file, not first
sub xdvi (@$) {
  my $file = GM::path pop;
  GM::xdvi (@_, $file);
}


###########################################################################
# Ok, now do it.

CORE::chdir $ENV{PWD};  # back where we started
package main;     # not stuck there, but good namespace to begin in
require lib;      # can't "use lib $bin" since $bin is runtime-determined
import lib $bin;  # puts $bin first in @INC
do $script;       # read it in and eval() it
die $@ if $@;
