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