#! /usr/bin/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 v5.14.0;   # Earliest version testing was performed against

use File::Copy;
use File::Path;
use File::Basename;
use File::Spec::Functions qw(rel2abs catfile);

use Getopt::Long;

my $APPNAME = 'TFSGenerate.pl';
my $versionMajor = 4;
my $versionMinor = '35';
my $APPWHAT = "TFS import control generator; 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 generation tool

This tool generates an import control file based on information from a
TFS extraction.

=cut

=head2 Operational Context

There are no context requirements for the operation of this tool.

=cut

####################
#
# Program constants and globals
#
####################

$| = 1;   # force STDOUT to keep logs up to date in case of failure/ abort

my $MINIMUM_EXTRACT_VERSION = 7.01;

my $hCtrl = undef;
my $ctrlFilename = 'cg.ctrl';

=head1 Progress Tracking

Straightforward reporting of changesets processed and elapsed time.

Each changeset is one progress request.

=cut

my $progressEvery = 250;

=head2 Processing

There are two phases to generation processing: validation and generation.
During the validation phase the specified extraction file(s) are checked
for consistency against expected formats and values.
During the generation phase a control file is created.
A control file is not generated if errors are detected during the
validation phase.

In practice, the two phases could be combined into a single phase.
There are two separate phases to (a) avoid creation of partial control
files, and (b) provide support for backreferences.
Backreferences may be needed to support branch and merge based on cherry
picked or other than current source versions.

=cut

my $isActive = 0;       # 1 when active processing, 0 is "inactive" evaluation processing.

####################
#
# Messaging support
#
####################

my $pathLog = '';
my $hLog = undef;

my $ifERRORReported = 0;          # 1 if an ERROR message has been reported
my $ifCONSTRUCTError = 0;         # 1 if CONSTRUCT messages are ERROR messages
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 MsgDEBUG($)
{
  print "$_[0]\n";
}

=head2 CONSTRUCT Messages

CONSTRUCT messages are issued during the validation phase.
These messages identify constructs that are either not recognized
or not expected.

A CONSTRUCT message typically indicates extraction information that has
not been previously encountered.
The information identified is ignored during the generation phase.
However, it may indicate that the generated control file will not
correctly migrate the TFS source information.

Unlike ERROR messages, CONSTRUCT messages allow control file generation.
There is an option to treat CONSTRUCT messages as ERROR messages.

=cut

sub MsgCONSTRUCT($)
{
  return if $isActive;

  if( $ifCONSTRUCTError ) {
    return MsgERROR( "CONSTRUCT $_[0]" );
  } else {
    print "$errorContext\n" if defined $errorContext;
    print "+++ $_[0] +++\n";
    print $hLog "$errorContext\n" if defined $errorContext && defined $hLog;
    print $hLog "+++ $_[0] +++\n" if defined $hLog;
    $errorContext = undef;
    return 0;
  }
}

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 $hCtrl if defined $hCtrl;

  exit( $exitCode );
}

sub OptionUsage(;$)
{
  my $errorMessage = $_[0];
  
  MsgERROR( $errorMessage ) if defined $errorMessage;

  print "$APPWHAT
$APPNOTICES

Usage:

  $APPNAME -V
  $APPNAME [-h|-?]
  $APPNAME [options] EXTRACT [...]

  Options:
    -log LOG - Create a copy of all message output in the log file LOG.
              Default is no output to STDOUT only.

    -control FILE - The control information is generated into the file FILE.
              Control file may not exist. Default is $ctrlFilename.

    -progress COUNT - Issue progress message every COUNT changeset
              extractions. COUNT defaults to $progressEvery. 0 is no progress
              tracking.

    -mode MODE - Specifies that the features specified by MODE are to be
              enabled. Available features are:
                 C - treat CONSTRUCT warnings as errors.

  Arguments:
    EXTRACT - A TFS extraction file. Changesets in a file may not duplicate
              changesets in a previous file and must be after changesets in
              a previous file.
";
  exit 0;
}

sub OptionVersion()
{
  print "$APPWHAT\n";
  exit 0;
}

sub EnvironmentWhichMode($)
{
    my $which = $_[0];

    $ifCONSTRUCTError = 1       if $which =~ s/C//ig;
    
    if( $which ne '' ) {
        MsgERROR( "Unknown operational mode(s): '$which'" );
        return 0;
    }
    return 1;
}

####################
#
# Progress tracking
#
####################

my $progressEventTotal = 0;          # total progress events (CV tags)
my $progressEventThis = 0;           # current count of CV tag being processed.

my $progressTimeStart = undef;       # time() at start of progress tracking
my $progressTimeLast = undef;        # time() as of last progress report

sub TimeHHMMSS($)
{
    return sprintf "%2d:%02d:%02d", $_[0]/3600, ($_[0]/60) % 60, $_[0] % 60;
}

sub ProgressInit()
{
  $progressEventTotal = 0;
  $progressEventThis = 0;

  $progressTimeStart = time();
  $progressTimeLast = $progressTimeStart;

  if( $progressEvery <= 0 ) {
    Msg( "No progress tracking" );
  } else {
    Msg( "Progress tracking every $progressEvery changesets" );
  }
}

