t/02/test.pl

   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.tar');
  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.tar');
  67    copy($fh, \*STDOUT, $size);
  68    exit 0;
  69 } ## end if ($config{heretar})
  70
  71 if ($config{filelist}) {
  72    my $root_tar = get_sub_tar('root.tar');
  73    print "root.tar:\n";
  74    $root_tar->print_filelist();
  75    my $here_tar = get_sub_tar('here.tar');
  76    print "here.tar\n";
  77    $here_tar->print_filelist();
  78    exit 0;
  79 } ## end if ($config{filelist})
  80
  81 my %script_config = (%default_config, get_config());
  82 if ($config{show}) {
  83    require Data::Dumper;
  84    print {*STDOUT} Data::Dumper::Dumper(\%script_config);
  85    exit 1;
  86 }
  87
  88 # Merge configurations and go on
  89 %config = (%script_config, %config);
  90
  91 if ($config{inspect}) {
  92    $config{cleanup}   = 0;
  93    $config{'deploy'}  = 0;
  94    $config{'tempdir'} = 0;
  95    $config{workdir}   = $config{inspect};
  96 } ## end if ($config{inspect})
  97
  98 if ($config{dryrun}) {
  99    require Data::Dumper;
 100    print {*STDOUT} Data::Dumper::Dumper(\%config);
 101    exit 1;
 102 }
 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 carp $EVAL_ERROR 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.tar');
 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.tar');
 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 * --roottar | --root-tar | -R
 280     print out the tar file that contains all the files that would be
 281     extracted in the root directory, useful to redirect to file or
 282     pipe to the tar program
 283
 284 * --show | --show-options | -s
 285     print configured options and exit
 286
 287 * --tar | -t
 288     use system tar.
 289
 290 * --tempdir | --no-tempdir
 291     by default a temporary directory is created (same as specifying
 292     '--tempdir'), but you can execute directly in the workdir (see below)
 293     without creating it.
 294
 295 * --workdir | --work-directory | --deploy-directory | -w
 296     working base directory (a temporary subdirectory will be created
 297     there anyway)
 298
 299 END_OF_USAGE
 300    exit 1;
 301 } ## end sub usage
 302
 303 sub version {
 304    print "$0 version $VERSION\n";
 305    exit 1;
 306 }
 307
 308
 309 package Deployable::Tar;
 310
 311 sub new {
 312    my $package = shift;
 313    my $self = { ref $_[0] ? %{$_[0]} : @_ };
 314    $package = 'Deployable::Tar::Internal';
 315    if (! $self->{'no-tar'}) {
 316       if ((exists $self->{tar}) || (open my $fh, '-|', 'tar', '--help')) {
 317          $package = 'Deployable::Tar::External';
 318          $self->{tar} ||= 'tar';
 319       }
 320    }
 321    bless $self, $package;
 322    $self->initialise() if $self->can('initialise');
 323    return $self;
 324 }
 325
 326 package Deployable::Tar::External;
 327 use English qw( -no_match_vars );
 328
 329 sub print_filelist {
 330    my $self = shift;
 331    open my $tfh, '|-', $self->{tar}, 'tvf', '-'
 332       or die "open() on pipe to tar: $OS_ERROR";
 333    main::copy($self->{fh}, $tfh, $self->{size});
 334    return $self;
 335 }
 336
 337 sub extract {
 338    my $self = shift;
 339    open my $tfh, '|-', $self->{tar}, 'xf', '-'
 340       or die "open() on pipe to tar: $OS_ERROR";
 341    main::copy($self->{fh}, $tfh, $self->{size});
 342    return $self;
 343 }
 344
 345 package Deployable::Tar::Internal;
 346 use English qw( -no_match_vars );
 347
 348 sub initialise {
 349    my $self = shift;
 350
 351    my $data = main::full_read($self->{fh}, $self->{size});
 352    open my $fh, '<', \$data or die "open() on internal variable: $OS_ERROR";
 353
 354    require Archive::Tar;
 355    $self->{_tar} = Archive::Tar->new();
 356    $self->{_tar}->read($fh);
 357
 358    return $self;
 359 }
 360
 361 sub print_filelist {
 362    my $self = shift;
 363    print {*STDOUT} "   $_\n" for $self->{_tar}->list_files();
 364    return $self;
 365 }
 366
 367 sub extract {
 368    my $self = shift;
 369    $self->{_tar}->extract();
 370    return $self;
 371 }
 372
 373 __END__
 374 9 71
 375 config.pl
 376 $VAR1 = {
 377           'deploy' => [],
 378           'bundle' => 1
 379         };
 380
 381
 382 8 2048
 383 here.tar
 384 hello.sh