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