sub Progress()
{
  return if $progressEvery <= 0;

  if( $isActive ) {
    ++$progressEventThis;
  } else {
    ++$progressEventTotal;
    return;
  }

  if( ($progressEventThis == $progressEventTotal) || ($progressEventThis % $progressEvery == 0) ) {

    my $now = time();
    my $remaining = int( ($progressEventTotal - $progressEventThis) * (($now - $progressTimeStart) / $progressEventTotal) );

=head2 Progress Output

Progress output uses the format:

  NN of LL Last HHMMSS Elapsed HHMMSS Remaining HHMMSS

NN is the most recent changeset processed and LL is the last changeset to
process.

HHMMSS is a time value.
Last is the time required to complete the most recent processing, Elapsed is
the time since start of processing, and Remaining is an estimate of the time
required to complete extraction.

=cut

    Msg( sprintf "%6d of %6d Last %s Elapsed %s Remaining %s",
                 $progressEventThis, $progressEventTotal,
                 TimeHHMMSS( $now - $progressTimeLast ),
                 TimeHHMMSS( $now - $progressTimeStart ),
                 TimeHHMMSS( $remaining ) );

    $progressTimeLast = $now;
  }
}

sub ProgressLast()
{
}

####################
#
# General utility functions.
#
####################

sub utilAssurePathFile($)
{
  my $FilePath = $_[0];

  my ($name, $Dir, $suffix) = fileparse( $FilePath, (qr(\.[^\.]+),qr(\.)));
  unless( -e $Dir ) {
      mkpath( $Dir, 0, 0777 );
  }
}

sub XMLTextEncode($)
{
  my $Text = $_[0];
  return '' unless defined $Text; # safety

  $Text =~ s/\&/\&amp;/g;     # must be first encode
  $Text =~ s/\>/\&gt;/g;
  $Text =~ s/\</\&lt;/g;
  $Text =~ s/\'/\&apos;/g;
  $Text =~ s/\"/\&quot;/g;
  return $Text;
}

sub XMLTextDecode($)
{
  my $Text = $_[0];
  return '' unless defined $Text;     # safety check

  $Text =~ s/\&gt;/>/g;
  $Text =~ s/\&lt;/</g;
  $Text =~ s/\&apos;/\'/g;
  $Text =~ s/\&quot;/\"/g;
  $Text =~ s/\&amp;/\&/g;     # must be last decode
  return $Text;
}

# XML Tag reader that supports the subset of XMl encoding used by these tools.
#
#  $refRemainder - Reference to text remaining on a line after processing
#       of the current tag has been completed. On entry, the scanner is
#       primed with this text. On exit, this is the text following the tag
#       just processed. If the source was a line of text then the exit value
#       is the join of post-tag text and any remaining "lines" from the
#       original source.
#
#   $source - source of further text input. May be a file GLOB, a reference
#       to an array of text lines, a text constant, a text variable, or a
#       scalar reference. Lines are read from a file and elements are shifted
#       from the array. Text is split on /\n/.
#
#   $refAttributes - reference to a hash into which tag attributes are written.
#       The attribute TAG is set to the tag name. Any existing elements are
#       removed from the hash at the start of processing. By convension
#       attribute names are lower case so there should be no conflict with
#       the key TAG.
#
# Returns:
#
#   undef - when no further tags are available from the source.
#
#   A single text value that represents the value of the tag. This may be '',
#   but it may also be the encoding of XML tags embedded by this tag.
#   \n characters are "restored" to the returned value.

