#! perl -w use strict; =head1 Notices Originally developed for Perforce by VIZIM (www.vizim.com) Copyright (c) 2014 Perforce Software, Inc. and VIZIM Worldwide, Inc. All rights reserved. Please see LICENSE.txt in top-level folder of this distribution for license information =cut use File::Path; use File::Basename; use File::Spec::Functions qw(rel2abs catfile); use IO::Handle; use Time::Local; use Getopt::Long; use v5.14.0; # Earliest version testing was performed against my $APPNAME = 'TFSAssociate.pl'; my $versionMajor = 2; my $versionMinor = '35'; my $APPWHAT = "TFS extract association manager; Version $versionMajor.$versionMinor"; my $APPNOTICES = "Copyright (c) 2014 Perforce Software, Inc. and VIZIM Worldwide, Inc. All rights reserved. See LICENSE.txt for license information."; =head1 TFS Extraction Association tool This tool associates sources with targets within extracted information. =cut =head2 Operational Context All processing uses existing file content. No specific TFS or P4 context is required for operation. =cut #################### # # Program constants and globals # #################### $| = 1; # force STDOUT to keep logs up to date in case of failure/ abort my $fileMerges = 'merges'; my $fileRenames = 'renames'; my $fileDirectories = 'directories'; my $fileTwoHop = 'twohop'; my $fileUnresolved = 'unresolved'; my $hUnresolved; my $fileItems = 'items'; my $hItem; #################### # # Messaging support # #################### my $pathLog = ''; my $hLog = undef; my $ifERRORReported = 0; my $errorContext = undef; sub Msg($) { print "$_[0]\n"; print $hLog "$_[0]\n" if defined $hLog; } sub MsgERROR($) { print STDERR "$errorContext\n" if defined $errorContext; print STDERR "***" . $_[0] . "***\n"; print $hLog "$errorContext\n" if defined $errorContext && defined $hLog; print $hLog "***" . $_[0] . "***\n" if defined $hLog; $errorContext = undef; $ifERRORReported = 1; return 1; } sub CoordinateExit(;$) { my $exitCode = $_[0]; $exitCode = $ifERRORReported if ! defined $exitCode; $errorContext = undef; Msg( "\n" ); MsgERROR( "Processing terminated by errors" ) if $exitCode != 0; Msg( ">>> Processing completed without errors" ) if $exitCode == 0; close $hLog if defined $hLog; close $hUnresolved if defined $hUnresolved; close $hItem if defined $hItem; exit( $exitCode ); } sub OptionUsage(;$) { my $errorMessage = $_[0]; MsgERROR( $errorMessage ) if defined $errorMessage; print "$APPWHAT $APPNOTICES Usage: $APPNAME -V $APPNAME [-h|-?] $APPNAME [options] EXTRACTION Options: -log LOG - Create a copy of all message output in the log file LOG. Default is no output to STDOUT only. -merges MERGES - Bulk merge information. Can be an empty file. Default for MERGES is $fileMerges -renames RENAMES - Bulk rename information. Can be an empty file. Default for RENAMES is $fileRenames -directories DIRECTORIES - Bulk directory information. Can be an empty file. Default for DIRECTORIES is $fileDirectories -twohop TWOHOP - Renames originating with a merge that are subsequently renamed before checkin. Can be an empty file. Default for TWOHOP is $fileTwoHop -unresolved UNRESOLVED - Information about unresolved branch, merge, and rename items. Used as input for bulk extraction coordination tools. Appends to existing information. Default for UNRESOLVED is $fileUnresolved -items ITEMS - Extracted information with associations. Must not exist. Default for ITEMS is $fileItems Arguments: EXTRACTION - Extraction file to process. "; exit 0; } sub OptionVersion() { print "$APPWHAT\n"; exit 0; } #################### # # General utility functions # #################### sub utilAssurePathFile($) { my $FilePath = $_[0]; my ($name, $Dir, $suffix) = fileparse( $FilePath, (qr(\.[^\.]+),qr(\.))); unless( -e $Dir ) { mkpath( $Dir, 0, 0777 ); } } #################### # # Bulk information import. # #################### my %mergeTargets = (); # Merge file content created with: # # tf merges $/ /recursive /format:detailed # # Typically dims the lights and takes a few minutes to run. Can # be split into separate $/XXX where $/XXX are the 'M P' unresolved # entries. # # Content format: # # $/SSS;SV -> $/TTT;TV # # Where SSS is the source of the target TTT. SV is the source version # and may be a single version Cvvv or a range of version Cvvv~vvv. # TV is the target version. sub LoadMerges() { my $h; Msg( "Merges file '$fileMerges'" ); if( ! -e $fileMerges ) { Msg( " ... '$fileMerges' does not exist" ); return 1; } if( ! open( $h, '<', "$fileMerges" ) ) { MsgERROR( "Can't open merges file '$fileMerges' - $!" ); return 0; } while(<$h>) { next unless m!^(.+) \-\> (.+)$!; my ($source, $target) = ($1, $2); my ($path, $version) = ($1, $2) if $target =~ m!^([^\;]+)\;[CX](\d+)$!; $mergeTargets{uc $path}{$version} = $source; } close $h; return 1; } # Directory file content created with: # # tf dir $/ /recursive /folders /deleted | DirectoryNames.pl # # Not much of a light dimmer. # # Content format: # # D $/XXX # # For directory path XXX. The path may or may not exist. my %directoryNames = (); sub LoadDirectories() { my $h; Msg( "Directories file '$fileDirectories'" ); if( ! -e $fileDirectories ) { Msg( " ... '$fileDirectories' does not exist" ); return 1; } if( ! open( $h, '<', "$fileDirectories" ) ) { MsgERROR( "Can't open directories file '$fileDirectories' - $!" ); return 0; } while(<$h>) { chomp; next unless m!^D (.+)$!; my $path = $1; $directoryNames{uc $path} = 'D'; } close $h; $directoryNames{ '$/' } = 'D'; return 1; } # Rename mappings created with: # # TFSRenames.pl unresolved my %renames = (); sub LoadRenames() { my $h; Msg( "Renames file '$fileRenames'" ); if( ! -e $fileRenames ) { Msg( " ... '$fileRenames' does not exist" ); return 1; } if( ! open( $h, '<', "$fileRenames" ) ) { MsgERROR( "Can't open renames file '$fileRenames' - $!" ); return 0; } while(<$h>) { next unless m!^(\d+) (.+) \-\> (.+)$!; my ($version, $source, $target) = ($1, $2, $3); $renames{uc $source}{$version} = $target; } close $h; return 1; } # TwoHop mappings created with: # # ExtractTH.pl log # TFSRenames.pl TwoHop.files my %twoHops = (); sub LoadTwoHops() { my $h; Msg( "TowHop file '$fileTwoHop'" ); if( ! -e $fileTwoHop ) { Msg( " ... '$fileTwoHop' does not exist" ); return 1; } if( ! open( $h, '<', "$fileTwoHop" ) ) { MsgERROR( "Can't open TwoHop file '$fileTwoHop' - $!" ); return 0; } while(<$h>) { next unless m!^(\d+) (.+) \-\> (.+)$!; my ($version, $source, $target) = ($1, $2, $3); $twoHops{uc $source}{$version} = $target; } close $h; return 1; } #################### # # Parent child relationships # #################### my $changesetCurrent = 0; my %lastChange = (); sub FileChange($) { my $idx = uc $_[0]; $lastChange{ $idx } = $changesetCurrent; } sub UseChanges($) { my $path = $_[0]; my $change = $changesetCurrent; $change = $1 if $path =~ s!\;C(\d+)$!!; $change = $1 if $path =~ s!\;C\d+\~(\d+)$!!; $path =~ s!\;C[\d\~]+$!!; my $idx = uc $path; return ( 'latest', 0 ) if ! exists $lastChange{ $idx }; return ( ($lastChange{ $idx } > $change ? $change : 'latest'), $lastChange{ $idx } ); } sub ItemType($) { return exists $directoryNames{uc $_[0]} ? 'D' : 'F'; } sub ItemReference($$) { my ($path, $line) = @_; FileChange( $path ); $line =~ s!\/\>$!!; print $hItem "$line rtype=\"", ItemType( $path ), "\"/>\n"; } sub ItemMergeSource($$) { my ($path, $line) = @_; my $type = ItemType( $path ); FileChange( $path ); my $source = '???'; if( exists $mergeTargets{uc $path} && exists $mergeTargets{uc $path}{$changesetCurrent} ) { $source = $mergeTargets{uc $path}{$changesetCurrent}; } else { print $hUnresolved "M$type $changesetCurrent $path\n"; } $line =~ s!\/\>$!!; my ($use, $last) = UseChanges( $source ); print $hItem "$line source=\"$source\" stype=\"$type\" svu=\"$use\" svl=\"$last\"/>\n"; } my %renameRoots = (); sub ItemRenameIsChild($) { my $path = $_[0]; foreach my $root (keys %renameRoots) { return 1 if $path =~ m!^$root!i; } return 0; } sub ItemRenamePathRebase($) { my $path = $_[0]; foreach my $root (keys %renameRoots) { if( $path =~ m!^$root!i ) { $path =~ s!^$root!$renameRoots{$root}!i; return $path; } } return $path; } sub ItemRenameQualify($) { my $path = $_[0]; my $response = 'U'; if( exists $directoryNames{uc $path} ) { if( ItemRenameIsChild( $path ) ) { $response = 'C'; } else { $renameRoots{quotemeta $path} = $path; $response = 'P'; } } else { $response = ItemRenameIsChild( $path ) ? 'C' : 'F'; } return $response; } sub ItemRenameSetRoot($$) { my ($root, $path) = @_; $renameRoots{quotemeta $root} = $path; } sub ItemRenameReset() { foreach my $key (keys %renameRoots) { delete $renameRoots{$key}; } } sub ItemRenameTarget($$) { my ($path, $line) = @_; $path =~ s!\;X\d+$!!; my $target = '???'; my $type = ItemRenameQualify( $path ); if( exists $renames{uc $path} && exists $renames{uc $path}{$changesetCurrent} ) { $target = $renames{uc $path}{$changesetCurrent}; ItemRenameSetRoot($path, $target) if $type eq 'P'; } elsif( $type eq 'C' ) { $target = ItemRenamePathRebase( $path ); } else { print $hUnresolved "R$type $changesetCurrent $path\n"; } FileChange( $target ); $line =~ s!\/\>$!!; if( exists $twoHops{uc $path} && exists $twoHops{uc $path}{$changesetCurrent} ) { print $hItem "$line mid=\"$target\" target=\"$twoHops{uc $path}{$changesetCurrent}\" ttype=\"2$type\"/>\n"; } else { print $hItem "$line target=\"$target\" ttype=\"$type\"/>\n"; } } # Special case of a merge into a case only rename sub ItemMergeSourceCase($$) { my ($path, $line) = @_; my $stype = ItemType( $path ); my $source = '???'; if( exists $mergeTargets{uc $path} && exists $mergeTargets{uc $path}{$changesetCurrent} ) { $source = $mergeTargets{uc $path}{$changesetCurrent}; } else { print $hUnresolved "M$stype $changesetCurrent $path\n"; } my ($svu, $svl) = UseChanges( $source ); my $target = '???'; my $ttype = ItemType( $path ); if( exists $renames{uc $path} && exists $renames{uc $path}{$changesetCurrent} ) { $target = $renames{uc $path}{$changesetCurrent}; ItemRenameSetRoot($path, $target) if $ttype eq 'P'; } elsif( $ttype eq 'C' ) { $target = ItemRenamePathRebase( $path ); } else { print $hUnresolved "R$ttype $changesetCurrent $path\n"; } # Early versions tracked the intermediate rename. Which is reflective of # what happened. However, this creates complexity with minimal end-user # value so two-hops now go right to the end file. $line =~ s!\/\>$!!; if( exists $twoHops{uc $path} && exists $twoHops{uc $path}{$changesetCurrent} ) { $target = $twoHops{uc $path}{$changesetCurrent}; } print $hItem "$line source=\"$source\" stype=\"$stype\" svu=\"$svu\" svl=\"$svl\" target=\"$target\" ttype=\"$ttype\"/>\n"; FileChange( $target ); } sub LineAsIs($) { my $line = $_[0]; print $hItem "$line\n"; } #################### # # Main processing point # #################### my $optHelp = 0; my $optVersion = 0; Getopt::Long::Configure( "auto_abbrev", "no_ignore_case" ); OptionUsage( "Invalid specification" ) unless( GetOptions( "help|?" => \$optHelp, "log=s" => \$pathLog, "merges=s" => \$fileMerges, "renames=s" => \$fileRenames, "directories=s" => \$fileDirectories, "unresolved=s" => \$fileUnresolved, "items=s" => \$fileItems, "Version" => \$optVersion ) ); # Help and version are one description and we're done OptionVersion() if $optVersion; OptionUsage() if $optHelp || scalar @ARGV == 0; # Don't understand anything but 1 argument OptionUsage( "Don't understand anything but 1 argument" ) if( scalar @ARGV != 1 ); # Establish a log if( $pathLog ne '' ) { $pathLog = rel2abs( $pathLog ); utilAssurePathFile( $pathLog ); Msg("Activity logged in: $pathLog"); open $hLog, '>', $pathLog; } # Identify the processing. Msg( $APPWHAT ); # Unresolved information my $path = rel2abs( $fileUnresolved ); utilAssurePathFile( $path ); Msg( "Unresolved information appended to: $path" ); open $hUnresolved, '>>', $path; print $hUnresolved "Entries generated: " . localtime() . "\n"; # Items information $path = rel2abs( $fileItems ); Msg( "Items information output to: $path" ); if( -e $path ) { MsgERROR( "Items information file $path exists" ); CoordinateExit(); } utilAssurePathFile( $path ); open $hItem, '>', $path; print $hItem "\n"; # Load bulk information files CoordinateExit() unless LoadMerges(); CoordinateExit() unless LoadDirectories(); CoordinateExit() unless LoadRenames(); CoordinateExit() unless LoadTwoHops(); # Process the extraction file my $hExtract; if( ! open( $hExtract, '<', $ARGV[0] ) ) { MsgERROR( "Can't open extract file '$ARGV[0]' - $!" ); CoordinateExit(); } while (<$hExtract>) { chomp; if( m!^\