Generate graphviz digraph script <dot-file> according to project dependencies that parsed from VC6 workspace file <dsw-file>.

gistfile1.pl

#!/usr/bin/perl -w
# ----------------------------------------------------------------------------
# $Date: 2007-10-29 18:15:53 +0800 (星期一, 29 十月 2007) $
# $Rev: 408 $
# $Author: jeffhung $
# ----------------------------------------------------------------------------
# revid: "@(#) $Id: dsw2dot.pl 408 2007-10-29 10:15:53Z jeffhung $"
# ----------------------------------------------------------------------------

use strict;
use utf8;
use File::Basename;
use Getopt::Long;
use JSON; # for --cluster
use List::Util qw(first);

my $__pname__ = basename($0);
my ($__revision__) = ('$Rev: 408 $' =~ m/(\d+)/o);
my ($__revdate__) = ('$Date: 2007-10-29 18:15:53 +0800 (星期一, 29 十月 2007) $' =~ m/(\d{4}-\d{2}-\d{2})/o);

sub usage
{
	print STDERR <<"EOF";
Usage: $__pname__ [ <option> ... ] <dsw-file> [ <dot-file> ]

Generate graphviz digraph script <dot-file> according to project dependencies
that parsed from VC6 workspace file <dsw-file>.  If path of digraph script
<dot-file> is not given or is a single dash, will output to standard output.

Options:

  -h,--help            Show this help message.
  --rankdir <rd>       Set drawing rank direction <rd> to TB (top-to-bottom),
                       LR (left-to-right), RL (right-to-left), or BT
                       (bottom-to-top).  (default: TB)
  --coloring <color>   Read node coloring information from <color>, which is
                       in JSON format.
  --cluster <cluster>  Read clustering information from <cluster>, which is
                       in JSON format.
  --hide <project>     Hide projects <project>.
  --png <png-file>     Output PNG format from <dot-file>, too.
  -v,--verbose         Show verbose progress messages.

Revision: r$__revision__ ($__revdate__)
EOF
	exit(0);
}

sub msg_exit
{
	my $ex = ((scalar(@_) > 0) ? shift @_ : 0);
	print STDERR <<"EOF";
Usage: $__pname__ [ <option> ... ] <dsw-file> [ <dot-file> ]

Type '$__pname__ --help' for usage.
EOF
	if (scalar @_ > 0) {
		print STDERR "\n";
		foreach my $m (@_) {
			print STDERR "ERROR: $m\n";
		}
	}
	exit($ex);
}

sub quote_value
{
	my ($v) = @_;
	return (($v =~ m/^[0-9]+$/o) ? $v : "\"$v\"");
}

sub dot_nodestyle
{
	my ($node, $dot_options) = @_;
	foreach my $c (keys %{$dot_options->{'node-colors'}}) {
		my $projects = $dot_options->{'node-colors'}->{$c};
		if (grep(/$node/, @$projects)) {
			return " [ style = \"filled\", fillcolor = \"$c\" ]";
		}
	}
	return '';
}

