#!/usr/bin/perl -w
# -*- perl -*-
use GD;  
use CGI; # replace with P4CGI, if using P4CGI/P4DB
use strict;
use Math::Trig;
#
#################################################################
#
#  P4 Branch Graphics
#  Original by tshort@cisco.com/tshort@ma.ultranet.com
#
#################################################################


# configurables (P4DB/P4CGI compatible names)

my $FONT;  # defaults to gdTinyFont if undefined

# URLS for for doing diffs and such.

# e.g. href="chv.vgi?CH=1234"
my $CHANGELIST_URL = "chv.cgi"; # name of the CGI URL that views changes
my $CHANGELIST_PARAM = "CH";    # name of the changelist parameter for the CGI script that views changes

# e.g. href="fdv.vgi?FSCP=//depot/filename.c&REV=2&ACT=edit"
my $DIFF_URL = "fdv.cgi"; # name of the CGI URL that does diffs
my $DIFF_PARAM = "FSPC";  # name of the file parameter for the CGI script that does diffs
my $DIFF_REV = "REV";     # name of the revision parameter for the CGI script that does diffs
my $DIFF_ACTION = "ACT";  # name of the action parameter for the CGI script that does diffs

# borrowed from P4CGI, if using P4DB/P4CGI, this can be cut out.

$ENV{P4PORT} = "perforce:1666";
$ENV{P4USER} = "perforce";

my $P4 = "/usr/bin/p4";
my $CGI = new CGI;

sub bail {
    my $message = shift @_ ;
    my $text = shift @_ ;    
    print 
	"",
	$CGI->header(),
	$CGI->start_html(-title   => "Error in script",
			 -bgcolor => "white");
    $message = &fixSpecChar($message) ;
    print 
	"<br><hr color=red><p align=center><font color=red size=+2>An error has occurred<br>Sorry!</font><p><font color=red>Message:<BR><pre>$message</pre><br>" ;
    if(defined $text) { 
	$text = &fixSpecChar($text) ;
	print "<pre>$text</pre><br>\n" ; 
    } ;
    print
	"<p>Parameters to script:<br>",
	$CGI->dump() ;
    print "</font>",$CGI->end_html() ;
    exit 1 ;
}
sub fixSpecChar($ )
{    
    my $d = shift @_ ;
    return "" unless defined $d;
    $d =~ s/&/&amp;/g ; # & -> &amp;
    $d =~ s/\"/&quot;/g;# " -> &quot;
    $d =~ s/</&lt;/g  ; # < -> &lt;
    $d =~ s/>/&gt;/g  ; # > -> &gt;
    return $d ;
}
sub p4call {
    my ( $par, @command ) = @_;
    my $partype = ref $par ;
    die("Called with illegal parameter ref: $partype") if $partype ne "ARRAY";

    @$par = ();
    open( P4, "$P4 @command|" ) || bail( "p4 @command failed" );
    while(<P4>) {
	chomp;
	push @$par,$_;
    }
    close P4;
    return;
}
# end from P4CGI, the functions can be replaced with those equivalents
# If using P4CGI/P4DB, add &P4CGI:: if needed to p4call and bail and fixSpecChar

#######
# Parameters:
#
######

$| = 1 ;

#
# Get parameter(s)
#
my $FSPC = $CGI->param("FSPC");
#P4CGI: my $FSPC = &P4CGI::cgi()->param("FSPC");
bail("No file specified") unless defined $FSPC ;
my $TYPE = $CGI->param("TYPE");
#P4CGI: my $TYPE = &P4CGI::cgi()->param("TYPE");
$TYPE = "html" unless defined $TYPE;

my @filelog;
my %filerev;
my %filename;
my %fileuser;
my %filechange;
my %filefromfile;
my %fileboxid;
my %filecol;
my %fileaction;
my %filefromaction;
my %otherfiles;
my @boxids = (0);

p4call(\@filelog,"filelog \"$FSPC\"") ;
bail("No data for file \"$FSPC\"") if @filelog == 0;

