#!/usr/local/bin/perl

eval 'exec /usr/local/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#
# unshar - extract files from a shell archive
#
# v 1.1 by Larry Wall
# v 1.2 by Fuzzy - uudecode, chmod, touch, $variables, `backticks`, if/else/fi

while (@ARGV && $ARGV[0] =~ s/^-//) {
    local $_ = shift;
    while (/([cdfq])/g) {
	if ($1 eq 'd') {
	    $opts{'d'} = /\G(.*)/g && $1 ? $1 : shift;
	} else {
	    $opts{$1}++;
	}
    }
}

local $SIG{__WARN__} = $opts{'q'} ? sub {} : sub { print @_ };

$ENV{1} = $opts{'c'} || $opts{'f'} ? '-c' : '';

while (<>) {
    last if /^[#:]/;
}

die "No script found.\n" unless $_;

if ($opts{'d'}) {
    chdir $opts{'d'} || die "Can't chdir '$opts{'d'}': $!";
}

%test = (
    'eq', '==',
    'ne', '!=',
    'gt', '>',
    'ge', '>=',
    'lt', '<',
    'le', '<=',
    '=',  'eq',
    '!=', 'ne',
    '<',  'lt',
    '>',  'gt',
);

while (<>) {
    next if /^[#:]/;
    s/^\s+//;
    s/\$(\w+)/$ENV{$1}/g;
    for (/`([^`]+)`/g) {
	if (/wc -c < (\S+)/) {
	    $filename = $1;
	    $filename =~ s/^'(.*)'$/$1/ ||
	    $filename =~ s/^"(.*)"$/$1/ ||
	    $filename =~ s/\\(.)/$1/;
	    $ENV{$_} = -s $filename;
	}
	else {
	    $ENV{$_} = `$_`;
	}
    }
    s/`([^`]+)`/$ENV{$1}/g;
    if ($if) {
	if (/^fi/) {
	    $if--;
	    pop @expr;
	    next;
	}
	if (/^else/ && defined $expr[$#expr]) {
	    $expr[$#expr] = $expr[$#expr] ? 0 : 1;
	    next;
	}
	next unless $expr[$#expr];
    }
    $endmark = $1 if s/<<\s*(\S+)//;
    if ($endmark) {
	$endmark =~ s/^'(.*)'$/$1/ ||
	$endmark =~ s/^"(.*)"$/$1/ ||
	$endmark =~ s/\\(.)/$1/;
	$endmark .= "\n";
    }
    if (s/^echo //) {
	s/["']//g;
	warn $_;
    }
    elsif (/^export\s+PATH|^PATH\s*=/) {
	next;
    }
    elsif (s/^mkdir\s*//) {
	die "Reference to parent directory" if m|\.\./|;
	die "Reference to absolute directory" if m|\s[/~]|;
	if (s/;(.*)//) {
	    $rem = $1;
	}
	else {
	    $rem = '';
	}
	s/\s+$//;
	s/^'(.*)'$/$1/ || s/^"(.*)"$/$1/ || s/\\(.)/$1/;
	mkdir($_, 0777) || die "Couldn't mkdir '$_': $!";
	$_ = $rem;
	redo if $rem;
    }
    elsif (/^cat\s+(>+)\s*(\S+)\s*$/) {
	$redir = $1;
	$filename = $2;
	$filename =~ s/^'(.*)'$/$1/ ||
	$filename =~ s/^"(.*)"$/$1/ ||
	$filename =~ s/\\(.)/$1/;
	die "Reference to parent directory" if $filename =~ m|\.\./|;
	die "Reference to absolute directory" if $filename =~ m|^[/~]|;
	open(FILE,"$redir$filename") || die "Can't create $filename";
	while (<>) {
	    last if $_ eq $endmark;
	    print FILE $_;
	}
	close FILE;
    }
    elsif (/^sed\s+(.*\S)\s+(>+|\|)\s*(\S+)\s*$/ ||
      /^sed\s+(>+|\|)\s*(\S+)\s+(.*\S)\s*$/) {
	if (substr($1,0,1) eq '>') {
	    $redir = $1;
	    $filename = $2;
	    $sedcmd = $3;
	}
	else {
	    $sedcmd = $1;
	    $redir = $2;
	    $filename = $3;
	}
	$filename =~ s/^'(.*)'$/$1/ ||
	$filename =~ s/^"(.*)"$/$1/ ||
	$filename =~ s/\\(.)/$1/;
	die "Reference to parent directory" if $filename =~ m|\.\./|;
	die "Reference to absolute directory" if $filename =~ m|^\s*[/~]|;
	die "Illegal sed command" if $sedcmd =~ /[|;`<\$]/;
	$sedcmd =~ s/^-e\s*//;
	$sedcmd =~ s/^'(.*)'$/$1/ ||
	$sedcmd =~ s/^"(.*)"$/$1/ ||
	$sedcmd =~ s/\\(.)/$1/;
	die "Can only do s command in sed" unless $sedcmd =~ /^s/;
	die "Can't do multiple commands" if $sedcmd =~ /;/;
	warn "$redir$filename\n";
	if ($filename eq 'uudecode') {
	    $_ = <ARGV>;
	    /^begin\s+(\d+)\s+(\S+)/ || die 'Missing uuencode header';
	    open(FILE,"> $2") || die "Can't create '$2'";
	    binmode FILE;
	    eval sprintf '
		while (<>) {
		    warn $_;
		    last if /^end$/;
		    %s;
		    $_ = unpack("u", $_);
		    print FILE;
		}
	    ', $sedcmd;
	    while ($_ = <>) {
		last if $_ eq $endmark;
	    }
	} else {
	    open(FILE,"> $filename") || die "Can't create $filename: $!";
	    binmode FILE;
	    eval sprintf '
		while (<>) {
		    warn $_;
		    last if $_ eq $endmark;
		    %s;
		    print FILE;
		}
	    ', $sedcmd;
	}
	close FILE;
    }
    elsif (/^exit/) {
	$_ = <> until $_ eq '' || /^[#:]/;
	exit unless $_;
    }
    elsif (/^chmod\s+(0\d{3})\s+(\S+)\s*$/) {
	($mode, $filename) = ($1, $2);
	$filename =~ s/^'(.*)'$/$1/ ||
	$filename =~ s/^"(.*)"$/$1/ ||
	$filename =~ s/\\(.)/$1/;
	$mode = oct($mode);
	chmod($mode, $filename);
    }
    elsif (/^touch\s+-([am]+t)\s+(\d{8})(\.\d\d)?\s+(\S+)\s*$/) {
	($type, $date, $sec, $filename) = ($1, $2, $3, $4);
	eval('use Time::Local');
	next if $@;
	$filename =~ s/^'(.*)'$/$1/ ||
	$filename =~ s/^"(.*)"$/$1/ ||
	$filename =~ s/\\(.)/$1/;
	($mon, $mday, $hour, $min) = $date =~ /(..)/g;
	$sec ||= 0;
	$sec =~ tr/.//d;
	$time = timelocal($sec, $min, $hour, $mday, $mon - 1, (localtime)[5]);
	$atime = $type =~ /a/ ? $time : (stat $filename)[8];
	$mtime = $type =~ /m/ ? $time : (stat $filename)[9];
	utime($atime, $mtime, $filename);
    }
    elsif (/^(\w+)=(\S*)/) {
	($name, $value) = ($1, $2);
	$value =~ s/^'(.*)'$/$1/ ||
	$value =~ s/^"(.*)"$/$1/ ||
	$value =~ s/\\(.)/$1/;
	$ENV{$name} = $value;
    }
    elsif (s/^if\s+//) {
	$if++;
	$a = 'test\s+';
	$z = '\s*(;|&&|\|\|)';
	s/$a(-[df])\s+(\S+)$z/$1 $2 $3/go;
	s/$a(\d+)\s+-(eq|ne|gt|ge|lt|le)\s+(\d+)$z/$1 $test{$2} $3 $4/go;
	s/$a([^']+)\s+(!?=|>|<)\s+([^']+)$z/'$1' $test{$2} '$3' $4/go;
	s/$a([^"]+)\s+(!?=|>|<)\s+([^"]+)$z/"$1" $test{$2} "$3" $4/go;
	s/$a(\w+)$z/length $1 $2/go;
	s/;\s*then\s*$/\n/;
	push @expr,
	    /test/   ? undef :
	    eval($_) ? 1 : 0;
    }
    else {
	$r = $_;
	$lines = 1;
	while (<>) {
	    ++$lines;
	    $r .= $_;
	    last if /^exit/;
	}
	if ($_) {
	    $_ = <> until $_ eq '' || /^[#:]/;
	}
	open(REM,">.r") || die "Can't create .r";
	print REM $r;
	close REM;
	chmod 0700, '.r';
	if ($lines > 21 || !open(TTY,'/dev/tty')) {
	    print "Could not run remainder of kit.  Inspect .r and run it\n";
	    exit;
	}
	else {
	    print "Could not run remainder of kit.  Inspect this.\n$r";
	    print "Run it? [y] ";
	    $ans = <TTY>;
	    system '.r' if $ans =~ /^y/i;
	}
	exit unless $_;
    }
}

__END__

=head1 NAME

unshar - extract files from a shell archive 

=head1 SYNOPSIS

B<unshar> [-d dir] [-cfq] file [files...]

=head1 DESCRIPTION

B<unshar> scans files for shell archives and extracts the files contained in
those archives. B<unshar> attempts to decode a B<shar> file in a secure fashion.
If it can't do so, it will instruct you to inspect something first.

=head1 OPTIONS

=over

=item -c

Overwrite existing files.

=item -d dir

Change directory to I<dir> before extracting files.

=item -f

Same as B<-c>.

=item -q

Shhh!

=back

=head1 ENVIRONMENT

No environment variables are used.

=head1 FILES

None.

=head1 BUGS

There are too many existent shar formats for it to handle.

=head1 SEE ALSO

B<shar>, B<uudecode>

=head1 AUTHOR

Larry Wall | larry@wall.org

=head1 COPYRIGHT

Copyright (c) 1999 Larry Wall.  All rights reserved.

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. 

=cut