#!/usr/bin/perl -w

#############################################################################
#
#  Zwrap v1.00
#
#  Copyright (C) 2004 David Griffith <[email protected]>
#
#  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;
}

You are viewing proxied material from gopher.661.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.