#! /usr/bin/env perl
# branches.pl
########################################################################
########################################################################
# PERL PRAGMAS
#
use strict;
use warnings;
#
########################################################################
########################################################################
# PERL MODULES
#
use Getopt::Long;
use File::Basename;
#
########################################################################
########################################################################
# CONSTANTS
#
*COUNTER = \100000;
our $COUNTER;
$| = 1;
*P4_ROOT_DEFAULT = \"//...";
our $P4_ROOT_DEFAULT;
*P4_CMD_DEFAULT = \"p4";
our $P4_CMD_DEFAULT;
#
########################################################################
########################################################################
# USAGE
our $USAGE =<<USAGE;
@{[basename($0)]} [-u <p4User>] [-p <p4Port>] [-P <p4Pass>]
[-trunk <trunk>...] -cmd [<p4>] [<files...>]
@{[basename($0)]} -h
where:
<p4User>: Perforce User ID. Default is to use current
environment.
<p4Port>: Perforce port to use. Default is to use current
environment.
<p4Pass>: Perforce password. Default is to use the current
user and active P4 Ticket.
<trunk>: Trunk branch of Source Tree. Multiple "trunks" are
permitted. To do this, use multiple "-trunk"
parameters. If "-trunk" is not specified, program
will attempt to derive the trunk branches.
<files>: The starting point in the Perforce Depot tree.
Default is "$P4_ROOT_DEFAULT".
-help: Prints out this message.
USAGE
#
########################################################################
########################################################################
# COMMAND LINE OPTIONS
#
my (@trunkList, $p4, $helpFlag, $p4User, $p4Port, $p4Passwd, $p4Root);
GetOptions(
"trunk=s" => \@trunkList,
"cmd=s" => \$p4,
"u=s" => \$p4User,
"p=s" => \$p4Port,
"P=s" => \$p4Passwd,
"help" => \$helpFlag) or
die "$USAGE\n";
$p4Root = shift;
if ($helpFlag) {
print "$USAGE\n";
exit 0;
}
$p4Root = $P4_ROOT_DEFAULT unless ($p4Root);
$p4 = $P4_CMD_DEFAULT unless ($p4);
$p4 .= " -u $p4User" if ($p4User);
$p4 .= " -p $p4Port" if ($p4Port);
$p4 .= " -P $p4Passwd" if ($p4Passwd);
#
########################################################################
########################################################################
# READ THROUGH INTEGRATION COMMAND
#
open (INTEGRATE, qq($p4 -ztag integrated "$p4Root"|)) or
die qq(Can't run command "p4 integrated"\n);
my %branchHash;
my %intRecHash;
my $counter = 0; #Clicks every $COUNTER times
while (<INTEGRATE>) {
$counter++;
if (($counter % $COUNTER) == 0) {
print ".";
}
chomp;
if(/^\.\.\./) {
/^\.\.\.\s+([^ ]+)\s(.+)$/; #... <field> <Value>
$intRecHash{$1} = "$2"; # $intRec{<field>} = <Value>
} else {
if ($intRecHash{"how"} ne "branch from") {
undef %intRecHash;
next;
}
my $change = $intRecHash{"change"};
#
# Python Programmers: Eat your heart out!
#
# We are going to mash together the strings $fromFile and
# toFile with an XOR operation. The matching characters
# will be x00 bytes.
#
# I then match against /^(\x00*)/, and $1 will be the matching
# part of the prefix. Taking the length of this will give
# me the number of characters which match which I can then
# remove from the strings. Next, I do the same for the suffix
# by using the "reverse" function. The end result is the non-
# matching portion of the strings, or the names of the
# branches.
($intRecHash{"fromFile"} ^ $intRecHash{"toFile"}) =~ /^(\x00*)/;
my $prefixLen = length($1);
(reverse($intRecHash{"fromFile"}) ^ reverse($intRecHash{"toFile"}))
=~ /^(\0*)/;
my $suffixLen = length($1);
# Okay, it isn't all skiddles and beer at this point. We've
# got a problem if $fromBranch is "//Foo/BAR-3.4/" and $toBranch
# is "//Foo/BAR-3.5/". The match is too good because the
# actual match would be "//Foo/BAR-3." and we would believe
# that the from branch is "4" and to branch is "5".
#
# So, the above really returns the MAXIMUM possible prefix
# (and suffix). What we need to do is backoff to the last
# directory slash. That is, instead of the prefix being
# "//Foo/BAR-3.", it would be "//Foo/". Fortunately, the
# normal "greedy" behavior of regular expressions is very
# helpful in this situation. We'll just match what was
# returned above to the last directory slash, and that's
# our prefix (and suffix).
substr($intRecHash{"fromFile"}, 0, $prefixLen) =~ /^(.*\/)/;
$prefixLen = length($1);
substr(reverse($intRecHash{"fromFile"}), 0, $suffixLen) =~ /^(.*\/)/;
$suffixLen = length($1);
# Now, we have the actual prefix and suffix of the branch
# names!
my $fromBranch =
substr($intRecHash{"fromFile"}, $prefixLen, -$suffixLen);
my $toBranch =
substr($intRecHash{"toFile"}, $prefixLen, -$suffixLen);
# In some circumstances, there is no from and to branches.
# Skip these problems.
unless ($fromBranch and $toBranch) {
undef %intRecHash;
next;
}
# We need to prevent recursion. What I do is track the
# changelist numbers. If I find a FOO_BRANCH->BAR_BRANCH
# record, I check to see if I also have a BAR_BRANCH->FOO_BRANCH
# record. If I do, I then see which one was done first via
# changelist number. I then delete the one with the higher
# changelist from my %branchHash. That way, I only have
# the initial direction of the branch.
#
# Skip if $fromBranch->$toBranch exists and has lower change #
#
if (($branchHash{"$fromBranch"}->{"$toBranch"}) and
($branchHash{"$fromBranch"}->{"$toBranch"} < $change)) {
undef %intRecHash;
next;
}
#
# No $fromBranch->$toBranch. Is there a $toBranch->$fromBranch?
#
if ($branchHash{"$toBranch"}->{"$fromBranch"}) {
#
# There's a $toBranch->$fromBranch. Which came first?
# The $toBranch->$fromBranch or the $fromBranch->$toBranch?
#
if ($branchHash{"$toBranch"}->{"$fromBranch"} > $change) {
#
# $fromBranch->$toBranch is before $toBranch-$fromBranch
# Delete $toBranch->$fromBranch Record and save the
# $fromBranch->$toBranch record
#
delete($branchHash{"$toBranch"}->{$fromBranch});
$branchHash{"$fromBranch"}->{"$toBranch"} = $change;
} else {
#
# $toBranch->$fromBranch came before $fromBranch->$toBranch.
# Don't do anything
#
undef %intRecHash;
}
} else {
#
# There is no $toBranch->$fromBranch record. Add the
# $fromBranch->$toBranch record.
#
$branchHash{"$fromBranch"}->{"$toBranch"} = $change;
undef %intRecHash;
}
}
}
print "\n";
#
########################################################################
########################################################################
# FIND ALL "TRUNK" BRANCHES
#
# Trunk branches are branches that are only "From Branch" and never
# a "To Branch".
#
unless (@trunkList) {
my %trunkBranchHash;
foreach my $key (sort(keys(%branchHash))) {
$trunkBranchHash{$key} = 1;
}
#
# Prune the $trunkBranchHash
#
foreach my $fromBranch (sort(keys(%branchHash))) {
foreach my $toBranch (sort(keys(%{$branchHash{$fromBranch}}))) {
delete($trunkBranchHash{"$toBranch"})
if (exists($trunkBranchHash{"$fromBranch"}));
}
}
#
# Convert to List
#
@trunkList = (sort(keys(%trunkBranchHash)));
}
########################################################################
# NOW LIST ALL BRANCHES
#
foreach my $trunk (@trunkList) {
printStruct($branchHash{"$trunk"}, "$trunk", 0);
}
#
########################################################################
########################################################################
# SUB PRINT STRUCT
#
sub printStruct {
my $hashRef = shift;
my $branchName = shift;
my $level = shift;
print " " x $level . "$branchName\n";
foreach my $key (sort(keys(%{$hashRef}))) {
printStruct($branchHash{"$key"}, $key, $level+1);
}
}
#
########################################################################