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