sub dsw2dot
{
	my ($dsw_name, $dswfh, $dotfh, $dot_options) = @_;

	my $projects = {};

	#
	# Parse
	#

	my $line;
	while ($line = <$dswfh>) {
		chomp($line);
		$line =~ s/[\r\n]+$//o;

		if ($line =~ m/^Project: "([^"]*)"/o) {
			my $project = $1;
			$projects->{$project} = [];

			while ($line = <$dswfh>) {
				chomp($line);
				$line =~ s/[\r\n]+$//o;

				if ($line =~ m/^#########/o) {
					last; # while
				}
				elsif ($line =~ m/Project_Dep_Name (.*)$/o) {
					my $depended_project = $1;
					push(@{$projects->{$project}}, $depended_project);
				}
			}
		}
	}

	#
	# Generate dot
	#

	print $dotfh "digraph $dsw_name {\n";
	foreach my $digraph_opt (keys %{$dot_options->{'digraph'}}) {
		printf $dotfh (
			"\t%s = %s\n",
			$digraph_opt,
			quote_value($dot_options->{'digraph'}->{$digraph_opt})
		);
	}
	print $dotfh "\n";
	print $dotfh "\t// general node style\n";
	print $dotfh "\tnode [\n";
	foreach my $node_opt (keys %{$dot_options->{'node'}}) {
		printf $dotfh (
			"\t\t%s = %s\n",
			$node_opt,
			quote_value($dot_options->{'node'}->{$node_opt})
		);
	}
	print $dotfh "\t]\n";
	print $dotfh "\n";
	print $dotfh "\t// general edge style\n";
	print $dotfh "\tedge [\n";
	foreach my $edge_opt (keys %{$dot_options->{'edge'}}) {
		printf $dotfh (
			"\t\t%s = %s\n",
			$edge_opt,
			quote_value($dot_options->{'edge'}->{$edge_opt})
		);
	}
	print $dotfh "\t]\n";

	print $dotfh "\n\t//\n\t// node list\n\t//\n\n";
	my @project_printed;
	if (defined($dot_options->{'clusters'})) {
		my $cluster_serial = 0;
		foreach my $c (sort keys %{$dot_options->{'clusters'}}) {
			my $cluster = $dot_options->{'clusters'}->{$c};

			my $one_in_projects = 0;
			foreach my $p (@$cluster) {
				if (defined(first { defined($_) && ($_ eq $p) } keys %$projects)) {
					$one_in_projects = 1;
					last; # foreach
				}
			}
			if ($one_in_projects) {
				printf $dotfh ("\tsubgraph cluster%d {\n", ++$cluster_serial);
#				print $dotfh "\n";
				print $dotfh "\t\tlabel = \"$c\";\n";
#				print $dotfh "\n";
				print $dotfh "\t\tstyle = solid;\n";
				print $dotfh "\t\tcolor = black;\n";
#				print $dotfh "\n";
				foreach my $p (sort @$cluster) {
					if (defined(first { defined($_) && ($_ eq $p) } keys %$projects)) {
						printf $dotfh ("%s\t\t%s%s;\n",
						               (grep(/$p/, @{$dot_options->{'hide-projects'}}) ? '//' : ''),
						               sprintf('"%s"', $p), dot_nodestyle($p, $dot_options));
						push(@project_printed, $p);
					}
				}
#				print $dotfh "\n";
				print $dotfh "\t}\n";
			}
		}
	}
	foreach my $p (sort keys %$projects) {
		if (!defined(first { defined($_) && ($_ eq $p) } @project_printed)) {
			printf $dotfh ("%s\t%s%s;\n",
			               (grep(/$p/, @{$dot_options->{'hide-projects'}}) ? '//' : ''),
			               sprintf('"%s"', $p), dot_nodestyle($p, $dot_options));
		}
	}

	foreach my $p (sort keys %$projects) {
		print $dotfh "\n\t// Dependencies of $p\n";
		foreach my $dp (sort @{$projects->{$p}}) {
			printf $dotfh ("%s\t%-24s -> %-24s;\n",
			               (grep(/$p/,  @{$dot_options->{'hide-projects'}}) ||
			                grep(/$dp/, @{$dot_options->{'hide-projects'}})
			                ? '//' : ''),
			               sprintf('"%s"', $p),
			               sprintf('"%s"', $dp));
		}
	}
	print $dotfh "\n}\n";

	print $dotfh "\n";
}

