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->{_programfile}
 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->{_programfile}, 4096, $offset
 293            or die "print(): $OS_ERROR";
 294
 295          $offset += $nwritten;
 296          if ($offset == length($self->{_programfile})) {
 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          die "got something from tar's STDERR: $buffer..."
 309            if $reader == $err;
 310          push @result, $buffer;
 311       } ## end for my $reader ($from_select...
 312    } ## end while ($from_select->exists...
 313    die 'could not pipe all data to tar' if $in;
 314
 315    return join '', @result;
 316 } ## end sub _interact_with_program
 317
 318 sub _transform_mode {
 319    my ($mode) = @_;
 320    my ($sticky, $user, $group, $other) = unpack 'A A3 A3 A3', $mode;
 321    $sticky = 0;
 322    my $sticky_mask = 4;
 323    for my $rwx ($user, $group, $other) {
 324       my ($r, $w, $x) = split //, $rwx;
 325       my $v = 0;
 326       $v |= 1 if $x eq 'x';
 327       $v |= 1 && $sticky |= $sticky_mask if lc($x) eq 's';
 328       $v |= 2 if $w eq 'w';
 329       $v |= 4 if $r eq 'r';
 330       $rwx = $v;
 331       $sticky_mask >>= 1;
 332    } ## end for my $rwx ($user, $group...
 333    return oct(join '', $sticky, $user, $group, $other);
 334 } ## end sub _transform_mode
 335
 336 sub _refresh_list {
 337    my $self = shift;
 338
 339    my $filelist = $self->_interact_with_program(qw( tar tvf - ));
 340
 341    my @files;
 342    for my $line (split /\n/, $filelist) {
 343       my ($mode, $ug, $size, $date1, $date2, $filename) =
 344         split /\s+/, $line, 6;
 345       push @files,
 346         Pseudo::Archive::Tar::File->new(
 347          mode    => _transform_mode($mode),
 348          is_dir  => (substr($mode, 0, 1) eq 'd'),
 349          name    => $filename,
 350          size    => $size,
 351          _parent => $self,
 352         );
 353    } ## end for my $line (split /\n/...
 354
 355    $self->{_files} = \@files;
 356    return;
 357 } ## end sub _refresh_list
 358
 359 sub read {
 360    my ($self, $handle) = @_;
 361    local $/;
 362    binmode $handle;
 363    $self->{_tarfile} = <$handle>;
 364    $self->_refresh_list();
 365    return;
 366 } ## end sub read
 367
 368 sub list_files {
 369    my $self = shift;
 370    my @files = map { $_->full_path() } @{$self->{_files}};
 371    return @files if wantarray;
 372    return \@files;
 373 } ## end sub list_files
 374
 375 sub get_files {
 376    my $self = shift;
 377    return @{$self->{_files}} unless @_;
 378    my $target = shift;
 379    return grep { $target eq $_->full_path() } @{$self->{_files}};
 380 } ## end sub get_files
 381
 382 package Pseudo::Archive::Tar::File;
 383 use Scalar::Util qw( weaken );
 384
 385 sub new {
 386    my $package = shift;
 387    my $self = bless {@_}, $package;
 388    weaken $self->{_parent};
 389    return $self;
 390 } ## end sub new
 391
 392 sub full_path   { return $_[0]->{name}; }
 393 sub mode        { return $_[0]->{mode}; }
 394 sub has_content { return $_[0]->{size}; }
 395 sub is_dir      { return $_[0]->{is_dir}; }
 396
 397 sub get_content {
 398    my $self = shift;
 399    return $self->{_parent}
 400      ->_interact_with_program(qw( tar xOf - ), $self->{name});
 401 }
 402
 403 __END__