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