#!/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, $ver ); # 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; 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 mk_ver_str { join( '@', '$File: //guest/perforce_software/sdp/main/Server/Unix/p4/common/bin/triggers/archive_long_name_trigger.pl $ $Change: 25245 $' =~ /\$\S+: (.*?) \$/g ) . ' MD5: ' . self_checksum } 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 ${\ mk_ver_str }\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, 'ver' => \ $ver, '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 } = mk_ver_str; $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;
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#3 | 27331 | C. Thomas Tyler |
Released SDP 2020.1.27325 (2021/01/29). Copy Up using 'p4 copy -r -b perforce_software-sdp-dev'. |
||
#2 | 26161 | C. Thomas Tyler |
Released SDP 2019.3.26159 (2019/11/06). Copy Up using 'p4 copy -r -b perforce_software-sdp-dev'. |
||
#1 | 25245 | C. Thomas Tyler |
Released SDP 2019.1.25238 (2019/03/02). Copy Up using 'p4 copy -r -b perforce_software-sdp-dev'. |
||
//guest/perforce_software/sdp/dev/Server/Unix/p4/common/bin/triggers/archive_long_name_trigger.pl | |||||
#1 | 25120 | cgeen |
Trigger to resolve filename too long issue when resolved special characters exceed unix file length. Optionally +X //...Waive...#... typemap can be added or just added on a needed basis. |