remote

   1 #!/usr/bin/env perl
   2 # *** NOTE *** LEAVE THIS MODULE LIST AS A PARAGRAPH
   3 use strict;
   4 use warnings;
   5 use 5.006_002;
   6 our $VERSION = '0.2.0';
   7 use English qw( -no_match_vars );
   8 use Fatal qw( close chdir opendir closedir );
   9 use File::Temp qw( tempdir );
  10 use File::Path qw( mkpath );
  11 use File::Spec::Functions qw( file_name_is_absolute catfile );
  12 use File::Basename qw( basename dirname );
  13 use POSIX qw( strftime );
  14 use Getopt::Long qw( :config gnu_getopt );
  15 use Cwd qw( getcwd );
  16 use Fcntl qw( :seek );
  17
  18 # *** NOTE *** LEAVE EMPTY LINE ABOVE
  19 my %default_config = (    # default values
  20    workdir     => '/tmp',
  21    cleanup     => 1,
  22    'no-exec'   => 0,
  23    tempdir     => 1,
  24    passthrough => 0,
  25    verbose     => 0,
  26 );
  27
  28 my $DATA_POSITION = tell DATA;                         # GLOBAL VARIABLE
  29 my %script_config = (%default_config, get_config());
  30
  31 my %config = %script_config;
  32 if ($ENV{DEPLOYABLE_DISABLE_PASSTHROUGH} || (!$config{passthrough})) {
  33    my %cmdline_config;
  34    GetOptions(
  35       \%cmdline_config,
  36       qw(
  37         usage|help|man!
  38         version!
  39
  40         bundle|all-exec|X!
  41         cleanup|c!
  42         dryrun|dry-run|n!
  43         filelist|list|l!
  44         heretar|here-tar|H!
  45         inspect|i=s
  46         no-exec!
  47         no-tar!
  48         roottar|root-tar|R!
  49         show|show-options|s!
  50         tar|t=s
  51         tempdir!
  52         tempdir-mode|m=s
  53         verbose!
  54         workdir|work-directory|deploy-directory|w=s
  55         ),
  56    ) or short_usage();
  57    %config = (%config, %cmdline_config);
  58 } ## end if ($ENV{DEPLOYABLE_DISABLE_PASSTHROUGH...})
  59
  60 usage()   if $config{usage};
  61 version() if $config{version};
  62
  63 if ($config{roottar}) {
  64    binmode STDOUT;
  65    my ($fh, $size) = locate_file('root');
  66    copy($fh, \*STDOUT, $size);
  67    exit 0;
  68 } ## end if ($config{roottar})
  69
  70 if ($config{heretar}) {
  71    binmode STDOUT;
  72    my ($fh, $size) = locate_file('here');
  73    copy($fh, \*STDOUT, $size);
  74    exit 0;
  75 } ## end if ($config{heretar})
  76
  77 if ($config{show}) {
  78    require Data::Dumper;
  79    print {*STDOUT} Data::Dumper::Dumper(\%script_config);
  80    exit 1;
  81 }
  82
  83 if ($config{inspect}) {
  84    $config{cleanup}   = 0;
  85    $config{'no-exec'} = 1;
  86    $config{'tempdir'} = 0;
  87    $config{workdir}   = $config{inspect};
  88 } ## end if ($config{inspect})
  89
  90 if ($config{dryrun}) {
  91    require Data::Dumper;
  92    print {*STDOUT} Data::Dumper::Dumper(\%config);
  93    exit 1;
  94 }
  95
  96 if ($config{filelist}) {
  97    my $root_tar = get_sub_tar('root');
  98    print "root:\n";
  99    $root_tar->print_filelist();
 100    my $here_tar = get_sub_tar('here');
 101    print "here:\n";
 102    $here_tar->print_filelist();
 103    exit 0;
 104 } ## end if ($config{filelist})
 105
 106 # here we have to do things for real... probably, so save the current
 107 # working directory for consumption by the scripts
 108 $ENV{OLD_PWD} = getcwd();
 109
 110 # go into the working directory, creating any intermediate if needed
 111 mkpath($config{workdir});
 112 chdir($config{workdir});
 113 print {*STDERR} "### Got into working directory '$config{workdir}'\n\n"
 114   if $config{verbose};
 115
 116 my $tempdir;
 117 if ($config{'tempdir'}) {    # Only if allowed
 118    my $me = basename(__FILE__) || 'deploy';
 119    my $now = strftime('%Y-%m-%d_%H-%M-%S', localtime);
 120    $tempdir = tempdir(
 121       join('-', $me, $now, ('X' x 10)),
 122       DIR     => '.',
 123       CLEANUP => $config{cleanup}
 124    );
 125
 126    if ($config{'tempdir-mode'}) {
 127       chmod oct($config{'tempdir-mode'}), $tempdir
 128         or die "chmod('$tempdir'): $OS_ERROR\n";
 129    }
 130
 131    chdir $tempdir
 132      or die "chdir('$tempdir'): $OS_ERROR\n";
 133
 134    if ($config{verbose}) {
 135       print {*STDERR}
 136         "### Created and got into temporary directory '$tempdir'\n";
 137       print {*STDERR} "### (will clean it up later)\n" if $config{cleanup};
 138       print {*STDERR} "\n";
 139    } ## end if ($config{verbose})
 140 } ## end if ($config{'tempdir'})
 141
 142 eval {    # Not really needed, but you know...
 143    $ENV{PATH} = '/bin:/usr/bin:/sbin:/usr/sbin';
 144    save_files();
 145    execute_deploy_programs() unless $config{'no-exec'};
 146 };
 147 warn "$EVAL_ERROR\n" if $EVAL_ERROR;
 148
 149 # Get back so that cleanup can successfully happen, if requested
 150 chdir '..' if defined $tempdir;
 151
 152 sub locate_file {
 153    my ($filename) = @_;
 154    my $fh = \*DATA;
 155    seek $fh, $DATA_POSITION, SEEK_SET;
 156    while (!eof $fh) {
 157       chomp(my $sizes = <$fh>);
 158       my ($name_size, $file_size) = split /\s+/, $sizes;
 159       my $name = full_read($fh, $name_size);
 160       full_read($fh, 1);    # "\n"
 161       return ($fh, $file_size) if $name eq $filename;
 162       seek $fh, $file_size + 2, SEEK_CUR;    # includes "\n\n"
 163    } ## end while (!eof $fh)
 164    die "could not find '$filename'";
 165 } ## end sub locate_file
 166
 167 sub full_read {
 168    my ($fh, $size) = @_;
 169    my $retval = '';
 170    while ($size) {
 171       my $buffer;
 172       my $nread = read $fh, $buffer, $size;
 173       die "read(): $OS_ERROR" unless defined $nread;
 174       die "unexpected end of file" unless $nread;
 175       $retval .= $buffer;
 176       $size -= $nread;
 177    } ## end while ($size)
 178    return $retval;
 179 } ## end sub full_read
 180
 181 sub copy {
 182    my ($ifh, $ofh, $size) = @_;
 183    while ($size) {
 184       my $buffer;
 185       my $nread = read $ifh, $buffer, ($size < 4096 ? $size : 4096);
 186       die "read(): $OS_ERROR" unless defined $nread;
 187       die "unexpected end of file" unless $nread;
 188       print {$ofh} $buffer;
 189       $size -= $nread;
 190    } ## end while ($size)
 191    return;
 192 } ## end sub copy
 193
 194 sub get_sub_tar {
 195    my ($filename) = @_;
 196    my ($fh, $size) = locate_file($filename);
 197    return Deployable::Tar->new(%config, fh => $fh, size => $size);
 198 }
 199
 200 sub get_config {
 201    my ($fh, $size) = locate_file('config.pl');
 202    my $config_text = full_read($fh, $size);
 203    my $config = eval 'my ' . $config_text or return;
 204    return $config unless wantarray;
 205    return %$config;
 206 } ## end sub get_config
 207
 208 sub save_files {
 209    my $here_tar = get_sub_tar('here');
 210    $here_tar->extract();
 211
 212    my $root_dir = $config{inspect} ? 'root' : '/';
 213    mkpath $root_dir unless -d $root_dir;
 214    my $cwd = getcwd();
 215    chdir $root_dir;
 216    my $root_tar = get_sub_tar('root');
 217    $root_tar->extract();
 218    chdir $cwd;
 219
 220    return;
 221 } ## end sub save_files
 222
 223 sub execute_deploy_programs {
 224    my @deploy_programs = @{$config{deploy} || []};
 225
 226    if ($config{bundle}) { # add all executable scripts in current directory
 227       print {*STDERR} "### Auto-deploying all executables in main dir\n\n"
 228         if $config{verbose};
 229       my %flag_for = map { $_ => 1 } @deploy_programs;
 230       opendir my $dh, '.';
 231       for my $item (sort readdir $dh) {
 232          next if $flag_for{$item};
 233          next unless ((-f $item) || (-l $item)) && (-x $item);
 234          $flag_for{$item} = 1;
 235          push @deploy_programs, $item;
 236       } ## end for my $item (sort readdir...)
 237       closedir $dh;
 238    } ## end if ($config{bundle})
 239
 240  DEPLOY:
 241    for my $deploy (@deploy_programs) {
 242       $deploy = catfile('.', $deploy)
 243         unless file_name_is_absolute($deploy);
 244       if (!-x $deploy) {
 245          print {*STDERR} "### Skipping '$deploy', not executable\n\n"
 246            if $config{verbose};
 247          next DEPLOY;
 248       }
 249       print {*STDERR} "### Executing '$deploy'...\n"
 250         if $config{verbose};
 251       system {$deploy} $deploy, @ARGV;
 252       print {*STDERR} "\n"
 253         if $config{verbose};
 254    } ## end DEPLOY: for my $deploy (@deploy_programs)
 255
 256    return;
 257 } ## end sub execute_deploy_programs
 258
 259 sub short_usage {
 260    my $progname = basename($0);
 261    print {*STDOUT} <<"END_OF_USAGE" ;
 262
 263 $progname version $VERSION - for help on calling and options, run:
 264
 265    $0 --usage
 266 END_OF_USAGE
 267    exit 1;
 268 } ## end sub short_usage
 269
 270 sub usage {
 271    my $progname = basename($0);
 272    print {*STDOUT} <<"END_OF_USAGE" ;
 273 $progname version $VERSION
 274
 275 More or less, this script is intended to be launched without parameters.
 276 Anyway, you can also set the following options, which will override any
 277 present configuration (except in "--show-options"):
 278
 279 * --usage | --man | --help
 280     print these help lines and exit
 281
 282 * --version
 283     print script version and exit
 284
 285 * --bundle | --all-exec | -X
 286     treat all executables in the main deployment directory as scripts
 287     to be executed
 288
 289 * --cleanup | -c | --no-cleanup
 290     perform / don't perform temporary directory cleanup after work done
 291
 292 * --deploy | --no-deploy
 293     deploy scripts are executed by default (same as specifying '--deploy')
 294     but you can prevent it.
 295
 296 * --dryrun | --dry-run
 297     print final options and exit
 298
 299 * --filelist | --list | -l
 300     print a list of files that are shipped in the deploy script
 301
 302 * --heretar | --here-tar | -H
 303     print out the tar file that contains all the files that would be
 304     extracted in the temporary directory, useful to redirect to file or
 305     pipe to the tar program
 306
 307 * --inspect | -i <dirname>
 308     just extract all the stuff into <dirname> for inspection. Implies
 309     --no-deploy, --no-tempdir, ignores --bundle (as a consequence of
 310     --no-deploy), disables --cleanup and sets the working directory
 311     to <dirname>
 312
 313 * --no-tar
 314     don't use system "tar"
 315
 316 * --roottar | --root-tar | -R
 317     print out the tar file that contains all the files that would be
 318     extracted in the root directory, useful to redirect to file or
 319     pipe to the tar program
 320
 321 * --show | --show-options | -s
 322     print configured options and exit
 323
 324 * --tar | -t <program-path>
 325     set the system "tar" program to use.
 326
 327 * --tempdir | --no-tempdir
 328     by default a temporary directory is created (same as specifying
 329     '--tempdir'), but you can execute directly in the workdir (see below)
 330     without creating it.
 331
 332 * --tempdir-mode | -m
 333     set permissions of temporary directory (octal string)
 334
 335 * --workdir | --work-directory | --deploy-directory | -w
 336     working base directory (a temporary subdirectory will be created
 337     there anyway)
 338
 339 END_OF_USAGE
 340    exit 1;
 341 } ## end sub usage
 342
 343 sub version {
 344    print "$0 version $VERSION\n";
 345    exit 1;
 346 }
 347
 348 package Deployable::Tar;
 349
 350 sub new {
 351    my $package = shift;
 352    my $self = {ref $_[0] ? %{$_[0]} : @_};
 353    $package = 'Deployable::Tar::Internal';
 354    if (!$self->{'no-tar'}) {
 355       if ((exists $self->{tar}) || (open my $fh, '-|', 'tar', '--help')) {
 356          $package = 'Deployable::Tar::External';
 357          $self->{tar} ||= 'tar';
 358       }
 359    } ## end if (!$self->{'no-tar'})
 360    bless $self, $package;
 361    $self->initialise() if $self->can('initialise');
 362    return $self;
 363 } ## end sub new
 364
 365 package Deployable::Tar::External;
 366 use English qw( -no_match_vars );
 367
 368 sub initialise {
 369    my $self = shift;
 370    my $compression =
 371        $self->{bzip2} ? 'j'
 372      : $self->{gzip}  ? 'z'
 373      :                  '';
 374    $self->{_list_command}    = 'tv' . $compression . 'f';
 375    $self->{_extract_command} = 'x' . $compression . 'f';
 376 } ## end sub initialise
 377
 378 sub print_filelist {
 379    my $self = shift;
 380    if ($self->{size}) {
 381       open my $tfh, '|-', $self->{tar}, $self->{_list_command}, '-'
 382         or die "open() on pipe to tar: $OS_ERROR";
 383       main::copy($self->{fh}, $tfh, $self->{size});
 384    }
 385    return $self;
 386 } ## end sub print_filelist
 387
 388 sub extract {
 389    my $self = shift;
 390    if ($self->{size}) {
 391       open my $tfh, '|-', $self->{tar}, $self->{_extract_command}, '-'
 392         or die "open() on pipe to tar: $OS_ERROR";
 393       main::copy($self->{fh}, $tfh, $self->{size});
 394    }
 395    return $self;
 396 } ## end sub extract
 397
 398 package Deployable::Tar::Internal;
 399 use English qw( -no_match_vars );
 400
 401 sub initialise {
 402    my $self = shift;
 403
 404    if ($self->{size}) {
 405       my $data = main::full_read($self->{fh}, $self->{size});
 406       open my $fh, '<', \$data
 407         or die "open() on internal variable: $OS_ERROR";
 408
 409       require Archive::Tar;
 410       $self->{_tar} = Archive::Tar->new();
 411       $self->{_tar}->read($fh);
 412    } ## end if ($self->{size})
 413
 414    return $self;
 415 } ## end sub initialise
 416
 417 sub print_filelist {
 418    my $self = shift;
 419    if ($self->{size}) {
 420       print {*STDOUT} "   $_\n" for $self->{_tar}->list_files();
 421    }
 422    return $self;
 423 } ## end sub print_filelist
 424
 425 sub extract {
 426    my $self = shift;
 427    if ($self->{size}) {
 428       $self->{_tar}->extract();
 429    }
 430    return $self;
 431 } ## end sub extract
 432
 433 __END__