archive_long_name_trigger.pl #1

#!/usr/bin/env perl

use 5.14.0;
use Carp 'longmess';
use Data::Dumper;
use Digest::MD5 'md5_hex';
use File::Basename;
use File::Spec;
use File::Temp;
use File::Path qw(make_path);
use Getopt::Long;
use IO::File;
use Pod::Usage;
#use autodie;
use diagnostics '-traceonly';
use sigtrap qw / handler sig_log normal-signals error-signals /;
use strict;
use warnings;

#GV
#
my ( $errors, %log_entry, $lfh ) = 1;
my ( $op, $rev, $alt_lbr, $lbr, $name, $log, $help, $dbg );
# Need to modify to IO::Compress to make if OS agnostic
# Use pigz if your files are large
my $GZIP_PROG = '/usr/bin/gzip';
my $GUNZIP_PROG = '/usr/bin/gunzip';
my $file_prefix = basename( $0 ) =~ s/\.pl$//r;
my $version = "1.0.2";

sub uDumper {
  local $Data::Dumper::Useqq     = 1;
  local $Data::Dumper::Terse     = 1;
  local $Data::Dumper::Sortkeys  = 1;
  local $Data::Dumper::Indent    = 0;
  local $Data::Dumper::Quotekeys = 0;
  Dumper @_
}

sub self_checksum { uc md5_hex join( '', IO::File->new( $0, '<' )->getlines ) =~ s/\R/\012/gr }

sub end {
  # Try to ensure that error messages from things like invalid arguments
  # get passed back to the end user.  Without reading a little from the
  # server, it just gets a 'broken pipe' error.
  STDIN->blocking( 0 );
  my $si = <STDIN>; # Have to get at least a line otherwise it doesn't work.
  # This doesn't work.
  #sysread STDIN, $_, 65536;

  $op  //= 'unset';
  $rev //= 'unset';
  $lbr //= 'unset';
  $log_entry{    start } //= time;
  $log_entry{      end } = time;
  $log_entry{ duration } = $log_entry{ end } - $log_entry{ start };
  $log_entry{   errors } = $errors;

  # todo: failure to open log leaves this silent?
  # todo: don't log for -v/-h
  say $lfh uDumper \ %log_entry if $lfh;
  exit ( $errors // 1 )
}

END { end }

sub sig_log {
  no sigtrap;
  $SIG{ __DIE__ } = $SIG{ __WARN__ } = undef;
  return if state $sigged++;
  $name //= $file_prefix;
  say STDERR $log_entry{ sig_log } =
    "\n$name $version\n\nExiting unexpectedly: \n@_\n\n${\ longmess }";
  end;
}

sub ERR { die "$0 line ${\ caller }: @_\n" }

################################################################################

sub help {
print <<EOF;
  $file_prefix -op <operation> -rev <revision> -lbr <path/file>  < stdin

  This script unconverts #@*% from ascii 
  The reason for doing this is when they are expanded they can overflow the unix file path length

  Trigger:
        arch archive //... "/p4/common/bin/triggers/archive_long_name_trigger.pl -op %op%  -lbr %file% -rev %rev%"
EOF
exit 1;
}

sub tmp_file {
  my $act = $_[ 0 ] ? "$_[0]-" : '';
  File::Temp->new( TEMPLATE => "$file_prefix-$$-$act-XXXXX", DIR => '.', SUFFIX => ( $_[ 1 ] // '.bin' ) );
}

###############################################################################
#Functions
sub quote($) { "'" . $_[ 0 ] =~ s/'/''/gr . "'" }

sub print_debug {
  my ($_s) =@_;
  print 'DBG: '.$_s if $dbg;
}

#@ - %40
## - %23
#* - %2A
#% - %25
sub resolve_special_char {
  my ($_tt)=@_;
  my $_t = '';
  if( defined $_tt){
    $_t=$_tt;
  }
  $_t=~s/\%40/\@/g;
  $_t=~s/\%23/\#/g;
  $_t=~s/\%2A/\*/g;
  $_t=~s/\%25/\%/g;
  return $_t;
}
sub uri_unescape($) { $_[ 0 ] =~ s/\+/ /gr =~ s/%([0-9A-Fa-f]{2})/chr hex $1/egr }

sub resolve_lbr {
  my ($_t)=@_;
  $_t=uri_unescape($_t);
  return $_t;
}
#print resolve_lbr("This string # @ * % This %40 %23 %2A %25 %40 %23 %2A %25 \n");
##########################################################
#MAIN
#########################################################
$SIG{ __DIE__ } = $SIG{ __WARN__ } = \ &sig_log;

$log_entry{ PID   } = $$;
$log_entry{ start } = time;
$log_entry{ OARGV } = join ' | ', @ARGV;

GetOptions   'op=s' => \ $op ,
             'rev=s'  => \ $rev,
             'lbr=s' => \ $lbr,
             'log=s' => \ $log,
             'help:s' => \ $help,
             'name=s' => \ $name,
             'debug=i' => \ $dbg,
             'alt_lbr=s' => \ $alt_lbr,
    or help;

exit help if defined $help;

$log    //= "$file_prefix.log";
$name   //= "trigger_$file_prefix";
$alt_lbr //= resolve_lbr($lbr);

$lfh = IO::File->new( $log, '>>' ) or die "Unable to open log '$log': $!";
$lfh->autoflush( 1 );

$log_entry{     name } = $name;
$log_entry{  version } = $version;
$log_entry{ checksum } = self_checksum;
$log_entry{       op } = $op;
$log_entry{      rev } = $rev;
$log_entry{      lbr } = $lbr;
$log_entry{  alt_lbr } = $alt_lbr;
exit help unless $op && $lbr && defined $rev;
print uDumper(\%log_entry) if defined($dbg);
die 'unsupported op!' if $op ne 'write' && $op ne 'read' && $op ne 'delete';

die "Unkown rev format:  $rev" if $rev !~ /^\d+\.\d+$/;
$rev =~ s/^1\.//; # 1.2 -> 2.  rev is always leading with '1.'

if (uc $op eq 'WRITE'){
  print_debug("makedir $alt_lbr\n");
  my @created=make_path("\"$alt_lbr\"", {
      verbose => $dbg,
      chmod => 0711,
  });
  print_debug("gzip to $alt_lbr/$rev.gz\n");
  open my $gzip, '|-', "$GZIP_PROG > \"$alt_lbr/$rev.gz\"" or die "Couldn't open pipe: $!\n"; 
  #This can take a lot of memory for large files.   
  while (<STDIN>){
   print { $gzip } $_;
  }
  close $gzip or die "Couldn't close pipe: $!\n"; 
  $errors=0;
}elsif(uc $op eq 'DELETE'){
  print_debug("delete $alt_lbr/$rev.gz\n");
  unlink "$alt_lbr/$rev.gz";
  $errors=0;
}elsif(uc $op eq 'READ'){
 print_debug("gunzip $alt_lbr/$rev.gz\n");
 open my $gzip, '|-', "$GUNZIP_PROG", '-c', "$alt_lbr/$rev.gz" or die "Couldn't open pipe: $!\n";
 while (<$gzip>) {
   print $_;
 }
 close $gzip or die "Couldn't close pipe: $!\n"; 
 $errors=0;
}

1;