TFSAssociate.pl #2

#! 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();