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