#! 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";
print $hItem "Associated " . localtime() . " by $APPNAME version $versionMajor.$versionMinor\n";
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!^\<CSS number\=\"([^\"]+)\" ! ) {
$changesetCurrent = $1;
ItemRenameReset();
}
my ($action, $reference) = ( '', '' );
($action, $reference) = ($1, $2) if m! action\=\"([^\"]+)\" reference\=\"([^\"]+)\"!;
if( $action eq '' ) {
LineAsIs($_);
next;
}
$action =~ s!encoding, !!;
$action =~ s!, rollback!!;
$reference =~ s!\;[CX\d\~]+$!!;
if( $action eq 'add'
|| $action eq 'edit'
|| $action eq 'rollback'
|| $action eq 'undelete'
|| $action eq 'undelete, edit' ) {
ItemReference( $reference, $_ );
} elsif( $action eq 'delete' ) {
ItemReference( $reference, $_ );
} elsif( $action eq 'branch'
|| $action eq 'branch, edit'
|| $action eq 'branch, delete' ) {
ItemMergeSource( $reference, $_ );
} elsif( $action eq 'merge'
|| $action eq 'merge, branch'
|| $action eq 'merge, branch, edit'
|| $action eq 'merge, delete'
|| $action eq 'merge, edit'
|| $action eq 'merge, undelete'
|| $action eq 'merge, undelete, edit' ) {
ItemMergeSource( $reference, $_ );
} elsif( $action eq 'delete, rename, source rename'
|| $action eq 'rename, edit, source rename'
|| $action eq 'rename, source rename' ) {
ItemRenameTarget( $reference, $_ );
} elsif( $action eq 'merge, rename, edit, source rename'
|| $action eq 'merge, rename, source rename' ) {
ItemMergeSourceCase( $reference, $_ );
} elsif( $action eq 'source rename' ) {
ItemRenameTarget( $reference, $_ );
} elsif( $action eq 'delete, rename' ) {
LineAsIs( $_ );
} elsif( $action eq 'delete, source rename' ) {
ItemRenameTarget( $reference, $_ );
} elsif( $action eq 'rename'
|| $action eq 'rename, edit' ) {
ItemReference( $reference, $_ );
} elsif( $action eq 'merge, delete, source rename' ) {
ItemRenameTarget( $reference, $_ );
} elsif( $action eq 'merge, rename'
|| $action eq 'merge, rename, edit' ) {
ItemMergeSource( $reference, $_ );
} elsif( $action eq 'merge, source rename' ) {
ItemRenameTarget( $reference, $_ );
} elsif( $action eq 'merge, rename, undelete, edit' ) {
ItemMergeSource( $reference, $_ );
} else {
MsgERROR( "Don't recognize action '$action'" );
}
}
close $hExtract;
CoordinateExit();