sub TagRead($$$)
{
  my ($refRemainder, $source, $refAttributes) = @_;
  
  my @src = ref($source) eq '' ? split /\n/, $source : ();
  my $line = defined $refRemainder ? $$refRemainder : '';
    
  foreach( keys %{$refAttributes} ) { delete $refAttributes->{$_}; }

  my $value = '';
  my $isComment = 0;
  my $idx = '';
  my $isFields = 0;
  while( 1 ) {
    

    # If the line is empty or only space characters remain, then establish
    # the next line from the source.

    if( $line =~ m/^\s*$/ ) {
      if( ref($source) eq '' ) {
        $line = shift @src;
      } elsif(ref($source) eq 'GLOB') {
        $line = <$source>;
      } elsif( ref($source) eq 'ARRAY' ) {
        $line = shift @{$source};
      } else {
        die "**FATAL** Don't understand tag source";
      }
            
      if( defined $line ) {
        chomp( $line );
      } else {
        $line = '';     # for remainder processing
        $value = undef;
        last;
      }
    }
       
    # If in a comment, then anything except an end of comment is
    # ignored.
        
    if( $isComment ) {
      if( $line =~ m/[^>]*\-\->(.*)$/ ) {
        $line = $1;
        $isComment = 0;
      } else {
        $line = '';
      }
            
    # If not currently processing a tag then look for one to start.
    # Anything prior to a '<' that isn't white space shouldn't be
    # there but is ignored. This includes blank lines.
        
    } elsif( $idx eq '' ) {
      if( $line =~ m/^\s*$/ ) {
        $line = '';
      } elsif( $line =~ m/^\s*<([^\/\s>]+)(.*)$/ ) {
        ($idx, $line) = ($1, $2);
        if( $idx =~ m/^\!\-\-/ ) {
          $isComment = 1;
          $idx = '';
        } else {
          $refAttributes->{TAG} = $idx;
          $isFields = 1;
        }
      } else {
        die "**FATAL** Bad tag format at $line";
      }
            
    # If extracting attributes (AKA fields), then either find one or
    # expect an end of the tag attribute sequence.
       
    } elsif( $isFields ) {
      $line =~ s/^\s+//;
      if( $line =~ m/^([^\s\=\>]+)\=\"([^\"]*)\"(.*)$/ ) {
        my ($key, $value) = ($1, $2);
        $line = $3;
        $refAttributes->{$key} = XMLTextDecode( $value );
      } elsif( $line =~ m/^\/>(.*)$/ ) {
        $line = $1;
        $idx = '';
        last;
      } elsif( $line =~ m/^>(.*)$/ ) {
        $line = $1;
        $isFields = 0;
      } else {
        die "**FATAL** In $idx don't understand attribute $line";
      }
            
    # Otherwise we're extracting tag value and only a formal
    # end tag is not value.
        
    } else {
      if( $line =~ m/(.*)<\/$idx>(.*)$/ ) {
        $value .= $1;
        $line = $2;
        $idx = '';
        last;
      } else {
        $value .= $line . "\n";
        $line = '';
      }
    }
  }

  # Various fatal format problems.
    
  die "**FATAL** Unterminated tag '$idx'"   if $idx ne '';
  die "**FATAL** Unterminated comment"      if $isComment;

  # Establish remainder. The remainder may be just space characters.
  # A trim really doesn't save much overhead as the extraction loop
  # needs to deal with "dead" space.

  if( defined $refRemainder ) {
    if( ref($source) eq '' ) {
      $line .= "\n"
        unless $line =~ m/^\s*$/;
      $line .= join "\n", @src;
    }
    $$refRemainder = $line;
  }
    
  return $value;
}

####################
#
# Generation support
#
####################

my $changesetPrevious = -1;

my %whenDeleted = ();

=head1 Action Representation

Each extracted item will either be eliminated or represented by
a single action in the generated control file.
The extracted action will be reduced to an import consistent action.
When appropriate, additional attributes will be created to reflect
reduction activities.

All actions have specific information requirements that are
validated as part of this processing.

=cut

my %renameMatching = ();
my %renameSource = ();

sub RenameMatch($$$;$)
{
  my ($path, $matches, $tomatch, $source ) = @_;

  if( exists $renameMatching{ $path } ) {
    if( $renameMatching{ $path } ne $matches ) {
      MsgCONSTRUCT( "RenameMatching $renameMatching{ $path } is not $matches for $path" );
    } else {
      delete $renameMatching{ $path };
      delete $renameSource{ $path }
        if exists $renameSource{ $path };
    }
  } else {
    $renameMatching{ $path } = $tomatch;
    $renameSource{ $path } = $source
      if defined $source;
  }
}

