infocom/interpreters/tools/zwrap.pl

#!/usr/bin/perl -w

#############################################################################
#
#  Zwrap v1.00
#
#  Copyright (C) 2004 David Griffith <dgriffi@cs.csubak.edu>
#
#  This program will create, in effect, a self-extracting executable
#  from a Z-machine binary or zcode file.  This is intended to simplify
#  giving zcode games to people using Unix machines who might not
#  clearly understand what a zcode interpreter is and how to use it.
#  This program creates a Perl script which includes the zcode file
#  encoded in uuencode format along with code to extract it.  When that
#  script is executed, the game is extracted to /tmp and given as a
#  command-line parameter to a zcode interpreter.  When the interpreter
#  exits, the zcode file is deleted.
#
#############################################################################


#############################################################################
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
#
#  Although this program is GPLed, the programs it creates are not.
#  That decision is the business of the user.  In other words, you can
#  distribute your zwrapped program however you like.
#
#############################################################################


use strict;
use POSIX;
use File::Basename;
use File::Copy;
use vars qw($opt_a $opt_o $opt_r $opt_s $opt_t);
use Getopt::Std;

# uuencode / uudecode code taken from:
# http://search.cpan.org/author/ANDK/Convert-UU-0.52/lib/Convert/UU.pm

my ($zwrap_version, $zwrap_date, $zwrap_author, $zwrap_author_email);
my ($tempdir, $encoded_string, $zcode, $filename, $gzfilename, @zcode);
my ($uufilename, $filename_fix, $outfile, $pwd, $umask_save, $terp);
my ($author, $title, $release, $serial);

$zwrap_version = "1.00";
$zwrap_date = "2003";
$zwrap_author = "David Griffith";
$zwrap_author_email = "<dgriffi\@cs.csubak.edu>";

$author = "Unknown Author";
$release = "Unknown Release";
$serial = "Unknown Serial";
$title = "Unknown Title";

$tempdir = "/tmp";
$terp = "frotz";


getopts("a:o:r:s:t:");

if ($opt_a) {
	$author = $opt_a;
}

if ($opt_o) {
	$outfile = $opt_o;
}

if ($opt_r) {
	$release = $opt_r;
}

if ($opt_s) {
	$serial = $opt_s;
}

if ($opt_t) {
	$title = $opt_t;
}


if ($ARGV[0]) {
	$filename = $ARGV[0];

	if (! -f $filename) {
		die "I don't see that file.\n";
	}
} else {
	usage();
}

$filename_fix = basename($filename)."$$";

$gzfilename = "$tempdir/" . $filename_fix;

$umask_save = umask();

umask(077);

copy($filename, $gzfilename);

`gzip -q $gzfilename`;
$gzfilename = "$gzfilename.gz";
$uufilename = basename($filename).".gz";

open(GAMEFILE, "< $gzfilename");

@zcode = <GAMEFILE>;

close(GAMEFILE);

umask($umask_save);

foreach my $i (@zcode) {
	$zcode = $zcode.$i;
}

unlink $gzfilename;

$encoded_string = uuencode($zcode, $uufilename);

# Protect single-quotes and backslashes from being mangled.
#
$encoded_string =~ s/\134/\134\134/g;
$encoded_string =~ s/\'/\\'/g;


# Now write out the wrapper script.
# 
if (!$outfile) {
	$outfile = basename("$filename");
	$outfile =~ s/\..+//;
	$outfile = "$outfile.pl";
}
	open(OUTFILE, "> $outfile") || die "Unable to write $outfile\n";

print OUTFILE <<EOF;
#!/usr/bin/perl -w
#
#############################################################################
#
#   Zwrap version $zwrap_version by $zwrap_author presents:
#
#	\"$title\" by $author
#	 Release $release / Serial number $serial
#	 Zwrapped file: $filename
#	
#############################################################################
#
# This script was created by zwrap $zwrap_version
# Copyright (C) $zwrap_date $zwrap_author $zwrap_author_email";
#
# Upon execution, this script will extract and decompress a zcode file
# and execute a zcode interpreter.
#
# Requirements:
#	A resonably modern Unix operating system.
# 	Perl 5.0 or later.
# 	A Z-machine interpreter (currently only Frotz is supported).
#
#
# Although the script that created this script is GPLed, the copyright
# for this script belongs to whoever created it.
#

use strict;

