/home/uherbst/Daten/Projekte/ServDoc/servdoc/tools/separ.pl

• package main
  • encode
• __DATA__
• EOF

#!/usr/bin/perl

# This script is a lightly modified version of the script on
# http://www.perlmonks.org/index.pl?node_id=101426
#
# Changes:
# - symlinks will be copied as symlinks, not as flat files.
# - execute-rights will be preserved.
#
# Usage:
# perl separ.pl [-l] [-s autostartscript] <fileOrDir> [...] > archive
#
# -l: Don't copy symlinks as flat files but as symlinks (this is
#     useless for links outside your archive dir!)
#
# -s autostartscript:
#    Without that option, your selfextracting perl archive will create
#    your original files or directories and then stop.
#    With that option, your selfextracting perl archive will create a
#    temporary dir, cd to that tempdir, create there your archives,
#    start there your autstartscript, and after that it will remove
#    that tempdir.

#
#--------------------------------------------------------------------
#
# Creates self-extracting archives that use Perl to extract.
# Will make directories on extraction, but parents of top-level
# directories must exist and be writable.
#
# Outputs self-extracting archive to stdout.
# Arguments that are directories will be recursed into.
#
# To make an archive:
#  perl separ.pl <fileOrDir> [...] > archive
#
# To unpack an archive:
#   perl archive
#
# Uses no external modules for decompression.
# File format is: extractor program (Perl) at top,
# __DATA__ tag,
# multiple files, uuencoded.
# There may be "mkdir" lines before files.
#
# By Ned Konz, perl@bike-nomad.com
# encode() derived from Tom Christensen's PPT version of uuencode
# decoder based on code by Nick Ing-Simmons and Tom Christiansen
#
#--------------------------------------------------------------------
#

use strict;
use File::Find;
use Getopt::Std;

sub encode {
  my ( $source, $destination, $mode ) = @_;

  if ( $source eq '-' && -t STDIN ) {
    warn "$0: WARNING: reading from standard input\n";
  }

  printf "begin %03o $destination\012", $mode || 0644;

  local *INPUT;
  open( INPUT, "< $source" ) || die "can't open $source: $!";
  binmode(INPUT);

  my $block;
  print pack( "u", $block ) while read( INPUT, $block, 45 );
  print "`\012";
  print "end\012";

  close(INPUT) || die "can't close $source: $!";
}

getopts('ls:');

my $AUTOSTART = "";
if ($Getopt::Std::opt_s) {
  $AUTOSTART = "my \$AUTOSTART = \"$Getopt::Std::opt_s\";";
}

# copy the extractor
while (<DATA>) {
  s/\# AUTOSTART/$AUTOSTART/o;
  print $_;
}

# now encode the files with relative path names
$File::Find::dont_use_nlink = 1;
for my $arg (@ARGV) {
  my $ignoreLength = length($arg) + 1;
  File::Find::find(
    {
      no_chdir => 1,
      wanted   => sub {
        my $name = $File::Find::name;
        return if ( $name =~ /CVS/ );
        my $mode = $name eq '-' ? 0777 : ( stat($name) )[2];

        if ( -d _ ) {
          $mode &= 0777;
          printf( "mkdir %03o %s\012", $mode || 0777, $name );
          return;
        }

        if ( -l "$name" && $Getopt::Std::opt_l ) {
          printf( "symlink %s %s\012", readlink($name), $name );
          return;
        }

        #                encode( $name, $name, $mode & 0666 );
        encode( $name, $name, $mode );
      },
    },
    $arg
  );
}

__DATA__
#!/usr/bin/perl
use strict;

# This is a self-extracting archive that requires Perl to extract.
BEGIN { $/ = "\012" }

# AUTOSTART

my $debug=0;
my $TEMPDIR="separ.$$";
if ($AUTOSTART) {
  mkdir $TEMPDIR,0777 or die "Can't make directory $TEMPDIR: $!\n";
  chdir $TEMPDIR
}

while (<DATA>) {

  # attempt to be robust if someone edits this file in a different OS
  $_ =~ s/[\r\n]+$//s;
  next
    unless my ( $op, $mode, $file ) = /^(begin|mkdir|symlink)\s+(\S+)\s+(.*)/s;

  if ( $op eq 'mkdir' ) {
    if ( !-d $file ) {
      print STDERR "making directory $file\n" if ( $debug);
      mkdir $file, 0777 or die "Can't make directory $file: $!\n";
    }
    next;
  }
  if ( $op eq 'symlink' ) {
      print STDERR "making symlink $mode -> $file\n" if ( $debug);
      symlink $mode,$file or die "Can't make symlink $file: $!\n";
    next;
  }
  my $foundEnd = 0;
  print STDERR "extracting file $file\n" if ( $debug);
  open( OUT, ">$file" ) or die "Can't create $file: $!\n";
  binmode(OUT);

  while (<DATA>) {
    $_ =~ s/[\r\n]+$//s;
    if (/^end/) { $foundEnd++; last }
    next if /[a-z]/;
    next
      unless int( ( ( ( ord() - 32 ) & 077 ) + 2 ) / 3 ) == int( length() / 4 );
    print OUT unpack( "u", $_ ) or die "can't write $file: $!";
  }
  close(OUT) or die "can't close $file: $!";
  chmod oct($mode), $file or die "can't chmod $file to $mode: $!\n";
  $foundEnd or die "Missing end: $file may be truncated.\n";
}

if ($AUTOSTART) {
  print STDERR "running $AUTOSTART @ARGV" if ( $debug);
  system "$AUTOSTART @ARGV";
  chdir "..";
  system "rm -rf $TEMPDIR";
}

__DATA__