sub ProcessITEMTag($$$)
{
  my ($refItemFields, $thisChangeset, $value) = @_;

  # Basic sanity checks against expected minimum ITEM attributes.

  if( ! exists $$refItemFields{action} || $$refItemFields{action} eq '' ) {
    MsgERROR( "ITEM without action attribute" );
    return ();
  }
  if( ! exists $$refItemFields{reference} || $$refItemFields{reference} eq '' ) {
    MsgERROR( "ITEM without reference attribute" );
    return ();
  }

  # Processing setup and return defaults.

  my %action = ();
  my $thisAction = $$refItemFields{action};
  $action{action} = $thisAction;
  $action{extract} = $thisAction;

  # As of the 6 series there are no values for items.

  if( $value ne '' ) {
    MsgCONSTRUCT( "Don't expect a value for $thisAction - $action{reference}" );
    return ();
  }

=head2 Encoding

TFS encodings are effectively a suggestion about content format used to
control merge, edit, and other TFS tools.
The content of a file in a TFS workspace is effectively a binary get/ put.

The import needs to account for encoding within a workspace so any
TFS encoding references are effectively moot.

=cut

  $thisAction =~ s!encoding,\s*!!;
  if( $thisAction =~ m!encoding! ) {
    MsgERROR( "encoding persists after reduction of '$$refItemFields{action}'" );
    return ();
  }

=head2 Rollback

Rollback does not indicate the action being rolled back.
Rather, it indicates an action that needs to be performed in order to
rollback an item.

There is a special case of an action that is just rollback.
This special case indicates that the rolled back content is the same as the
current content.
However, for this to occur there must be at least some content change between
the rollback content and the current content.
This case is effectively an edit no change.

=cut

  $thisAction = 'edit'
    if $thisAction eq 'rollback';
  $thisAction =~ s!, rollback!!;
  if( $thisAction =~ m!rollback! ) {
    MsgERROR( "rollback persists after reduction of '$$refItemFields{action}'" );
    return ();
  }

  # Sanity checks against reduced actions.

  $thisAction =~ s!^\s+!!;
  if( $thisAction eq '' ) {
    MsgERROR( "'$$refItemFields{action}' reduces to ''" );
    return ();
  }

  $action{action} = $thisAction;  

  # add and edit are against the current reference.

  if(    $thisAction eq 'add'
      || $thisAction eq 'edit' ) {
    $action{reference} = $$refItemFields{reference};
    return ( { %action } );
  }

  # delete is against the current reference.

  if( $thisAction eq 'delete' ) {
    my $path = $$refItemFields{reference};
    $action{reference} = $path;
    $path =~ s!\;X\d+$!!;
    $whenDeleted{$path} = $thisChangeset;
    $action{rtype} = $$refItemFields{rtype}
      if exists $$refItemFields{rtype};
    return ( { %action } );
  }

  # undelete is against the current reference. However, it also needs to know
  # the delete version for the object.
  #
  # NOTE: Undelete is imported as an add. The current content should be
  #       deleted in Perforce so an explicit edit would generate an error.
  #       Depend on the content correction within the import tool to emulate
  #       the edit.

  if(    $thisAction eq 'undelete'
      || $thisAction eq 'undelete, edit' ) {

    $action{action} = 'undelete';
    $action{reference} = $$refItemFields{reference};
    if( exists $whenDeleted{$action{reference}} ) {
      $action{deleted} = $whenDeleted{$action{reference}};
    } else {
      MsgCONSTRUCT( "Don't know when $action{reference} was deleted for $thisAction" );
    }

    return ( { %action } );
  }

  ##########
  #
  # Renames
  #
  # All sorts of rename scenarios. One of the most important considerations
  # is that when a parent directory is renamed all child files and
  # subdirectories are also implicitly renamed. Although child files can
  # also have explicit renames child subdirectories can not have an
  # explicit rename. Child renames are detected through RenameMatching
  # errors which spin back through the association processing.
  #
  # One level of potential complexity is that TFS tracks renames of deleted
  # files and directories. That can't be represented in Perforce. However,
  # a merge that causes a rename of a file that is subsequently deleted is
  # of interest.
  #
  # NOTE: Renames involving merges are actually two actions. The first action
  #       is the rename. The second action is the integration of the source
  #       into the renamed target.
  ##########

  # A rename being the source of a rename indicates a change of character
  # case. Implicitly this is a matching delete and rename

  if(    $thisAction eq 'rename, source rename'
      || $thisAction eq 'rename, edit, source rename' ) {

    $action{action} = 'renamecase';
    $action{action} .= '-' . $$refItemFields{ttype}
      if defined $$refItemFields{ttype};
    $action{reference} = $$refItemFields{reference};
    $action{unitconfirm} = 'Replacing';

    if( $thisAction eq 'rename, source rename' ) {
      return ( { %action } );

    } else {
      my %edit;
      $edit{action} = 'renameedit';
      $edit{secondary} = 'yes';
      $edit{unitconfirm} = 'no';
      $edit{extract} = $$refItemFields{action};
      $edit{reference} = $$refItemFields{reference};

      return ( { %action }, { %edit } );
    }
  }

  if(    $thisAction eq 'merge, rename, edit, source rename'
      || $thisAction eq 'merge, rename, source rename' ) {

    $action{action} = 'renamecase';
    $action{action} .= '-' . $$refItemFields{ttype}
      if defined $$refItemFields{ttype};
    $action{reference} = $$refItemFields{reference};
    $action{ttype} = $$refItemFields{ttype}
      if defined $$refItemFields{ttype};

    my %merge;
    $merge{extract} = $$refItemFields{action};
    $merge{secondary} = 'yes';
    $merge{unitconfirm} = 'no';
    $merge{target} = $$refItemFields{reference};
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $merge{source} = $source;
    $merge{sversion} = $version;
    $merge{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};
    $merge{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};

    if( $thisAction eq 'merge, rename, source rename' ) {
      $action{unitconfirm} = 'Replacing';
      $merge{action} = 'merge-M';
    } else {
      $action{unitconfirm} = 'Replacing';
      $merge{action} = 'merge-E';
    }

    return ( { %action }, { %merge } );
  }

  # Specific to case only rename of a unit that is deleted
  # prior to checkin.

  if( $thisAction eq 'delete, rename, source rename' ) {

    $action{action} = 'renamecase';
    $action{action} .= '-' . $$refItemFields{ttype}
      if defined $$refItemFields{ttype};
    $action{unitconfirm} = 'Deleting';
    $action{reference} = $$refItemFields{reference};

    my %delete;
    $delete{action} = 'renamedelete';
    $delete{extract} = $$refItemFields{action};
    $delete{unitconfirm} = 'no';
    $delete{secondary} = 'yes';
    $delete{reference} = $$refItemFields{reference};

    return ( { %action }, { %delete } );
  }

  if(    $thisAction eq 'source rename'
      || $thisAction eq 'merge, source rename' ) {

    $action{action} = 'rename';
    $action{action} .= '-' . $$refItemFields{ttype}
      if defined $$refItemFields{ttype};

    # The file is deleted, there will be nothing to confirm

    $action{unitconfirm} = 'no';
    $action{optional} = 'yes';
    $action{source} = $$refItemFields{reference};
    $action{target} = $$refItemFields{target};

    RenameMatch( $action{target}, 'rename', 'delete', $action{source} );

    return ( { %action } );
  }

  # This is both the target of a deleted unit rename, AND... a renamed
  # unit that is deleted after the rename and before the checkin.

  if( $thisAction eq 'delete, rename' ) {
    
    $action{action} = 'renamedelete';
    $action{secondary} = 'yes';
    $action{unitconfirm} = 'no';
    $action{reference} = $$refItemFields{reference};
    $action{reference} =~ s!\;X\d+$!!;

    RenameMatch( $action{reference}, 'delete', 'rename' );

    return ( { %action } );
  }

  if( $thisAction eq 'merge, rename, undelete, edit' ) {
    $action{action} = 'merge-U';
    $action{secondary} = 'yes';
    $action{target} = $$refItemFields{reference};
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $action{source} = $source;
    $action{sversion} = $version;
    $action{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};
    $action{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};

    RenameMatch( $action{target}, 'delete', 'rename' );

    my %edit;
    $edit{action} = 'edit';
    $edit{secondary} = 'yes';
    $edit{unitconfirm} = 'no';
    $edit{extract} = $$refItemFields{action};
    $edit{reference} = $$refItemFields{reference};

    return( { %action }, { %edit } );
  }

  # Traditional rename

  if(    $thisAction eq 'delete, source rename'
      || $thisAction eq 'merge, delete, source rename' ) {

    if( exists $$refItemFields{ttype} && $$refItemFields{ttype} eq '2C' ) {
      $action{action} = 'rename-C';
      $action{source} = $$refItemFields{reference};
      $action{source} =~ s!\;X\d+!!;
      $action{target} = $$refItemFields{mid};
      $action{ttype} = '2C';
      $action{unitconfirm} = 'source';

      my %final;
      $final{extract} = $$refItemFields{action};
      $final{ttype} = '2F';
      if( uc $action{target} eq uc $$refItemFields{target} ) {
        $final{action} = 'renamecase-F';
        $final{source} = $action{source};
        $final{reference} = $$refItemFields{target};
        $final{unitconfirm} = 'Getting';

        RenameMatch( $final{reference}, 'rename', 'delete', $action{source} );
      } else {
        $final{action} = 'rename-F';
        $final{unitconfirm} = 'target';
        $final{source} = $action{target};
        $final{target} = $$refItemFields{target};

        RenameMatch( $final{target}, 'rename', 'delete', $action{source} );
      }

      return ( { %action }, { %final } );
    } else {
      $action{action} = 'rename';
      $action{action} .= '-' . $$refItemFields{ttype}
        if defined $$refItemFields{ttype};
      $action{source} = $$refItemFields{reference};
      $action{source} =~ s!\;X\d+$!!;
      $action{target} = $$refItemFields{target};

      RenameMatch( $action{target}, 'rename', 'delete', $action{source} );

      return ( { %action } );
    }
  }

  # There needs to be a matching delete for a rename. However, renames can
  # be ignored unless there is an edit.

  if(    $thisAction eq 'rename'
      || $thisAction eq 'rename, edit' ) {

    $action{action} = $thisAction eq 'rename' ? 'IGNORE' : 'renameedit';
    $action{secondary} = 'yes';
    $action{unitconfirm} = 'no';
    $action{reference} = $$refItemFields{reference};

    RenameMatch( $action{reference}, 'delete', 'rename' );

    return ( { %action } );
  }

  # A merge rename needs to match the delete. It also needs to account
  # for the merge source.

  if(    $thisAction eq 'merge, rename'
      || $thisAction eq 'merge, rename, edit' ) {

    $action{action} = $thisAction eq 'merge, rename' ? 'merge-M' : 'merge-E';
    $action{secondary} = 'yes';
    $action{unitconfirm} = 'no';
    $action{target} = $$refItemFields{reference};
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $action{source} = $source;
    $action{sversion} = $version;
    $action{stype} = $$refItemFields{stype}
      if exists $$refItemFields{stype};
    $action{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};
    $action{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};

    RenameMatch( $action{target}, 'delete', 'rename' );

    return ( { %action } );
  }

  ##########
  #
  # Branch / merge not involving renames
  #
  # Multiple files can merge into a target. And you can cherry pick the
  # versions that are merged. However, any one checkin only supports one
  # merge source using a contiguous version range.
  #
  # Both branch and merge can be one sided if the source is destroyed. If a
  # source is destroyed then branch becomes an add and merge becomes an edit.
  #
  ##########

  # Branch indicates creation of a target that doesn't exist. 'merge branch'
  # is still a branch it's just that user activity was merge.
  #
  # Edit indicates TFS believes the final content is not the same as the
  # source. The content modification could be due to an explicit TFS edit
  # command or the user modifying the content locally prior to the checkin.

  if(    $thisAction eq 'branch'
      || $thisAction eq 'branch, edit' ) {

    if( $$refItemFields{source} eq '???' ) {
      $action{action} = 'add';
      $action{reference} = $$refItemFields{reference};

    } else {
      $action{action} = 'branch';
      $action{target} = $$refItemFields{reference};
      my ($source, $version) = ($$refItemFields{source}, 0);
      ($source, $version) = ($1, $2)
        if $source =~ m!^([^\;]+)\;(.+)$!;
      $action{source} = $source;
      $action{sversion} = $version;
      $action{svu} = $$refItemFields{svu}
        if exists $$refItemFields{svu};
      $action{svl} = $$refItemFields{svl}
        if exists $$refItemFields{svl};

    }
    return ( { %action } );
  }

  # 'branch, delete' is a branch followed by a delete. In TFS the user sees
  # a branch and a deleted file. If the import doesn't have a separate delete
  # after a branch then the imported history will miss the relationship.
  #
  # Unlike a merge, the get for the changeset does not yield either a
  # Getting or Deleting for the target file.
  #
  # The TFS workspace will not have a target file. Both the two sided and
  # single sided cases are handled during import processing to account for
  # other anomalous conditions associated with missing target files.

  if( $thisAction eq 'branch, delete' ) {
    $action{action} = 'branch';
    $action{target} = $$refItemFields{reference};
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $action{source} = $source;
    $action{sversion} = $version;
    $action{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};
    $action{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};
    $action{unitconfirm} = 'no';

    my %delete;
    $delete{action} = 'delete';
    $delete{unitconfirm} = 'no';
    $delete{phantom} = 'yes';
    $delete{extract} = $$refItemFields{action};

    my $path = $$refItemFields{reference};
    $delete{reference} = $path;
    $path =~ s!\;X\d+$!!;
    $whenDeleted{$path} = $thisChangeset;
    $delete{rtype} = $$refItemFields{rtype}
      if exists $$refItemFields{rtype};

    return( { %action }, { %delete } );
  }

  if(    $thisAction eq 'merge, branch'
      || $thisAction eq 'merge, branch, edit' ) {

    if( $$refItemFields{source} eq '???' ) {
      $action{action} = 'add';
      $action{unitconfirm} = 'Getting';
      $action{reference} = $$refItemFields{reference};

      return( { %action } );
    }

    $action{action} = 'merge-B';
    $action{target} = $$refItemFields{reference};
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $action{source} = $source;
    $action{sversion} = $version;
    $action{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};
    $action{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};

    return ( { %action } );
  }

  if(    $thisAction eq 'merge'
      || $thisAction eq 'merge, delete'
      || $thisAction eq 'merge, edit'
      || $thisAction eq 'merge, undelete'
      || $thisAction eq 'merge, undelete, edit' ) {

    if( $$refItemFields{source} eq '???' ) {
      $action{action} = 'edit' if $thisAction eq 'merge';
      $action{action} = 'delete' if $thisAction eq 'merge, delete';
      $action{action} = 'edit' if $thisAction eq 'merge, edit';
      $action{action} = 'add' if $thisAction eq 'merge, undelete';
      $action{action} = 'add' if $thisAction eq 'merge, undelete, edit';
      $action{unitconfirm} = 'Replacing' if $thisAction eq 'merge';
      $action{unitconfirm} = 'Deleting' if $thisAction eq 'merge, delete';
      $action{unitconfirm} = 'Replacing' if $thisAction eq 'merge, edit';
      $action{unitconfirm} = 'Getting' if $thisAction eq 'merge, undelete';
      $action{unitconfirm} = 'Getting' if $thisAction eq 'merge, undelete, edit';
      $action{reference} = $$refItemFields{reference};

      return( { %action } );
    }

    $action{action} = 'merge';
    $action{action} = 'merge-M' if $thisAction eq 'merge';
    $action{action} = 'merge-D' if $thisAction eq 'merge, delete';
    $action{action} = 'merge-E' if $thisAction eq 'merge, edit';
    $action{action} = 'merge-U' if $thisAction eq 'merge, undelete'
                                   || $thisAction eq 'merge, undelete, edit';
    $action{target} = $$refItemFields{reference};
    if( $thisAction eq 'merge, delete' ) {
      my $path = $action{target};
      $path =~ s!\;X\d+$!!;
      $whenDeleted{$path} = $thisChangeset;
    }
    my ($source, $version) = ($$refItemFields{source}, 0);
    ($source, $version) = ($1, $2)
      if $source =~ m!^([^\;]+)\;(.+)$!;
    $action{source} = $source;
    $action{sversion} = $version;
    $action{svu} = $$refItemFields{svu}
      if exists $$refItemFields{svu};
    $action{svl} = $$refItemFields{svl}
      if exists $$refItemFields{svl};

    if( $thisAction eq 'merge, undelete, edit' ) {
      my %edit;
      $edit{action} = 'edit';
      $edit{unitconfirm} = 'no';
      $edit{secondary} = 'yes';
      $edit{extract} = $$refItemFields{action};
      $edit{reference} = $$refItemFields{reference};
      return( { %action }, { %edit } );

    } else {
      return ( { %action } );

    }
  }

  MsgERROR( "Don't understand action '$thisAction' - $$refItemFields{reference}" );
  return ();
}