sub uudecode {
    die("Usage: uudecode( {string|filehandle|array ref})\\n")
      unless(\@_ == 1);
    my(\$in) = \@_;

    my(\@result,\$file,\$mode);
    \$mode = \$file = "";
    if (
        ref(\$in) eq 'IO::Handle' or
        ref(\\\$in) eq "GLOB" or
        ref(\$in) eq "GLOB" or
        ref(\$in) eq 'FileHandle'
       ) {
        local(\$\\) = "\\n";
        binmode(\$in);
        while (<\$in>) {
            if (\$file eq "" and !\$mode){
                (\$mode,\$file) = (\$1, \$2) if /^begin\\s+(\\d+)\\s+(.+)\$/ ;
                next;
            }
            last if /^end/;
            push \@result, uudecode_chunk(\$_);
        }
    } elsif (ref(\\\$in) eq "SCALAR") {
	while (\$in =~ m/\\G(.*?(\\n|\\r|\\r\\n|\\n\\r))/gc) {
            my \$line = \$1;
            if (\$file eq "" and !\$mode){
                (\$mode,\$file) = \$line =~ /^begin\\s+(\\d+)\\s+(.+)\$/ ;
                next;
            }
            next if \$file eq "" and !\$mode;
            last if \$line =~ /^end/;
            push \@result, uudecode_chunk(\$line);
        }
    } elsif (ref(\$in) eq "ARRAY") {
        my \$line;
        foreach \$line (\@\$in) {
            if (\$file eq "" and !\$mode){
                (\$mode,\$file) = \$line =~ /^begin\\s+(\\d+)\\s+(.+)\$/ ;
                next;
            }
            next if \$file eq "" and !\$mode;
            last if \$line =~ /^end/;
            push \@result, uudecode_chunk(\$line);
        }
    }
    wantarray ? (join("",\@result),\$file,\$mode) : join("",\@result);
}

sub uudecode_chunk {
	my(\$chunk) = \@_;
	return "" if \$chunk =~ /^(?:--|CREATED)/;
	my \$string = substr(\$chunk,0,int((((ord(\$chunk) - 32) & 077) + 2) / 3)*4+1);
	my \$ret = unpack("u", \$string);
	defined \$ret ? \$ret : "";
}


# It should be obvious how to extract the zcode file if you want to.
#
my \$filestring =\n\'$encoded_string\';


my (\$tempdir, \$zcode, \$filename, \$mode, \$terp);
\$tempdir = "$tempdir";
\$terp = "$terp";
(\$zcode, \$filename, \$mode) = uudecode(\$filestring);
\$filename = "\$tempdir\"."/zwrap_\".\"\$\$\".\"_\".\"\$filename";
umask 077;
open(OUTFILE, "> \$filename") || die "Unable to write \$filename.\\n";
print OUTFILE \$zcode;
close(OUTFILE);
system("gzip -d \$filename");
\$filename =~ s/.gz\$//;
system("\$terp \$filename");
system("reset -Q");
unlink(\$filename);
EOF

close(OUTFILE);

# Finished creating the wrapper script
#


sub usage {
	die "usage:  $0 [options] zcodefile
options:  -a \"Joe Bloggs\"     (author)
          -t \"My Game\"        (game title)
          -r \"4\"              (release number)
          -s \"010101\"         (serial number)\n";
}

sub uuencode {

	die("Usage: uuencode( {string|filehandle} [,filename] [, mode] )")
      		unless(@_ >= 1 && @_ <= 3);

	my ($in, $file, $mode) = @_;
	$mode ||= "644";
	$file ||= "uuencode.uu";

	my ($chunk, @result, $r);

    if (
        ref($in) eq 'IO::Handle' or
        ref(\$in) eq "GLOB" or
        ref($in) eq "GLOB" or
        ref($in) eq 'FileHandle'
       ) {
        # local $^W = 0; # Why did I get use of undefined value here ?
        binmode($in);
        local $/;
        $in = <$in>;
    }
    pos($in)=0;
    while ($in =~ m/\G(.{1,45})/sgc) {
      push @result, uuencode_chunk($1);
    }
    push @result, "`\n";
    join "", "begin $mode $file\n", @result, "end\n";
}

sub uuencode_chunk {
	my($string) = shift;
	my $encoded_string = pack("u", $string);	# unix uuencode
	    $encoded_string;
}