my $log;
my $idx;
my $boxid = 1;
my $col = 1;
$filecol{$FSPC} = $col;
$col++;
for ($log = shift @filelog; defined $log; $log = shift @filelog) 
{
    $_ = fixSpecChar($log) ;
    if (/^\.\.\. \#(\d+) \S+ (\d+) (\S+) on (\S+) by (\S*)@(\S*) (\S*)\s*'(.*)'/ )
    {
	$idx = $FSPC . "\#" . $1;
	$filerev{$idx} = $1;
	$filename{$idx} = $FSPC;
	$fileuser{$idx} = $5;
	$filechange{$idx} = $2;
	$fileaction{$idx} = $3;
	$fileboxid{$idx} = $boxid;
	push(@boxids, $idx);
	$boxid++;
    }
    elsif (/^\.\.\. \.\.\. (copy|merge|delete|branch|edit) from ([^#]+)\#(\d+),\#(\d+)$/)
    {
	bail("no file?!?") unless defined $idx;
	$filefromfile{$idx} = $2 . "\#" . $4;
	$filefromaction{$idx} = $1;
        $otherfiles{$2} = 1;
    }
    elsif (/^\.\.\. \.\.\. (copy|merge|delete|branch|edit) from ([^#]+)\#(\d+)$/)
    {
	bail("no file?!?") unless defined $idx;
	$filefromfile{$idx} = $2 . "\#" . $3;
	$filefromaction{$idx} = $1;
        $otherfiles{$2} = 1;
    }
    elsif (/^\.\.\. \.\.\. (add|copy|merge|delete|branch|edit) into ([^#]+)\#(\d+)$/)
    {
	bail("no file?!?") unless defined $idx;
        $otherfiles{$2} = 1;
    }
}

my $file;
my @otherfiles = keys(%otherfiles);
for ($file = shift @otherfiles; defined $file; $file = shift @otherfiles)
{
    p4call(\@filelog,"filelog \"$file\"") ;
    next if @filelog == 0;

    $filecol{$file} = $col;
    $col++;
    undef $idx;
    for ($log = shift @filelog; defined $log; $log = shift @filelog) 
    {
	$_ = fixSpecChar($log) ;
	if (/^\.\.\. \#(\d+) \S+ (\d+) (\S+) on (\S+) by (\S*)@(\S*) (\S*)\s*'(.*)'/ )
	{
	    $idx = $file . "\#" . $1;
	    $filerev{$idx} = $1;
	    $filename{$idx} = $file;
	    $fileuser{$idx} = $5;
	    $filechange{$idx} = $2;
	    $fileaction{$idx} = $3;
	    $fileboxid{$idx} = $boxid;
	    push(@boxids, $idx);
	    $boxid++;
	}
	elsif (/^\.\.\. \.\.\. (copy|merge|delete|branch|edit) from ([^#]+)\#(\d+),\#(\d+)/)
        {
	    bail("no file?!?") unless defined $idx;
	    $filefromfile{$idx} = $2 . "\#" . $4;
	    $filefromaction{$idx} = $1;
	}
	elsif (/^\.\.\. \.\.\. (copy|merge|delete|branch|edit) from ([^#]+)\#(\d+)/)
        {
	    bail("no file?!?") unless defined $idx;
	    $filefromfile{$idx} = $2 . "\#" . $3;
	    $filefromaction{$idx} = $1;
	}
    }
}

# Now that we have the history of the main file, and any close files that are one branch away,
# we need to figure out where the arrows are...
my @arrows;
my $i;

for ($i = 1; defined $boxids[$i]; $i++)
{
    $idx = $boxids[$i];
    if (defined $filefromfile{$idx})
    {
	my $file = $filefromfile{$idx};
	my $action = $filefromaction{$idx} if defined $file;
	my $from = $fileboxid{$file} if defined $action;
        push(@arrows, "$action $from-&gt;$i") if defined $from;
    }
}

my @revarrows;
for ($i = 1; defined $boxids[$i]; $i++)
{
    $idx = $boxids[$i];
    my $rev = $filerev{$idx} + 1;
    $file = $filename{$idx};
    my $filespec = $file . "\#" . $rev;
    if (defined $fileboxid{$filespec})
    {
	my $to = $fileboxid{$filespec};
        push(@revarrows, "$i-&gt;$to") if defined $to;
    }
}

# determine height of each box based on change
my @changes = sort { $a <=> $b } values %filechange;
my $last = 0;
my $height = 1;
my %changetoheight;
foreach (@changes)
{
    next if ($_ == $last);
    $last = $_;
    $changetoheight{$last} = $height;
    $height++;
}

unless (defined $FONT)
{
    if ($col < 8) # arbitrary cutoff
    {
	$FONT = gdMediumBoldFont;
    }
    elsif ($col < 12) # arbitrary cutoff
    {
	$FONT = gdSmallFont;
    }
    else
    {
	$FONT = gdTinyFont;
    }
}


# THESE SHOULD BE EVEN NUMBERS!
my $BOXHEIGHT = $FONT->height * 2 + 6;
my $BOXWIDTH = $FONT->width * 10; # for clXXXXXX with two spaces
my $BOXVSPACE = $FONT->height * 2;
my $BOXHSPACE = $BOXWIDTH / 2;

# returns the centerpoint of the box
sub boxtoxy
{
    my $box = $_[0];
    my $idx = $boxids[$box];
    my $h = $changetoheight{$filechange{$idx}};
    my $c = $filecol{$filename{$idx}};
    
    my $x = (($BOXHSPACE + $BOXWIDTH) * $c) - ($BOXWIDTH / 2);
    my $y = (($BOXVSPACE + $BOXHEIGHT) * $h) - ($BOXHEIGHT / 2);
    return ($x, $y);
}

sub boxrect
{
    my ($x, $y) = boxtoxy($_[0]);
    $x -= $BOXWIDTH / 2;
    $y -= $BOXHEIGHT / 2;
    my $x1 = $x + $BOXWIDTH;
    my $y1 = $y + $BOXHEIGHT;
    return ($x, $y, $x1, $y1);
}

sub nwcorner
{
    my ($x, $y) = boxtoxy($_[0]);
    $x -= $BOXWIDTH / 2;
    $y -= $BOXHEIGHT / 2;
    return ($x, $y);
}
sub necorner
{
    my ($x, $y) = boxtoxy($_[0]);
    $x += $BOXWIDTH / 2;
    $y -= $BOXHEIGHT / 2;
    return ($x, $y);
}
sub swcorner
{
    my ($x, $y) = boxtoxy($_[0]);
    $x -= $BOXWIDTH / 2;
    $y += $BOXHEIGHT / 2;
    return ($x, $y);
}
sub secorner
{
    my ($x, $y) = boxtoxy($_[0]);
    $x += $BOXWIDTH / 2;
    $y += $BOXHEIGHT / 2;
    return ($x, $y);
}
sub centertop
{
    my ($x, $y) = boxtoxy($_[0]);
    $y -= $BOXHEIGHT / 2;
    return ($x, $y);
}

sub centerbottom
{
    my ($x, $y) = boxtoxy($_[0]);
    $y += $BOXHEIGHT / 2;
    return ($x, $y);
}
sub centerright
{
    my ($x, $y) = boxtoxy($_[0]);
    $x += $BOXWIDTH / 2;
    return ($x, $y);
}

sub centerleft
{
    my ($x, $y) = boxtoxy($_[0]);
    $x -= $BOXWIDTH / 2;
    return ($x, $y);
}

sub imagesize
{
    my ($x, $y);
# $col and $height are one more than the number of columns/height
    $x = ($BOXWIDTH + $BOXHSPACE) * $col - $BOXWIDTH;
    $y = ($BOXHEIGHT + $BOXVSPACE) * $height - $BOXHEIGHT;
    return ($x, $y);
}

# not sure where I got this from... by I didn't write it... P4DB?/p4pr?
sub find_branch_part {
    # Strips identical substrings from the beginning and end of
    # $origname and $branchname and then returns what remains of
    # $branchname.
    my($origname, $branchname) = @_;
    my(@origname) = split('/', $origname);
    my(@branchname) = split('/', $branchname);
    while (@origname && ($origname[0] eq $branchname[0])) {
        shift @origname;
        shift @branchname;
    }
    while (@origname &&
           ($origname[@origname-1] eq $branchname[@branchname-1])) {
        pop @origname;
        pop @branchname;
    }
    join('/', @branchname);
}

#create image or do the HTML page
my ($x, $y);
my $image;
my $white;
my $blue;
my $green;
my $black;
my $red;

if ($TYPE eq "html")
{
    # start the HTML page

    #print "",&P4CGI::start_page("Branch Relationships<br>$FSPC", "BRA", "");
    print "Content-type: text/html\n\n";
    print "<html>\n<head>\n<title>Branch Relationships $FSPC</title>\n</head>\n";
    print "<body bgcolor=\"white\">\n";
    #end P4CGI

    print "<br>Branch relationships for <i>$FSPC</i>:<br>\n";
    print "<br><b>Key:</b><br>\n";
    print "Each box represents a revision (<font color=\"blue\">\#<i>n</i></font>) and changelist (<font color=\"blue\">cl<i>n</i></font>) of a file. Click a box to view the changelist description. A box with a red <font color=\"red\">X</font> indicates the file was deleted.<br>\n";
    print "The <b>title</b> over each column represents the branch name. Click on the title to view the graph from the point of view of that file.<br>\n";
    print "<font color=\"\#007F00\">Solid green arrows indicate a revision change. Click on a green arrow to view the diffs between revisions.</font><br>\n";
    print "<font color=\"red\">Solid red arrows indicate a branch.</font><br>\n";
    print "<font color=\"red\">Dashed red arrows indicate a merge.</font><br>\n";
    print "<img src=\"$SCRIPTNAME?FSPC=$FSPC&TYPE=branches.png\" usemap=\"\#branch\">\n";
    print "<map name=\"branch\">\n";
}
else
{
    ($x, $y) = imagesize();
    $image = GD::Image->new($x, $y) || die;
    $white = $image->colorAllocate(255, 255, 255); 
    $blue = $image->colorAllocate(0, 0, 255);
    $green = $image->colorAllocate(0, 127, 0);
    $black = $image->colorAllocate(0, 0, 0);
    $red = $image->colorAllocate(255, 0, 0);
}

# draw the rev arrows
foreach (@revarrows)
{
    if (/(\d+)-&gt;(\d+)/)
    {
	my ($from, $to) = ($1, $2);
	my ($x1, $y1) = centerbottom($from);
	my ($x2, $y2) = centertop($to);
	if ($TYPE eq "html")
	{
	    $idx = $boxids[$to];
	    $x1 -= $FONT->width;
	    $x2 += $FONT->width;
	    print "<area shape=\"rect\" coords=\"$x1, $y1, $x2, $y2\" href=\"$DIFF_URL?$DIFF_PARAM=$filename{$idx}&$DIFF_REV=$filerev{$idx}&$DIFF_ACTION=$fileaction{$idx}\">\n";
	}
	else
	{
	    $image->line($x1, $y1, $x2, $y2, $green);
	    my $h = $FONT->width;
	    my $poly = new GD::Polygon;
	    $poly->addPt($x2, $y2);
	    $poly->addPt($x2 - $h, $y2 - $h*2);
	    $poly->addPt($x2 + $h, $y2 - $h*2);
	    $image->filledPolygon($poly, $green);
	}
    }
}

# draw the boxes & text

for ($i = 1; defined $boxids[$i]; $i++)
{
    my ($x1, $y1, $x2, $y2) = boxrect($i);
    $idx = $boxids[$i];
    if ($TYPE eq "html")
    {
	print "<area shape=\"rect\" coords=\"$x1, $y1, $x2, $y2\" href=\"$CHANGELIST_URL?$CHANGELIST_PARAM=$filechange{$idx}\">\n";
    }
    else
    {
	$image->filledRectangle($x1, $y1, $x2, $y2, $white);
	$image->rectangle($x1, $y1, $x2, $y2, $black);
	my $rev = "\#" . $filerev{$idx};
	my $halflen = (length($rev) * $FONT->width) / 2;
	my ($x, $y) = boxtoxy($i);
	$image->string($FONT, $x - $halflen, $y1 + 2, $rev, $blue);
	my $change = "cl" . $filechange{$idx};
	$halflen = (length($change) * $FONT->width) / 2;
	$image->string($FONT, $x - $halflen, $y1 + $FONT->height + 4, $change, $blue);

	# cross out deleted files
	if ($fileaction{$idx} eq "delete")
	{
	    $image->line($x1, $y1, $x2, $y2, $red);
	    $image->line($x1, $y2, $x2, $y1, $red);
	}
    }
    if ($filerev{$idx} == 1)
    {
	# display branch name
	my $name;
	if ($FSPC eq $filename{$idx})
	{
	    $name = $FSPC;
	    # display centered above the box
	    my $halflen = (length($name) * $FONT->width) / 2;
	    my ($x, $y) = boxtoxy($i);
	    $y = $y1 - ($FONT->height + 2);
	    $x -= $x1;
	    if ($TYPE eq "html")
	    {
		$y2 = $y + $FONT->height;
		$x2 = $x + length ($name) * $FONT->width;
		print "<area shape=\"rect\" coords=\"$x, $y, $x2, $y2\" href=\"$SCRIPTNAME?FSPC=$name\" alt=\"$name\">\n";
	    }
	    else
	    {
		$image->string($FONT, $x, $y, $name, $black);
	    }
	}
	else
	{
	    $name = find_branch_part($FSPC, $filename{$idx});
	    # display centered above the box
	    my $halflen = (length($name) * $FONT->width) / 2;
	    my ($x, $y) = boxtoxy($i);
	    $y = $y1 - ($FONT->height + 2);
	    $x -= $halflen;
	    if ($TYPE eq "html")
	    {
		$y2 = $y + $FONT->height;
		$x2 = $x + $halflen * 2;
		print "<area shape=\"rect\" coords=\"$x, $y, $x2, $y2\" href=\"$SCRIPTNAME?FSPC=$filename{$idx}\" alt=\"$filename{$idx}\">\n";
	    }
	    else
	    {
		$image->string($FONT, $x,$y, $name, $black);
	    }

	}
    }
}

# draw the arrows
if ($TYPE eq "html")
{
    print "</map>\n</body>\n</html>\n";
    #print "</map>\n", &P4CGI::end_page() ;
}
else
{
    foreach (@arrows)
    {
	my ($from, $to);
	my ($x1, $y1);
	my ($x2, $y2);
	if (/(add|branch) (\d+)-&gt;(\d+)/)
	{
	    ($from, $to) = ($2, $3);
	    ($x1, $y1) = boxtoxy($from);
	    ($x2, $y2) = boxtoxy($to);
	    if ($x1 < $x2)
	    {
		($x1, $y1) = centerright($from);
	        ($x2, $y2) = nwcorner($to);
	    }
	    else
	    {
		($x1, $y1) = centerleft($from);
	        ($x2, $y2) = necorner($to);
	    }
	    $image->line($x1, $y1, $x2, $y2, $red);

	}
	elsif (/(\S+) (\d+)-&gt;(\d+)/)
	{
	    ($from, $to) = ($2, $3);
	    ($x1, $y1) = boxtoxy($from);
	    ($x2, $y2) = boxtoxy($to);
	    if ($x1 < $x2)
	    {
		($x1, $y1) = centerright($from);
		($x2, $y2) = centerleft($to);
	    }
	    else
	    {
		($x1, $y1) = centerleft($from);
		($x2, $y2) = centerright($to);
	    }
	    $image->dashedLine($x1, $y1, $x2, $y2, $red);
	}
	if (defined $from)
	{
	    my $h = $FONT->width;
	    my $poly = new GD::Polygon;
	    my $angle = atan2 ($y2 - $y1, $x2 - $x1) - pi() / 2;

	    $poly->addPt(0, 0);
	    my $c = cos($angle);
	    my $s = sin($angle);
	    $x1 = $c * (-$h) - $s * (-$h * 2);
	    $y1 = $s * (-$h) + $c * (-$h * 2);
	    $poly->addPt($x1, $y1);
	    $x1 = $c * $h - $s * (-$h * 2);
	    $y1 = $s * $h + $c * (-$h * 2);
	    $poly->addPt($x1, $y1);

	    $poly->offset($x2, $y2);
	    
	    $image->filledPolygon($poly, $red);
	    
	}
    }
    print "Content-type: image/png\n\n";
    binmode STDOUT;
    
    print $image->png();
}

## tada