sub GenerateAIctrl($)
{
  my ($item) = @_;

  print $hCtrl "  <AI action=\"$item->{action}\"";
  foreach my $key (sort keys %$item) {
    print $hCtrl " $key\=\"$item->{$key}\""
      if $key ne 'action' && $key ne 'TAG';
  }
  print $hCtrl "/>\n";
}

sub ProcessCSTagSet($$)
{
  my ($refFields, $hExtract) = @_;

  $errorContext = "Changeset $refFields->{number}";

  my $comment = '';
  my $note = '';
  my @items = ();

  my $tagRemains = '';
  my %tagFields = ();
  while( 1 ) {
    my $value = TagRead( \$tagRemains, $hExtract, \%tagFields );
    last unless defined $value;

    if( ! defined $tagFields{TAG} ) {
      MsgERROR( "No tag identified" );
      last;
    } elsif( $tagFields{TAG} eq 'COMMENT' ) {
      $comment = $value;
    } elsif( $tagFields{TAG} eq 'NOTE' ) {
      $note = $value;
    } elsif( $tagFields{TAG} eq 'ITEM' ) {
      push @items, ProcessITEMTag( \%tagFields, $refFields->{number}, $value );
    } elsif( $tagFields{TAG} eq 'CSE' ) {
      last;
    } else {
      MsgERROR( "Unknown tag '$tagFields{TAG}'" );
      last;
    }
  }

  foreach my $key (sort keys %renameMatching) {
    MsgCONSTRUCT( "RenameMatching $renameMatching{$key} for $key" )
      unless exists $renameSource{$key};
    MsgCONSTRUCT( "RenameMatching $renameMatching{$key} for $key ($renameSource{$key})" )
      if exists $renameSource{$key};
    delete $renameMatching{$key};
    delete $renameSource{$key}
      if exists $renameSource{$key};
  }

  foreach my $key (sort keys %renameSource) {
    delete $renameSource{$key};
  }

=head1 Control File Entry Generation

TFS changesets relate one-to-one to Perforce changelists.

Each control file entry represents a changelist.
Changelists that would have no actions are not represented.
Changelists that only create directories are eliminated during import
processing.

=cut

  if( $isActive && scalar @items > 0 ) {

=head2 Control File - Sequence Reference

The sequence reference for generated entries is the TFS changeset number.
TFS changeset numbers are known to be unique and in sequence.

=cut

    print $hCtrl "<CC seq=\"$$refFields{number}\"";

=head2 Control File - Changelist Comment

The changelist comment is composed of the extracted comment, work-item, and
notes information from the extraction.

=cut

    $comment =~ s![\n\s]+$!!;
    $note =~ s![\n\s]+$!!;
    if( $comment ne '' || $note ne '' ) {
      print $hCtrl ">";
      print $hCtrl $comment if $comment ne '';
      if( $note ne '' ) {
        print $hCtrl "\n";
        print $hCtrl $note;
      }
      print $hCtrl "</CC>\n";
    } else {
      print $hCtrl "/>\n";
    }

=head2 Control File - Action Items

Each action item is a separate tag.
All action item characteristics are specified by arguments.

Certain processing can only be done effectively at this point.
In particular:

=over 4

=item *

Rename of child files when a parent rename was a case only rename.

=item *

Case only setup.

=back

=cut

    my $thisActions = 0;
    my $caseRenameSequence = 0;
    foreach my $item (@items) {
      if( $item->{action} eq 'rename-P' ) {
        $caseRenameSequence = 0;
      } elsif( $item->{action} eq 'renamecase-P' ) {
        $caseRenameSequence = 1;
      } elsif(    exists $item->{ttype}
               && $item->{action} =~ m!^rename! ) {
        $item->{ttype} .= 'P'
          if $caseRenameSequence;
      }

      if(    $item->{action} eq 'renamecase-P'
          || $item->{action} eq 'renamecase-F' ) {
        ++$thisActions;
        my $confirmSave = '';
        $confirmSave = $item->{unitconfirm}
          if exists $item->{unitconfirm};
        $item->{unitconfirm} = 'no';
        $item->{casesetup} = 'yes';
        GenerateAIctrl( $item );
        delete $item->{casesetup};
        $item->{unitconfirm} = $confirmSave
          if $confirmSave ne '';
        delete $item->{unitconfirm}
          if $confirmSave eq '';
      }
    }
    print $hCtrl "  <PROCESS type=\"casesetup\" user=\"$$refFields{user}\" when=\"$$refFields{date}\"/>\n"
      if $thisActions > 0;

    foreach my $item (@items) {
      next if exists $item->{secondary} || exists $item->{phantom};
      GenerateAIctrl( $item );
    }
    print $hCtrl "  <PROCESS type=\"primary\"/>\n";

    $thisActions = 0;
    foreach my $item (@items) {
      next unless exists $item->{secondary};
      GenerateAIctrl( $item );
      ++$thisActions;
    }
    print $hCtrl "  <PROCESS type=\"secondary\"/>\n"
      if $thisActions > 0;

    $thisActions = 0;
    foreach my $item (@items) {
      next unless exists $item->{phantom};
      print $hCtrl "  <PROCESS type=\"force\" user=\"$$refFields{user}\" when=\"$$refFields{date}\">Phantom actions to re-create TFS results</PROCESS>\n"
        if $thisActions == 0;
      GenerateAIctrl( $item );
      ++$thisActions;
    }
    print $hCtrl "  <PROCESS type=\"phantom\"/>\n"
      if $thisActions > 0;

=head2 Control File - Submit Changelist

The submit for the changelist needs to correct the user and time information.

=cut

    print $hCtrl "<CS user=\"$$refFields{user}\""
                 . " when=\"$$refFields{date}\""
                 . "/>\n";
  }
}

