#!/usr/bin/perl -w
our $datadir;
BEGIN {
our $VERSION = '@VERSION@';
$datadir = $0;
unless( $datadir =~ s@/[^/]+$@@ ) {
foreach( split( /:/, $ENV{'PATH'} ), '.' ) {
if( -d "$_/Mpp" ) {
$datadir = $_;
last;
}
}
}
$datadir or die "makepp: can't find library files\n";
$datadir = eval "use Cwd; cwd . '/$datadir'"
if $datadir =~ /^\./;
unshift @INC, $datadir;
}
sub eval_or_die($) {
my $result = eval $_[0];
&maybe_die;
$result;
}
BEGIN {
(*Mpp::Makefile::implicitly_load,
*DEPEND, *INCL, *PHONY, *BECAUSE) = @Mpp::Text::N[0, 1, 2, 2, 4];
}
sub SELF() { '' }
my $home = absolute_filename dereference file_info $ENV{HOME};
$datadir = absolute_filename dereference file_info $datadir;
sub dir() { defined and $_ ne '' and -d || s!/[^/]+$!! || s!^(\|\w+\|).*!$1! }
sub home() { defined and s/^$home/~/ }
sub makepp() { defined and s!^$Mpp::datadir(?:/|$|(?=:))!|m|! }
sub suf(;$) {
no warnings 'uninitialized';
if( !defined $_[0] ) {
s!.+ (\.[^/.]+) $!*$1!x;
} elsif( !$_[0] ) {
s!^ ([/~|]?) .+ (\.[^/.]+) $!$1*$2!x;
} elsif( $_[0] > 0 ) {
my $n_1 = $_[0] - 1;
s!^ (\|\w+\| | [/~]?[^/]*/ )? ((?:[^/]+/){0,$n_1}) .+ (\.[^/.]+) $!$1$2*$3!x;
} else {
my $n_1 = -1 - $_[0];
s! (?: ^\|\w+\| | ^/(?:[^/]+/)? | ^~[^/]*/ | [^|/]+/ )? (?:[^/]+/){0,$n_1} [^/]+ (\.[^/.]+) $!*$1!x;
}
}
sub usr() {
no warnings 'uninitialized';
s!^/(?:(?=(.))(?:opt|usr)/(?:(?=(.))(?:local|X11R?[67]?)/)?)?(?=(.))(?:bin|etc|include|lib|share)(?:/|$)!|$1$2$3|!;
}
sub merge($$$$) {
return if !/([^\/]+)$_[2]$/;
my $basename = $1;
for( keys %{$_[0]} ) {
if( /(?:.*\/)?\Q$basename\E$_[3]$/ ) {
delete $_[0]{$_};
return ["$_$_[1]", $_];
}
}
}
sub c2o($) { merge $_[0], '>o', qr/\.o(?:bj)?/, qr/\.(?:c(|[xp+])\1|cc|CC?)/ }
sub exe($) { merge $_[0], '*', qr/(?:\.exe)?/, qr/\.o/ }
sub x2($) { merge $_[0], '*2', '', '' }
our %head = ( dot => <<EOSdot, html => <<EOShtml, txt => '', udg => "[\n" );
// Generated by makeppgraph
digraph a {
rankdir=LR
outputorder=edgesfirst
node [shape=box style=filled fillcolor="#ffffffe0"]
edge [dir=back]
EOSdot
<html>
<meta name='generator' content='makeppgraph' />
<style>
a { border: 1px dotted
b { font-weight: normal; border: 1px solid; padding-left: 1ex; padding-right: 1ex; }
ul ul { border-left: 1px dotted
ul { margin: 0; padding-left: 1em; }
li { list-style: square; padding: 0; padding-top: 3px; }
li.fold { list-style: disc; }
li.unfold { list-style: circle; }
.flash { background-color: yellow; }
/* Actually show and hide sublists */
li.fold ul { display: block; }
li.unfold ul { display: none; }
</style>
<script>
// Inspired by Stuart Langridge, www.kryogenix.org/code/browser/aqlists/
function foldify( ul ) {
if( !ul.childNodes || ul.childNodes.length == 0 ) return;
// Iterate LIs
for( var itemi = 0; itemi < ul.childNodes.length; itemi++ ) {
var item = ul.childNodes[itemi];
if( item.nodeName == "LI" ) {
// Iterate things in this LI
var b;
for( var sitemi = 0; sitemi < item.childNodes.length; sitemi++ ) {
var sitem = item.childNodes[sitemi];
switch( sitem.nodeName ) {
case "B": b = sitem; break;
case "UL": foldify(sitem);
item.className = 'fold';
b.title = 'click to (un)fold, double click to unfold all';
b.onclick = function() {
this.parentNode.className = (this.parentNode.className=='fold') ? 'unfold' : 'fold';
return false;
};
b.ondblclick = function() {
foldify( this.parentNode.parentNode.getElementsByTagName( "ul" )[0] );
return false;
};
}
}
}
}
}
var last;
function flash( id ) {
if( id )
(last = document.getElementById( id )).className = 'flash'
else
last.className = '';
}
</script>
<body onload='foldify( document.getElementsByTagName( "ul" )[1] )'>
<table align='right' style='border: 1px solid; background-color: #dfd; padding: 3px; padding-top: 0'><tr><td>
<ul>
<li id='_a' class='fold'>subtree</li>
<li class='unfold'>folded subtree</li>
<li>leaf</li>
<li style='list-style: none'><b>file</b></li>
<li style='list-style: none'><b style='border: 1px dashed'>phony</b></li>
<li style='list-style: none'><a href='#_a' onmouseover="flash( '_a' );" onmouseout="flash();">repeated</a></li>
</ul>
&
&
</td></tr></table>
<ul>
EOShtml
chop $head{html};
our %include =
(dot => 'style=dotted',
html => 'include',
udg => 'a("EDGEPATTERN","dotted")');
our %because =
(dot => 'style=bold color=red',
html => "because",
txt => 'because',
udg => 'a("EDGEPATTERN","thick"),a("EDGECOLOR","#ff0000")');
our %because_self =
(dot => 'style="filled,bold" color=red',
html => 'border-color: red',
txt => 'because',
udg => 'a("BORDER","double")');
our %phony =
(dot => 'shape=ellipse',
html => 'border: 1px dashed',
txt => 'phony',
udg => 'a("_GO","ellipse")');
our @file_attr =
map +($_->[1] =>
{dot => 'fillcolor="#'.$_->[0].'e0"',
html => "background-color: #$_->[0]",
udg => 'a("COLOR","#'.$_->[0].'")'}),
['f8a808', qr/\.(?:c(|[xp+])\1|cc|CC?)(?:>o)?$/],
['f8e800', qr/\.(?:h(|[xp+])\1|hh|HH?)(?:\*2)?$/],
['98e800', qr/\.(?:[ep]c)$/],
['e8e8e8', qr/\.(?:[ao]|so(?:\.[\d.]+)?|obj|dll)$/],
['0090e0', qr/(?:\.(?:p[ml]c?|mk|makepp)|[Mm]akep*file)(?:\.in)?$/];
our %foot = ( dot => '}', html => <<EOShtml, txt => '', udg => ']' );
</ul>
</body>
</html>
EOShtml
my $type = 'udg';
my $bidirectional = 1;
my( $because, $dependencies, $includes );
my( $down, $up, $rename, $merge );
my( @logfiles, $outfile, $plain );
{
my $tmp;
Mpp::Text::getopts
['b', qr/because|build[-_]?reasons?/, \$because],
['D', qr/dependenc(?:ies|y)/, \$dependencies],
['d', qr/down(?:wards?)?/, \$down],
['g', qr/graphviz|dot/, \$type, 0, 'dot'],
[qw(h html), \$type, 0, 'html'],
['I', qr/include(?:[-_]?dir)?/, \$tmp, 1, sub { unshift @INC, $tmp }],
['i', qr/includes/, \$includes],
['l', qr/log(?:[-_]?file)?/, \$tmp, 1, sub { push @logfiles, $tmp }],
[qw(M module), \$tmp, 1, sub { $tmp =~ s/=(.*)/ qw($1)/ and $tmp =~ tr/,/ /; eval_or_die "use $tmp" }],
[qw(m merge), \$merge, 1],
[qw(o output), \$outfile, 1],
[qw(p plain), \$plain],
[qw(r rename), \$rename, 1],
['s', qr/separate[-_]?directions?/, \$bidirectional, 0, 0],
['t', qr/te?xt/, \$type, 0, 'txt'],
['u', qr/up(?:wards?)?/, \$up],
splice @Mpp::Text::common_opts;
}
if( $includes ) {
$include{txt} = 'include' if $dependencies;
} else {
$dependencies = 1;
}
my $build_re = $because ?
qr/(?!NOT)(?:PHONY()|(CHANGED|MARK_NEW|OLD))?/ :
qr/PHONY()/;
for( $rename, $merge ) {
$_ or next;
$_ = eval_or_die "package Mpp::Rewrite; sub { $_ }";
}
$rename ||= \&Mpp::Rewrite::cwd;
find_logfiles @logfiles;
for( $outfile ) {
$_ = $logfiles[0] if !defined;
last if $_ eq '-';
s!^\.makepp/+!! || s!/+\.makepp/+!/!;
s!(?:\.\w+)?$!.$type!;
open STDOUT, '>', $_;
}
my %graph;
for( @logfiles ) {
open my $log, $_ or die "$Mpp::progname: can't open `$_'--$!\n";
<$log>;
my( %dir_name, %file_name );
while( <$log> ) {
chop;
s/^[\02\03]//s;
if( /\01/ ) {
chop( $_ .= <$log> ) while !/\01$/s;
while( s/([\da-f]+)\03([^\01-\03]+)(?:\03([^\01-\03]+)(?:\03([^\01-\03]+))?)?/$1/ ) {
if( defined $3 ) {
if( defined $4 ) {
$dir_name{$3} = $4;
for( "$4" ) {
&$rename();
$file_name{$3} = $_ if defined && $_ ne '';
}
}
for( "$dir_name{$3}/$2" ) {
$dir_name{$1} = $_;
&$rename();
$file_name{$1} = $_ if defined && $_ ne '';
}
} else {
for( "$2" ) {
&$rename();
$file_name{$1} = $_ if defined && $_ ne '';
}
}
}
my( $key, @args ) = split /\01/, "$_-";
pop @args;
if( $includes ) {
if( $key eq 'INCL' ) {
$graph{$file_name{$args[0]}}{$file_name{$args[1]}} |= INCL
if exists $file_name{$args[1]} && exists $file_name{$args[0]};
next;
} elsif( $key eq 'LOAD_INCL' ) {
for( $args[1] ) {
if( s/:\d+$// ) {
&$rename();
} elsif( exists $file_name{$_} ) {
$_ = $file_name{$_};
} else {
next;
}
$graph{$_}{$file_name{$args[0]}} |= INCL
if defined && $_ ne '' && exists $file_name{$args[0]};
}
next;
}
}
next if !$because && !$dependencies;
if( $key =~ /^BUILD_$build_re/o ) {
if( exists $file_name{$args[0]} ) {
if( $2 ) {
exists $file_name{$_} and
$graph{$file_name{$args[0]}}{$file_name{$_}} |= BECAUSE
for split /\02/, $args[1];
} else {
$graph{$file_name{$args[0]}}{+SELF} |= defined $1 ? PHONY : BECAUSE;
}
}
} elsif( $args[1] && $key eq 'DEPEND' ) {
my @dependencies;
for my $start ( split /\02/, $args[0] ) {
next if !exists $file_name{$start};
@dependencies = map { exists $file_name{$_} ? $file_name{$_} : () } split /\02/, $args[1]
or last
if !@dependencies;
$graph{$file_name{$start}}{$_} |= DEPEND
for @dependencies;
}
}
}
}
}
if( @ARGV ) {
my $cwd = absolute_filename( dereference $CWD_INFO ) . '/';
@ARGV =
grep { substr $_, 0, 0, $cwd unless /^\//; &$rename; $_ ne '' } map glob, @ARGV;
my %tmp;
&$Mpp::both_up_down( \$outfile, \$up, \$down ) if $Mpp::both_up_down;
$up = $down = 1
if !$up && !$down;
if( $down ) {
my @list = @ARGV;
while( @list ) {
my $elt = shift @list;
for( keys %{$graph{$elt}} ) {
push @list, $_
if !exists $tmp{$elt}{$_};
$tmp{$elt}{$_} |= $graph{$elt}{$_};
}
}
}
if( $up ) {
my %origin;
for my $start ( keys %graph ) {
$_ ne SELF && undef $origin{$_}{$start}
for keys %{$graph{$start}};
}
while( @ARGV ) {
my $elt = shift;
for( keys %{$origin{$elt}} ) {
push @ARGV, $_;
delete $origin{$elt}{$_};
$tmp{$_}{$elt} |= $graph{$_}{$elt};
$tmp{$elt}{+SELF} ||= 0;
}
}
for my $start ( keys %graph ) {
if( $because && exists $tmp{$start} ) {
for( keys %{$graph{$start}} ) {
if( $_ ne SELF && !exists $tmp{$start}{$_} && $graph{$start}{$_} & BECAUSE ) {
$tmp{$start}{+SELF} |= BECAUSE;
last;
}
}
}
$tmp{$start}{+SELF} |= $graph{$start}{+SELF}
if exists $tmp{$start} && exists $graph{$start}{+SELF};
}
}
%graph = %tmp;
}
sub apply_rename(\%) {
{
my %tmp;
for( keys %graph ) {
if( !$_[0]{$_} ) {
$tmp{$_} = $graph{$_};
} elsif( $tmp{$_[0]{$_}} ) {
%{$tmp{$_[0]{$_}}} = (%{$tmp{$_[0]{$_}}}, %{$graph{$_}});
} else {
$tmp{$_[0]{$_}} = $graph{$_};
}
}
%graph = %tmp;
}
for my $node ( keys %graph ) {
for( keys %{$graph{$node}} ) {
if( $_[0]{$node} && $_[0]{$node} eq ($_[0]{$graph{$node}{$_}} || '') ) {
delete $graph{$node}{$_};
}
}
}
}
if( $merge ) {
my %rename;
for( keys %graph ) {
next if $rename{$_};
my $new = &$merge( $graph{$_} );
next if !$new;
$rename{$_} = $rename{$new->[1]} = $new->[0];
}
apply_rename %rename;
}
&$Mpp::all_types( $outfile, \$type ) if $Mpp::all_types;
if( $plain ) {
for my $first( keys %graph ) {
delete $graph{$first}{SELF};
$graph{$first}{$_} = DEPEND for keys %{$graph{$first}};
}
}
my $sep = $type eq 'dot' ? ' ' : $type eq 'html' ? '; ' : ',';
my $back = $type eq 'udg' ? 'a("_DIR","first")' : $type eq 'html' ? 'back' : '';
my $both = $type eq 'dot' ? 'dir=both' : $type eq 'udg' ? 'a("_DIR","both")' : $plain ? '' : 'bidirectional';
my %node_extra;
sub node_attr() {
return '' if $plain;
$node_extra{$graph{$_}{+SELF} || ''} ||=
($because && exists $graph{$_}{+SELF} && $graph{$_}{+SELF} & BECAUSE ? "$sep$because_self{$type}" : '') .
(exists $graph{$_}{+SELF} && $graph{$_}{+SELF} & PHONY ? "$sep$phony{$type}" : '');
for( my $i = 0; $i < @file_attr; $i += 2 ) {
return $sep . $file_attr[$i+1]{$type} . $node_extra{$graph{$_}{+SELF} || ''}
if exists $file_attr[$i+1]{$type} && /$file_attr[$i]/;
}
$node_extra{$graph{$_}{+SELF} || ''};
}
my $style;
sub edge($$$$$;$) {
my( $start ) = @_;
if( $dependencies ) {
my $found_both = $because && $_ ne $start && $graph{$_}{$start} && $graph{$_}{$start} & BECAUSE;
if( $because && $graph{$start}{$_} & BECAUSE ) {
$style = $because{$type};
} else {
$found_both = $found_both ? 0 :
($_ ne $start && $graph{$_}{$start} && $graph{$_}{$start} & DEPEND);
if( $graph{$start}{$_} & DEPEND ) {
$style = '';
} else {
undef $style;
$found_both = 0;
}
}
if( defined $style ) {
if( $bidirectional && $found_both ) {
$style = $style ? "$style$sep$both" : $both;
$graph{$_}{$start} &= ~(DEPEND | BECAUSE);
} elsif( $back ) {
$style = $style ? "$style$sep$back" : $back;
}
print $style ? "$_[1]$_[2]$style$_[3]$_[4]" : "$_[1]$_[4]" if defined $_[1];
&{$_[5]} if $_[5];
}
}
if( $includes && exists $include{$type} && exists $graph{$start}{$_} && $graph{$start}{$_} & INCL ) {
$style = $include{$type};
if( $bidirectional && $_ ne $start && $graph{$_}{$start} && $graph{$_}{$start} & INCL ) {
$style .= "$sep$both";
$graph{$_}{$start} &= ~INCL;
} elsif( $back ) {
$style .= "$sep$back";
}
print "$_[1]$_[2]$style$_[3]$_[4]" if defined $_[1];
&{$_[5]} if $_[5];
}
}
my( $id, %id ) = 'a';
sub DOTid {
print "$id [label=\"$_\"" . &node_attr . "]\n";
$id++;
}
our $TXTindent = '';
my %HTMLedge =
('top' => '',
'' => '→',
'because' => '<span style="color: red">→</span>',
'back' => '←',
'because; back' => '<span style="color: red">←</span>',
'bidirectional' => '↔',
'because; bidirectional' => '<span style="color: red">↔</span>',
'include' => '↓ ',
'include; back' => '↑ ',
'include; bidirectional' => '↕ ');
sub HTMLid {
my $node_attr = &node_attr;
$node_attr &&= ' style="' . substr( $node_attr, 2 ) . '"';
my $start = $_;
s/&/&/g; s/</</g; s/>/>/g;
print "\n$TXTindent <li id='$id'>$HTMLedge{$style || ''}<b$node_attr>$_</b>";
my $nested = 0;
{
local $TXTindent = "$TXTindent ";
$id{$start} = $id++;
for( sort keys %{$graph{$start}} ) {
next if $_ eq SELF;
edge $start, undef, undef, undef, undef, sub {
print "\n$TXTindent<ul>" unless $nested++;
if( exists $id{$_} ) {
my $end = $_;
s/&/&/g; s/</</g; s/>/>/g;
print "\n$TXTindent <li>$HTMLedge{$style || ''}<a href='#$id{$end}' onmouseover=\"flash( '$id{$end}' );\" onmouseout=\"flash();\">$_</a></li>";
$_ = $end;
} else {
&HTMLid;
}
};
}
}
print "\n$TXTindent </ul>\n$TXTindent " if $nested;
print '</li>';
}
sub TXTid {
local $TXTindent = "$TXTindent ";
undef $id{$_};
my $start = $_;
for( sort keys %{$graph{$_}} ) {
next if $_ eq SELF;
my $attr = $plain ? '' : exists $id{$_} ? ',repeated' : &node_attr;
substr $attr, 0, 1, ' {' and $attr .= '}' if $attr;
edge $start, $TXTindent, '{', '} ', "$_$attr\n", sub {
&TXTid unless exists $id{$_};
};
}
}
sub UDGid {
print qq!l("$id",n("",[a("OBJECT","$_")! . &node_attr . "],[\n";
$id{$_} = $id++;
my $start = $_;
for( reverse sort keys %{$graph{$_}} ) {
next if $_ eq SELF;
edge $start, q!e("",[!, '', '', '],', sub {
if( exists $id{$_} ) {
print qq!r("$id{$_}")),\n!;
} else {
&UDGid;
print "),\n";
}
}
}
print "]))\n";
}
print $head{$type};
if( $type eq 'dot' ) {
for( sort keys %graph ) {
next if $_ eq SELF;
$a = $id{$_} ||= &DOTid;
my $start = $_;
for( sort keys %{$graph{$_}} ) {
next if $_ eq SELF;
$b = $id{$_} ||= &DOTid;
edge $start, "$a -> $b", ' [', ']', "\n";
}
}
} elsif( $type eq 'udg' ) {
exists $id{$_} or &UDGid, print ',' for reverse sort keys %graph;
} else {
my %roots;
@roots{keys %graph} = ();
for my $first( keys %graph ) {
length and exists $graph{$first}{$_} and delete $roots{$_}
for keys %{$graph{$first}};
}
if( $type eq 'txt' ) {
for( sort( keys %roots ), sort keys %graph ) {
next if exists $id{$_};
my $attr = &node_attr;
print $_ . ($attr ? ' {' . substr( $attr, 1 ) . "}\n" : "\n");
&TXTid;
}
} else {
exists $id{$_} or $style = 'top', &HTMLid
for sort( keys %roots ), sort keys %graph;
}
}
print $foot{$type};