p4tree #1

#!/usr/bin/perl 

# Print a version tree of a Perforce controlled file
#
# Usage: p4tree files...
#
# Copyright (c) 1997-1999 by Jeremy Fitzhardinge.
# Copyright (c) 2000 by Thomas Quinot.
#
# Released under the GNU General Public License.
#
# 1997-1999 Jeremy Fitzhardinge <jeremy@goop.org> created the original
#           p4tree code. See http://www.goop.org/~jeremy/p4/.
#      2000 Thomas Quinot <thomas@cuivre.fr.eu.org> adapted it to
#           produce dot files.
#
# $Id: //depot/scripts/p4/p4tree#5 $

require 5.002;

my (%vcg_tmpl) = (
  'prologue', <<__EOF__,
graph: {\n
  title: "%s"
  display_edge_labels: yes
  late_edge_labels: yes
  fine_tuning: yes
  edge.priority: 10
  arrowmode: free
  straight_phase: yes
__EOF__
  'node', <<__EOF__,
  node: {
    title: "%s"
    label: "%s"
  }
__EOF__
  'edge', <<__EOF__,
  edge: {
    sourcename: "%s"
    targetname: "%s"
    linestyle: %s
    color: %s
  }
__EOF__
  'prioedge', <<__EOF__,
  nearedge: {
    sourcename: "%s"
    targetname: "%s"
    linestyle: %s
    color: %s
    priority: 5
  }
__EOF__
  'epilogue', "}\n"
);

my (%dot_tmpl) = (
  'prologue', <<__EOF__,
digraph "%s" {
  node [ shape = box ];
  edge [ weight = 10 ];
__EOF__
  'node', <<__EOF__,
  %s [ label = "%s" ];
__EOF__
  'edge', <<__EOF__,
  %s -> %s [ style = "%s" color = "%s" ];
__EOF__
  'prioedge', <<__EOF__,
  %s -> %s [ style = "%s" color = "%s" weight = 5 ];
__EOF__
  'epilogue', "}\n"
);

%targets = (
  'vcg', \%vcg_tmpl,
  'dot', \%dot_tmpl
);

sub usage () {
    print STDERR "Usage: $0 [ -t TITLE ] [ -T (dot|vcg) ] FILE [ FILE... ]\n";
    die ();
}

sub p4 ($@) {
    my ($op, @args) = (@_);
    my $cmd = "p4 $op ".(join " ", @args);
    # print STDERR "doing $cmd\n";
    system $cmd || die "Perforce command $cmd failed\n";
}

sub canon($) {
    my ($f) = @_;
    $f =~ s,/+,/,g;
    $f =~ s,/\.$,/,;
    return $f;
}

my %node_dict;
my $last_node_id = 0;

sub node_id () {
  my ($nodename) = @_;
  if (!exists $node_dict{$nodename}) {
    ++$last_node_id;
    $node_dict{$nodename} = "n$last_node_id";
  }
  return $node_dict{$nodename};
}

#
# Parse JCL
#

my (%tmpl) = %vcg_tmpl;
my ($title) = "Revision history";

require "getopts.pl";

&Getopts ("t:T:") || &usage ();

if (defined ($opt_T)) {
  if (exists $targets{$opt_T}) {
    $tmplref = $targets{$opt_T};
    %tmpl = %$tmplref;
  } else {
    print STDERR "Unknown target: $opt_T\n";
    &usage ();
  }
}

$title = $opt_t if (defined ($opt_t));

@files = @ARGV;

# %db = (
#	"//depot/depotname" => [
#		{	# indexed by version
#			"op" => "add/delete/edit/branch",
#			"date" => "1997/08/01",
#			"who" => "jeremy@ixodes",
#			"comment" => "fingled the wazzit",
#			"change" => 1234,
#			"links" => [ 
#				[ "branch", "from", \%other, 2, 3 ],
#				[ "merge", "from", \%other ]
#			]
#		}
#	]
# )

file:
foreach $file (@files) {
    my $currentfile;
    my $currentver;
    my $depotname;
    
    $file =~ s/#.*$//;

    open P4, "p4 filelog $file|";
    
    while(<P4>) {
	chop;
	
	if (/^\/\//) {
	    $depotname = $_;
	    $currentfile = $db{$_};
	    next file if $done{$_};
	    $done{$_} = "doing";

            print STDERR "depotname = $_\n";
	    next;
	} elsif (/^\.\.\. ([^\s]+) (.*)$/) {
	    my $rest = $2;

	    if ($1 =~ /#([0-9]+)/) {
		my $ver = $1;
		$rest =~ /change ([0-9]+) ([a-z]+) on ([^ ]+) by ([^ ]+) \(([^)]+)\) '(.*)'$/ || die "bad line: $rest";

		$currentver = $currentfile->[$ver];

		$currentver->{"ver"} = $ver;
		$currentver->{"change"} = $1;
		$currentver->{"op"} = $2;
		$currentver->{"date"} = $3;
		$currentver->{"who"} = $4;
		$currentver->{"type"} = $5;
		$currentver->{"comment"} = $6;
		$currentver->{"comment"} =~ s/"/\\"/g;

		$currentfile->[$ver] = $currentver;
	    } elsif ($1 eq "...") {
		$rest =~ /^([a-z]+) ([a-z]+) ([^\#]+)\#([0-9]+)(,\#([0-9]+))?$/ || die "bad line: $rest";
		my $link = [$1, $2, $3, $4, $6];
		my $links = $currentver->{"links"};

		push @files, $3;

		$links = [ @$links, $link ];

		$currentver->{"links"} = $links;
	    }
	    $db{$depotname} = $currentfile;
	    $done{$depotname} = "done";
	} else {
	    die  "Unrecognised line $_\n";
	}

    }

    close P4;
    die "Failed to get file details for $file: $?\n" if $?;
}

#open VCG, "| xvcg -";
#open VCG, "| cat -";

printf $tmpl{prologue}, $title;

my $order = 1;

foreach $f (keys %db) {
    my $vers = $db{$f};
    my ($prev, $style);

    foreach $v (@$vers) {
	next if !defined $v;
	my $links = $v->{"links"};
	next if (!defined $links && $v->{"op"} !~ /add|delete|branch/);

	my $nodename = "$f#$v->{\"ver\"}";

	printf $tmpl{node}, &node_id($nodename), "$f\@$v->{\"change\"}\\n$v->{\"op\"}: $v->{\"comment\"}";
	printf $tmpl{edge}, &node_id($prev), &node_id($nodename), $style, "black" if $prev;

	if ($links) {
	    for $l (@$links) {
		my $style;
		my $colour = "black";
		my $arrow = "";
		next if $l->[1] eq "from";

		my $target = "$l->[2]#";

		if (defined $l->[4]) {
		    $target .= $l->[4];
		} else {
		    $target .= $l->[3];
		}
		if ($l->[0] eq 'branch') {
		    $style = "solid";
		    $colour = "blue";
		} elsif ($l->[0] eq 'merge' || $l->[0] eq 'copy') {
		    $style = "dotted";
		    $colour = "blue";
		    $arrow = "arrowstyle: line";
		} else {
		    $style = "solid";
		}

		# print "edge: { sourcename: \"$nodename\" targetname: \"$target\" label: \"$l->[0]\" linestyle: $style priority: $pri color: $colour }\n";
		#print "nearedge: { sourcename: \"$nodename\" targetname: \"$target\" $arrow linestyle: $style priority: $pri color: $colour }\n";
	        #print &node_id($nodename) . " -> " . &node_id($target) . " [ style = $style, color = $colour ];\n";
	        printf $tmpl{prioedge}, &node_id($nodename), &node_id($target), $style, $colour;
	    }
	}
	$prev = $nodename;
	$style = ($v->{"op"} eq "delete") ? "invisible" : "solid";
    }
    $order++;
}

print $tmpl{epilogue};