sub ProcessExtractionFile($)
{
  my ($file) = @_;

  # Active should ouline processing context

  Msg( "  ... $file" );

  # Open the extraction file and verify version from the TFSEXTRACT tag
  # expected at the start of the file.

  unless( -e $file ) {
    MsgERROR( "File does not exist" );
    return 0;
  }

  my $hExtract;
  open $hExtract, "<", $file or die "**FATAL** can't open $file; $!";

  my %tagFields = ();
  my $tagRemains = '';

  my $tagValue = TagRead( \$tagRemains, $hExtract, \%tagFields );
  if( $tagFields{TAG} eq 'TFSEXTRACT' ) {
    if( ! exists $tagFields{version} ) {
      MsgERROR( "Version attribute not found" );
      close $hExtract;
      return 0;
    } elsif( $tagFields{version} < $MINIMUM_EXTRACT_VERSION ) {
      Msg( "Extraction version: $tagFields{version}" );
      MsgERROR( "Extraction version $MINIMUM_EXTRACT_VERSION or later is required" );
      close $hExtract;
      return 0;
    } elsif( ! $isActive ) {
      Msg( "Extraction encoding version: $tagFields{version}" );
    }
  } else {
    MsgERROR( "No starting tag - TFSEXTRACT - found" );
    close $hExtract;
    return 0;
  }

  while( 1 ) {
    $tagValue = TagRead( \$tagRemains, $hExtract, \%tagFields );
    last    unless defined $tagValue;
    $errorContext = $file;
    if( $tagFields{TAG} eq 'CSS' ) {
      $errorContext .= " changeset $tagFields{number}"
        if exists $tagFields{number};
      if( $tagFields{number} <= $changesetPrevious ) {
        MsgERROR( "Changeset $tagFields{number} not after previous $changesetPrevious" );
        last;
      }
      $changesetPrevious = $tagFields{number};
      Progress();
      ProcessCSTagSet( \%tagFields, $hExtract );
    } else {
      MsgERROR( "???tag - $tagFields{TAG}???" );
    }
  }
  close $hExtract;

  return $ifERRORReported;
}

