#!/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/dev/Server/Unix/p4/common/bin/triggers/archive_long_name_trigger.pl $ $Change: 25120 $' =~ /\$\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 | 26652 | Robert Cowham |
This is Tom's change: Introduced new 'Unsupported' directory to clarify that some files in the SDP are not officially supported. These files are samples for illustration, to provide examples, or are deprecated but not yet ready for removal from the package. The Maintenance and many SDP triggers have been moved under here, along with other SDP scripts and triggers. Added comments to p4_vars indicating that it should not be edited directly. Added reference to an optional site_global_vars file that, if it exists, will be sourced to provide global user settings without needing to edit p4_vars. As an exception to the refactoring, the totalusers.py Maintenance script will be moved to indicate that it is supported. Removed settings to support long-sunset P4Web from supported structure. Structure under new .../Unsupported folder is: Samples/bin Sample scripts. Samples/triggers Sample trigger scripts. Samples/triggers/tests Sample trigger script tests. Samples/broker Sample broker filter scripts. Deprecated/triggers Deprecated triggers. To Do in a subsequent change: Make corresponding doc changes. |
||
#2 | 26159 | C. Thomas Tyler |
Changed file type, removing '+k' file type modifier. Reason: The +k file type modifier is disallowed in SDP scripts, as it does not translate properly during fetch/clone operations across Helix Core servers (or into Git repos). Introduced new handcrafted $version value to replace mk_ver_str(). The $version value must be manually updated when the script changes (as is typical with other SDP scripts). Testing note: As changed, this passes a 'perl -c' compile check but I don't have a test environment for this script. Any testing support would be helpful. #review @cgeen |
||
#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. |