my $opt_verbose = 0;
my $opt_rankdir = 'TB';
my $opt_color = undef;
my $opt_cluster = undef;
my @opt_hide_projects;
my $opt_png_file = undef;
my $opt_dsw_file = undef;
my $opt_dot_file = undef;
if (!GetOptions('h|help'     => sub { usage; },
                'rankdir=s'  => \$opt_rankdir,
                'coloring=s' => \$opt_color,
                'cluster=s'  => \$opt_cluster,
                'hide=s'     => \@opt_hide_projects,
                'png=s'      => \$opt_png_file,
                'v|verbose'  => \$opt_verbose)) {
	msg_exit(0);
}
$opt_dsw_file = shift @ARGV
	or msg_exit(1, 'Missing <dsw-file>.');
$opt_dot_file = ((scalar @ARGV > 0) ? shift @ARGV : '-');
if ($opt_rankdir !~ m/TB|LR|RL|BT/o) {
	msg_exit(1, "Bad <rd>: $opt_rankdir");
}
if (defined($opt_png_file) && !defined($opt_dot_file)) {
	msg_exit(1, 'Cannot output PNG file when outputing DOT to stdout.  Please specify <dot-file>.');
}

my $dsw_name = fileparse($opt_dsw_file, qr/\.[^.]*/i);

#print "\$opt_verbose : $opt_verbose\n";
#print "\$opt_dsw_file: $opt_dsw_file\n";
#print "\$dsw_name: $dsw_name\n";
#print "\$opt_dot_file: $opt_dot_file\n";

my $dot_version = `dot -V 2>&1`;
my ($dot_major_version, $dot_minor_version) = ($dot_version =~ m/(\d+)\.(\d+)\./o);

my $dot_options = { # default options
	'digraph' => {
		'fontsize'    => 10,
		'bgcolor'     => 'white', #'transparent',
#		'concentrate' => 'true',
		'splines'     => 'spline',
	},
	'node'  => {
		'shape'    => (($dot_minor_version >= 15) ? 'component' : 'record'),
		'fontsize' => 10,
		'fontname'    => 'Bitstream Vera Sans Mono',
	},
	'edge'  => {
		'fontsize'  => 8,
		'arrowhead' => 'vee', # or 'diamond', 'onormal'
		'arrowsize' => 0.5,
		'style'     => 'dashed', # or 'dotted'
#		'label'     => '<<depends on>>',
	},
};
if ($opt_rankdir ne 'TB') {
	$dot_options->{'digraph'}->{'rankdir'} = $opt_rankdir;
}
my $line = '';
if (defined($opt_color)) {
	open(my $color_fh, '<:encoding(utf8)', $opt_color)
		or msg_exit(2, "Cannot open $opt_color: $!");
	my $color_json = '';
	while ($line = <$color_fh>) {
		$color_json .= $line;
	}
	close($color_fh);
#	print "$color_json";
	$dot_options->{'node-colors'} = jsonToObj($color_json);
}
if (defined($opt_cluster)) {
	open(my $cluster_fh, '<:encoding(utf8)', $opt_cluster)
		or msg_exit(2, "Cannot open $opt_cluster: $!");
	my $cluster_json = '';
	while ($line = <$cluster_fh>) {
		$cluster_json .= $line;
	}
	close($cluster_fh);
#	print "$cluster_json";
	$dot_options->{'clusters'} = jsonToObj($cluster_json);
}
$dot_options->{'hide-projects'} = [];
@{$dot_options->{'hide-projects'}} = @opt_hide_projects;

my $dswfh;
my $dotfh;
open $dswfh, '<:encoding(big5)', $opt_dsw_file;
if ($opt_dot_file ne '-') {
	open $dotfh, '>', $opt_dot_file;
}
else {
	$dotfh = \*STDOUT;
}

dsw2dot($dsw_name, $dswfh, $dotfh, $dot_options);

close $dswfh;
if ($opt_dot_file ne '-') {
	close $dotfh;
}

if (defined($opt_png_file)) {
	die unless defined($opt_dot_file);
	my $cmd = "dot -Tpng -o \"$opt_png_file\" \"$opt_dot_file\"";
#	print STDERR "CMD> $cmd\n";
	system($cmd);
}