####################
#
# Main processing point
#
####################

my $optHelp = 0;
my $optVersion = 0;
my $WhichMode = '';

Getopt::Long::Configure( "auto_abbrev", "no_ignore_case" );

OptionUsage( "Invalid specification" )
  unless( GetOptions( "help|?" => \$optHelp,
                      "mode=s" => \$WhichMode,
                      "log=s" => \$pathLog,
                      "progress=i" => \$progressEvery,
                      "control=s" => \$ctrlFilename,
                      "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 specified arguments" )
  if( scalar @ARGV < 1 );

OptionUsage()    unless EnvironmentWhichMode($WhichMode);

# The control file can't exist (protect the user from themselves).

if( -e $ctrlFilename ) {
  MsgERROR( "Control file currently exists - $ctrlFilename" );
  CoordinateExit();
}

# Establish a log

if( $pathLog ne '' ) {
  $pathLog = rel2abs( $pathLog );
  utilAssurePathFile( $pathLog );
  Msg("Activity logged in: $pathLog");
  open $hLog, ">", $pathLog;
}

# Identify the processing.

Msg( "$APPNAME Version $versionMajor.$versionMinor" );

ProgressInit();

Msg( "Validation phase..." );

$changesetPrevious = -1;
$isActive = 0;
foreach( @ARGV ) {
   ProcessExtractionFile( $_ );
}
CoordinateExit() if $ifERRORReported;

Msg( "$progressEventTotal changesets to process" );

Msg( "" );
Msg( "Generation phase..." );

$ctrlFilename = rel2abs( $ctrlFilename );
utilAssurePathFile( $ctrlFilename );
Msg( "Control information in: $ctrlFilename" );
open $hCtrl, '>', $ctrlFilename;
print $hCtrl "<!---\nGenerated " . localtime() . " by $APPNAME\n -->\n";
print $hCtrl "<TFSCONTROL version=\"$versionMajor.$versionMinor\"/>\n";

$changesetPrevious = -1;
$isActive = 1;
foreach( @ARGV ) {
  ProcessExtractionFile( $_ );
}

ProgressLast();

CoordinateExit();