Project CMSSW displayed by LXR CMSSW_15_1_X_2025-04-20-2300/​Utilities/​ReleaseScripts/​ignominy/​xmerge	Source navigation Diff markup Identifier search General search
	Version: CMSSW_15_1_X_2025-04-20-2300 CMSSW_15_1_X_2025-04-18-2300 CMSSW_15_1_X_2025-04-17-2300 CMSSW_15_1_X_2025-04-16-2300 CMSSW_15_1_X_2025-04-15-2300 CMSSW_15_1_X_2025-04-14-2300 CMSSW_15_1_X_2025-04-13-2300 CMSSW_15_0_4 CMSSW_15_0_3_patch1 CMSSW_14_0_21_patch1 Revert   Change

Warning, /Utilities/ReleaseScripts/ignominy/xmerge is written in an unsupported language. File is not indexed.

 #!/usr/bin/env perl
 use warnings;
 use strict;
 
 my $me = $0;
 $me =~ s|.*/||;
 
 ######################################################################
 my $SUM_INC_OUT_EDGES   = 0;
 my $SUM_INC_OUT_COUNT   = 1;
 my $SUM_INC_IN_EDGES    = 2;
 my $SUM_INC_IN_COUNT    = 3;
 my $SUM_LIB_OUT_EDGES   = 4;
 my $SUM_LIB_OUT_COUNT   = 5;
 my $SUM_LIB_IN_EDGES    = 6;
 my $SUM_LIB_IN_COUNT    = 7;
 my $SUM_LOG_OUT_EDGES   = 8;
 my $SUM_LOG_IN_EDGES    = 9;
 my $SUM_ALL_IN_EDGES    = 10;
 my $SUM_ALL_OUT_EDGES   = 11;
 my $SUM_N               = 12;
 
 my $CELL_INC_OUT_COUNT  = 0;
 my $CELL_INC_IN_COUNT   = 1;
 my $CELL_LIB_OUT_COUNT  = 2;
 my $CELL_LIB_IN_COUNT   = 3;
 my $CELL_LOG_OUT_EDGES  = 4;
 my $CELL_LOG_IN_EDGES   = 5;
 my $CELL_N              = 6;
 
 my @SUM_LABELS = ("Number of outgoing edges from includes",
                   "Total count of outgoing includes",
                   "Number of incoming edges from includes",
                   "Total count of incoming includes",
                   "Number of outgoing edges from symbols",
                   "Total count of outgoing symbols",
                   "Number of incoming edges from symbols",
                   "Total count of incoming symbols",
                   "Number of (possibly overlapping) outgoing logical edges",
                   "Number of (possibly overlapping) incoming logical edges",
                   "Total count of incoming edges",
                   "Total count of outgoing edges");
 
 sub min {
   my $min = shift;
   foreach my $val (@_) {
     $min = $min > $val ? $val : $min;
   }
   return $min;
 }
 
 sub max {
   my $max = shift;
   foreach my $val (@_) {
     $max = $max > $val ? $max : $val;
   }
   return $max;
 }
 
 sub rgb2hsv {
   my ($r, $g, $b) = @_;
   my ($h, $s, $v);
   my $max = &max($r, $g, $b);
   my $min = &min($r, $g, $b);
 
   $v = $max;
   $s = ($max ? ($max - $min)/$max : 0.0);
   if (! $s) {
     $h = 0;
   } else {
     my $d = $max - $min;
     if ($r == $max) {
       $h = 0. + ($g - $b)/$d;
     } elsif ($g == $max) {
       $h = 2. + ($b - $r)/$d;
     } elsif ($b == $max) {
       $h = 4. + ($r - $g)/$d;
     }
     $h /= 6.;
     $h += 1. if ($h < 0.);
   }
 
   $h = int($h * 1000 + .5)/1000;
   $s = int($s * 1000 + .5)/1000;
   $v = int($v * 1000 + .5)/1000;
 
   return ($h, $s, $v);
 }
 
 sub rgb2yiq {
   my ($r, $g, $b) = @_;
   return (.299 * $r + .587 * $g + .115 * $b,
           .596 * $r - .275 * $g - .321 * $b,
           .212 * $r - .523 * $g + .311 * $b);
 }
 
 sub hsv2rgb {
   my ($h, $s, $v) = @_;
   if ($s eq 0.) {
     die "bad HSV H value: $h -- should be 0\n" if $h;
     return ($v, $v, $v);
   } else {
     $h = 0. if $h eq 1.;
     $h *= 6.;
     my $i = int($h);
     my $f = $h - $i;
     my $p = $v * (1. - $s);
     my $q = $v * (1. - $s * $f);
     my $t = $v * (1. - $s * (1. - $f));
 
     return ($v, $t, $p) if $i == 0;
     return ($q, $v, $p) if $i == 1;
     return ($p, $v, $t) if $i == 2;
     return ($p, $q, $v) if $i == 3;
     return ($t, $p, $v) if $i == 4;
     return ($v, $p, $q) if $i == 5;
     die;
   }
 }
 
 sub validate_flag {
   my ($value, $opt) = @_;
 
   return 1 if (grep(lc($value) eq $_, qw(1 y yes)));
   return 0 if (grep(lc($value) eq $_, qw(0 n no)));
   die "$opt must be (1, y, yes) or (0, n, no)\n";
 }
 
 sub file_part {
   my $name = shift;
   $name =~ s|.*/||;
   return $name;
 }
 
 sub dir_part {
   my $name = shift;
   return '' if $name !~ m|/|;
   $name =~ s|/[^/]+$||;
   return $name;
 }
 
 sub check_xedge {
   my ($edges, $rinclusive, $rrx, $xinclusive, $xrx, $source, $target) = @_;
   return 0 if (grep($target =~ /$_/, @$rrx) && 1) ne $rinclusive;
 
   my $matches = 0;
   foreach my $xrx (@$xrx) {
     $matches += scalar grep ($_ ne ':hard'
                              && ($xinclusive ? $_ =~ /$xrx/ : $_ !~ /$xrx/),
                              @{$edges->{$source}->{$target}});
   }
   return $matches;
 }
 
 sub include_edge {
   my ($edges, $nodes, $rinclusive, $rrx, $xinclusive, $xrx, $source, $target) = @_;
   return 0 if !exists $nodes->{$target};
   return 0 if (grep($target =~ /$_/, @$rrx) && 1) ne $rinclusive;
   return 1 if grep($_ eq ':hard', @{$edges->{$source}->{$target}});
   return 2 if &check_xedge($edges,$rinclusive,$rrx,$xinclusive,$xrx,$source,$target) ne 0;
   return 0;
 }
 
 sub do_node {
   my ($gedges,$gnodes, $edges,$nodes, $rinclusive,$rrx, $xinclusive,$xrx, $from,$to,$include)=@_;
   return if ! $include;
 
   if (defined $from) {
     $gedges->{$from} ||= {};
     $gedges->{$from}->{$to} = $include
       if (! exists $gedges->{$from}->{$to}
           || $gedges->{$from}->{$to} > $include);
   }
 
   return if (exists $gnodes->{$to});
 
   $gnodes->{$to} = 1;
   foreach (keys %{$edges->{$to}}) {
     &do_node($gedges, $gnodes, $edges, $nodes, $rinclusive, $rrx, $xinclusive, $xrx, $to, $_,
              &include_edge($edges, $nodes, $rinclusive, $rrx, $xinclusive, $xrx, $to, $_));
   }
 }
 
 sub group_node {
   my ($grouping, $groups, $node, $default) = @_;
   foreach my $group (@$groups) {
     my $i = 0;
     foreach (@{$group->[2]}) {
       if ($node =~ /$_/) {
         $grouping->{$node} = [ $group, $i ];
         return;
       }
       $i++;
     }
   }
   $grouping->{$node} = [ $default, 0 ];
 }
 
 my %renames_results = ();
 sub rename_node {
   my ($renames, $node) = @_;
   if (exists $renames_results{$node}){return $renames_results{$node};}
   for (@$renames){
     if ($node =~ /$_->[0]/){
       my $tmp=eval $_->[1];
       $renames_results{$node}=$tmp;
       $renames_results{$tmp}=$tmp;
       return $tmp;
     }
   }
   $renames_results{$node}=$node;
   return $node;
 }
 
 sub dep_count {
   my ($table, $i, $j, $row) = @_;
   my $x = $table->[$i]->[$j];
   my $y = $table->[$j]->[$i];
 
   my ($libs, $incs);
   if ($row->[3] eq 'libraries') {
     $libs = $row->[2];
     $incs = $row->[5];
   } else {
     $libs = $row->[5];
     $incs = $row->[2];
   }
 
   $x->[$CELL_LIB_OUT_COUNT] += $libs;
   $y->[$CELL_LIB_IN_COUNT] += $libs;
 
   $x->[$CELL_INC_OUT_COUNT] += $incs;
   $y->[$CELL_INC_IN_COUNT] += $incs;
 }
 
 sub dep_xcount {
   my ($edges, $rinclusive, $rrx, $xinclusive, $xrx, $labels, $table, $i, $j) = @_;
   my $source = $labels->[$i];
   my $target = $labels->[$j];
   my $matches = &check_xedge($edges, $rinclusive, $rrx, $xinclusive, $xrx, $source, $target);
   if ($matches ne 0) {
     $table->[$i]->[$j]->[$CELL_LOG_OUT_EDGES] += $matches;
     $table->[$j]->[$i]->[$CELL_LOG_IN_EDGES]  += $matches;
   }
 }
 
 sub dep_summarise {
   my ($summary, $labels, $table, $i) = @_;
 
   foreach my $cell (@{$table->[$i]}) {
     $summary->[$i]->[$SUM_INC_OUT_EDGES]++ if ($cell->[$CELL_INC_OUT_COUNT]);
     $summary->[$i]->[$SUM_INC_OUT_COUNT]   += $cell->[$CELL_INC_OUT_COUNT];
     $summary->[$i]->[$SUM_INC_IN_EDGES]++  if ($cell->[$CELL_INC_IN_COUNT]);
     $summary->[$i]->[$SUM_INC_IN_COUNT]    += $cell->[$CELL_INC_IN_COUNT];
 
     $summary->[$i]->[$SUM_LIB_OUT_EDGES]++ if ($cell->[$CELL_LIB_OUT_COUNT]);
     $summary->[$i]->[$SUM_LIB_OUT_COUNT]   += $cell->[$CELL_LIB_OUT_COUNT];
     $summary->[$i]->[$SUM_LIB_IN_EDGES]++  if ($cell->[$CELL_LIB_IN_COUNT]);
     $summary->[$i]->[$SUM_LIB_IN_COUNT]    += $cell->[$CELL_LIB_IN_COUNT];
 
     $summary->[$i]->[$SUM_LOG_OUT_EDGES]   += $cell->[$CELL_LOG_OUT_EDGES];
     $summary->[$i]->[$SUM_LOG_IN_EDGES]    += $cell->[$CELL_LOG_IN_EDGES];
 
     $summary->[$i]->[$SUM_ALL_IN_EDGES]++
       if ($cell->[$CELL_INC_IN_COUNT]
           || $cell->[$CELL_LIB_IN_COUNT]
           || $cell->[$CELL_LOG_IN_EDGES]);
 
     $summary->[$i]->[$SUM_ALL_OUT_EDGES]++
       if ($cell->[$CELL_INC_OUT_COUNT]
           || $cell->[$CELL_LIB_OUT_COUNT]
           || $cell->[$CELL_LOG_OUT_EDGES]);
   }
 }
 
 sub dep_metrics_mark {
   my ($edges, $tedges, $n,$m) = @_;
   return if defined $m && exists $tedges->{$n}->{$m};
   if (defined $m) {
     $tedges->{$n}->{$m} = 1;
     map { &dep_metrics_mark($edges, $tedges, $n, $_) } keys %{$edges->{$m}};
   }
   map { &dep_metrics_mark($edges, $tedges, $n, $_) } keys %{$edges->{$n}};
 }
 
 sub dep_metrics {
   # see ftp://ftp.aw.com/cp/lakos/idep_ldep.c
   my ($edges, $nodes, $metrics) = @_;
 
   my @nodes     = keys %$nodes;
   my $n         = scalar @nodes;
   my @levels    = (0) x $n;
   my $nlevels   = 1;
   my @levelnums = (0) x $n;
   my @mapping   = (0) x $n;
   my $nmapping  = 0;
 
   my @lowerthan = map { [ (0) x $n ] } @nodes, 'foo', 'bar';
    
   # calculate transitive closure
   my %tedges = map { $_ => {} } keys %$edges;
   map { &dep_metrics_mark($edges, \%tedges, $_, undef) } keys %$edges;
 
   # determine and label all members of all cycles
   my @cycles    = (-1) x $n;
   my @weights   = (0) x $n;
   my @cindices  = (-1) x $n;
   my $ncycles   = 0;
   my $nmembers  = 0;
   for (my $i = 0; $i < $n; ++$i) {
     next if $cycles[$i] >= 0;
     my $found = 0;
     $cycles[$i] = $i;
     for (my $j = $i + 1; $j < $n; ++$j) {
       next if $cycles[$j] >= 0;
       if ($tedges{$nodes[$i]}->{$nodes[$j]} && $tedges{$nodes[$j]}->{$nodes[$i]}) {
         $found = 1;
         $cycles[$j] = $i;
       }
     }
     if ($found) {
       my $weight = 0;
       for (my $j = $i; $j < $n; ++$j) {
         ++$weight if $cycles[$j] == $i;
       }
       for (my $j = $i; $j < $n; ++$j) {
         $weights[$j] = $weight if $cycles[$j] == $i;
       }
       $nmembers += $weight;
       $ncycles++;
     } else {
       $cycles[$i] = -1;
     }
   }
 
   # sort packages into levelized order; strip principal cycle
   # members from their dependencies on other cycle members
   for (my $i = 0; $i < $n; ++$i) {
     next if $cycles[$i] != $i;
     for (my $j = $i + 1; $j < $n; ++$j) {
       next if $cycles[$j] != $i;
       delete $tedges{$nodes[$i]}->{$nodes[$j]};
       $lowerthan[1]->[$j] = 1;
     }
   }
 
   # construct levelized array of package indices
   while ($nmapping < $n) {
     my $count = 0;
     my @current = (0) x $n;
     for (my $i = 0; $i < $n; ++$i) {
       next if $cycles[$i] >= 0 && $cycles[$i] != $i;
       next if $lowerthan[$nlevels]->[$i];
 
       my $weight = 1;
       if ($cycles[$i] == $i) {
         next if $weights[$i] > $nlevels + 1;
         $weight = $weights[$i];
       }
 
       my $level = $nlevels + 1 - $weight;
       my $j;
       for ($j = 0; $j < $n; ++$j) {
         next if $i == $j;
         last if $tedges{$nodes[$i]}->{$nodes[$j]} && !$lowerthan[$level]->[$j];
       }
       next if $j < $n;
 
       $current[$i] = 1;
       $mapping[$nmapping++] = $i;
       $count++;
       if ($cycles[$i] == $i) {
         for ($j = $i + 1; $j < $n; ++$j) {
           next if $cycles[$j] != $i;
           $mapping[$nmapping++] = $j;
           $count++;
           $tedges{$nodes[$i]}->{$nodes[$j]} = 1;
         }
       }
     }
     for (my $i = 0; $i < $n; ++$i) {
       $current[$i] ||= $lowerthan[$nlevels][$i];
     }
     $levels[$nlevels++] = $count;
     @{$lowerthan[$nlevels]} = @current;
     @current = (0) x $n;
   }
   die "internal error" if $nmapping != $n;
 
   # start loading level number array
   my $start = 0;
   for (my $i = 1; $i < $nlevels; ++$i) {
     my $top = $start + $levels[$i];
     for (my $j = $start; $j < $top; ++$j) {
       $levelnums[$mapping[$j]] = $i;
     }
     $start = $top;
   }
 
   # sort packages on each level lexicographically
   $start = 0;
   for (my $k = 1; $k < $nlevels; ++$k) {
     my $top = $start + $levels[$k];
     for (my $i = $start + 1; $i < $top; ++$i) {
       for (my $j = $start; $j < $i; ++$j) {
         if (($nodes[$mapping[$i]] cmp $nodes[$mapping[$j]]) < 0) {
           my $tmp = $mapping[$i];
           $mapping[$i] = $mapping[$j];
           $mapping[$j] = $tmp;
         }
       }
     }
     $start = $top;
   }
 
   # create @cindices from cycles array and the level map
   my $ncycle = 0;
   for (my $i = 0; $i < $n; ++$i) {
     my $label = $cycles[$mapping[$i]];
     next if $label < 0;
     my $index = $cindices[$mapping[$i]];
     next if $index >= 0 && $index < $ncycle;
     for (my $j = $i; $j < $n; ++$j) {
       $cindices[$mapping[$j]] = $ncycle if $label == $cycles[$mapping[$j]];
     }
     $ncycle++;
   }
   die "internal error" if $ncycle != $ncycles;
 
   # sort packages on each level again but now grouping
   # cyclically dependent packages together
   $start = 0;
   for (my $k = 1; $k < $nlevels; ++$k) {
     my $top = $start + $levels[$k];
     for (my $i = $start + 1; $i < $top; ++$i) {
       for (my $j = $start; $j < $i; ++$j) {
         my $ci = $cindices[$mapping[$i]];
         my $cj = $cindices[$mapping[$j]];
         if ($ci < $cj || ($ci == $cj && ($nodes[$mapping[$i]] cmp $nodes[$mapping[$j]]) < 0)) {
           my $tmp = $mapping[$i];
           $mapping[$i] = $mapping[$j];
           $mapping[$j] = $tmp;
         }
       }
     }
     $start = $top;
   }
 
   # calculate ccd
   my %tmp = map { $_ => {} } keys %tedges;
   foreach my $n (keys %tedges) {
     map { $tmp{$n}->{$_} = 1 } keys %{$tedges{$n}};
   }
 
   for (my $i = 0; $i < $n; ++$i) {
     if ($levelnums[$i] == 0) {
       for (my $j = 0; $j < $n; ++$j) {
         delete $tmp{$nodes[$j]}->{$nodes[$i]};
       }
     } else {
       $tmp{$nodes[$i]}->{$nodes[$i]} = 1;
     }
   }
 
   my $ccd = 0;
   map { $ccd += scalar keys %{$tmp{$_}} } keys %tmp;
 
   if (0) {
     # make canonical representation: remove all redundant (transitive0edges
     my @tmp = map { [ (0) x $n ] } @nodes;
     for (my $i = 0; $i < $n; ++$i) {
       my $u = $mapping[$i];
       for (my $j = 0; $j < $n; ++$j) {
         my $v = $mapping[$j];
         my $bit = $tedges{$nodes[$u]}->{$nodes[$v]};
         $tmp[$i]->[$j] = $bit;
       }
     }
     # FIXME;
   }
 
   $metrics->{NODES}     = \@nodes;
   $metrics->{N}         = $n;
   $metrics->{LEVELS}    = \@levels;
   $metrics->{NLEVELS}   = $nlevels;
   $metrics->{LEVELNUMS} = \@levelnums;
   $metrics->{MAPPING}   = \@mapping;
   $metrics->{NMAPPINGS} = $nmapping;
    
   $metrics->{TEDGES}    = \%tedges;
 
   $metrics->{CYCLES}    = \@cycles;
   $metrics->{WEIGHTS}   = \@weights;
   $metrics->{CINDICES}  = \@cindices;
   $metrics->{NCYCLES}   = $ncycles;
   $metrics->{NMEMBERS}  = $nmembers;
 
   $metrics->{CCD}       = $ccd;
 
   return $nmembers;
 }
 
 my %url_results = ();
 sub node_url {
   my ($urls, $name) = @_;
   if (exists $url_results{$name}){return $url_results{$name};}
   foreach my $mapping (@$urls) {
     if ($name =~ /$mapping->[0]/) {
       my $N = $name;
       my $tmp = eval $mapping->[1];
       $url_results{$name} = $tmp;
       return $tmp;
     }
   }
   $url_results{$name} = undef;
   return undef;
 }
 
 sub read_report {
   my ($edges, $nodes, $file, $part) = @_;
   my $node = undef;
 
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     last if /^\# $part/;
   }
 
   while (<FILE>) {
     chomp;
     last if (/^\#\#\#\#\#/);
     next if (/^\s*$/);
 
     if (/^\S/) {
       chop;
       s% ([^/]+)$%%;
       $node = $_;
       $nodes->{$_} = 1;
       $edges->{$_} ||= {};
     } elsif (/^\s+\S/) {
       print STDERR "$file: warning: no current node for a dependency\n"
         if ! $node;
 
       s/\s//g;
       $nodes->{$_} = 1;
       $edges->{$_} ||= {}; 
       $edges->{$node}->{$_} ||= [];
       push(@{$edges->{$node}->{$_}}, ':hard');
     } else {
       print STDERR "$file: warning: unrecognized line: `$_'\n";
     }
   }
   close(FILE);
 }
 
 sub keep_nodes {
   my ($kept_nodes, $edges, $node) = @_;
   $kept_nodes->{$node} = 1;
   foreach my $edge (keys %{$edges->{$node}}) {
     if (!exists $kept_nodes->{$edge}){
       &keep_nodes ($kept_nodes, $edges, $edge);
     }
   }
 }
 
 sub remove_nodes {
   my ($edges, $nodes, $spart) = @_;
   my %kept_nodes = ();
   my $node;
   foreach $node (keys %$nodes) {
     if (($node=~/$spart/) && (!exists $kept_nodes{$node})){
       &keep_nodes (\%kept_nodes, $edges, $node);
     }
   }
   foreach $node (keys %$nodes) {
     if (!exists $kept_nodes{$node}){
       delete $nodes->{$node};
       delete $edges->{$node};
     }
   }
 }
 
 sub recalculate {
   my ($renames, $edges, $nodes, $vector) = @_;
   my %indexs = ();
   my @newvec = ();
   foreach my $item (@$vector){
     my $node = &rename_node($renames, $item->[0]);
     my $edge = &rename_node($renames, $item->[1]);
     my $count = $item->[2];
     next if (!exists $edges->{$node}->{$edge});
     if (!exists $indexs{"$node:$edge"}){
       $indexs{"$node:$edge"} = @newvec;
       $item->[0]=$node;
       $item->[1]=$edge;
       push(@newvec, $item);      
     }
     else{
       my $index = $indexs{"$node:$edge"};
       my $pcount = $newvec[$index]->[2];
       $newvec[$index]->[2] = $pcount + $count;
     }
   }
   while (@$vector > 0){pop @$vector;}
   foreach my $item (@newvec){push (@$vector, $item);}
 }
 
 sub apply_renames {
   my ($renames, $edges, $nodes) = @_;
   my %nnodes = ();
   foreach my $node (keys %$nodes){
     my $nnode = &rename_node($renames, $node);
     $nnodes{$nnode} ||= {};
     foreach my $edge (keys %{$edges->{$node}}){
       my $nedge = &rename_node($renames, $edge);
       $nnodes{$nnode}->{$nedge} = 1;
     }
     delete $nodes->{$node};
     delete $edges->{$node};
   }
   foreach my $node (keys %nnodes){
     foreach my $edge (keys %{$nnodes{$node}}){
       $nodes->{$node} = 1; $edges->{$node} ||= {};
       $nodes->{$edge} = 1; $edges->{$edge} ||= {};
       $edges->{$node}->{$edge} ||= [];
       if(!exists $edges->{$node}->{$edge}->[0]){
         push(@{$edges->{$node}->{$edge}}, ':hard');
       }
     }
   }
 }
 
 sub read_counts {
   my ($renames, $edges, $nodes, $vector, $note, $file) = @_;
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     chomp;
     if (! /^\s*(\d+)\s+(\S+)\s+(\S+(,\s+\S+)?)(\s+via\s+(\S+))?$/) {
       print STDERR "$file: error: bad line `$_'\n";
       next;
     }
     my $node=$2;
     my $edge=$3;
     next if &rename_node($renames, $node) eq &rename_node($renames, $edge);
     $nodes->{$node} = 1; $edges->{$node} ||= {};
     $nodes->{$edge} = 1; $edges->{$edge} ||= {};
     $edges->{$node}->{$edge} ||= [];
     push(@{$edges->{$node}->{$edge}}, ':hard');
     push(@$vector, [ $node, $edge, $1, $note, $5 || '', -1]);
   }
   close(FILE);
 }
 
 sub read_loglinks {
   my ($edges, $nodes, $file) = @_;
   my @xtargets = ();
   my @xreasons = ();
 
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     chomp; s/\#.*//; s/\s*$//;
     next if (/^\s*$/);
 
     if (/^(\S+(\s*,\s*\S+)*)(\s*:\s*->\s*(\S+(\s*,\s*\S+)*))?$/) {
       @xreasons = split(/\s*,\s*/, $1);
       @xtargets = split(/\s*,\s*/, $4 || '');
     } elsif (/^\s+(\S+(\s*,\s*\S+)*)(\s*->\s*(\S+(\s*,\s*\S+)*))?$/) {
       my @sources = split(/\s*,\s*/, $1);
       my @targets = ($4 ? split(/\s*,\s*/, $4) : @xtargets);
       foreach my $source (grep(exists $nodes->{$_}, @sources)) {
         $edges->{$source} ||= {};
         map { $edges->{$source}->{$_} ||= [];
               push(@{$edges->{$source}->{$_}}, @xreasons); } @targets;
       }
     } else {
       print STDERR "$file: warning: unrecognized line: `$_'\n";
     }
   }
   close(FILE);
 }
 
 sub read_groups {
   my ($groups, $file) = @_;
   my $i = 0;
 
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     chomp;
     while (/\\$/ && !eof(FILE)) {
       chop; $_ .= <FILE>; chomp;
     }
     if (/\\$/) {
       print STDERR "$file: warning: incomplete last line\n";
       chop;
     }
     s/\#.*//; s/^\s*//; s/\s*$//;
     next if (/^$/);
 
     if (/^group\s+(\S+)\s+(.*)\s+--\s+(.*)$/) {
       push(@$groups, [ $i++, $1, [ split(/\s+/, $2) ], $3 ]);
     } else {
       print STDERR "$file: warning: unrecognized line: `$_'\n";
     }
   }
   close(FILE);
 }
 
 sub read_renames {
   my ($renames, $file) = @_;
   my $i = 0;
 
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     chomp;
     while (/\\$/ && !eof(FILE)) {
       chop; $_ .= <FILE>; chomp;
     }
     if (/\\$/) {
       print STDERR "$file: warning: incomplete last line\n";
       chop;
     }
     s/\#.*//; s/^\s*//; s/\s*$//;
     next if (/^$/);
 
     if (/^rename\s+([^:]+):(.*)$/) {
       push(@$renames, [ $1, $2 ]);
     } else {
       print STDERR "$file: warning: unrecognized line: `$_'\n";
     }
   }
   close(FILE);
 }
 
 sub read_urls {
   my ($urls, $file) = @_;
   my $i = 0;
 
   open(FILE, $file) || die "$file: error: cannot open: $!\n";
   while (<FILE>) {
     chomp;
     while (/\\$/ && !eof(FILE)) {
       chop; $_ .= <FILE>; chomp;
     }
     if (/\\$/) {
       print STDERR "$file: warning: incomplete last line\n";
       chop;
     }
     s/^\s*//; s/\s*$//;
     next if (/^$/);
 
     if (/^([^:]+):(.*)$/) {
       push(@$urls, [ $1, $2 ]);
     } else {
       print STDERR "$file: warning: unrecognized line: `$_'\n";
     }
   }
   close(FILE);
 }
 
 ######################################################################
 my $usage =
     "usage: $me [--text|--html|--side-by-side] [--group=FILE] [--rename=FILE]\n"
   . "                INCS LIBS FILTER INCLUSIVE? [RE...]\n"
   . "                [! RESTRICT-INCLUSIVE? RESTRICT-RE...]\n"
   . "                [-- EXTRA EXTRA-INCLUSIVE? EXTRA-RE...]\n";
 
 my $mode = 'text';
 my $groupfile = '/dev/null';
 my $renamefile = '/dev/null';
 my $default_group = [ -1, 'other', [ '.*' ], '1 1 1' ];
 
 while (scalar @ARGV && $ARGV[0] =~ /^--(.*)$/) {
   my $arg = $1;
   if ($1 eq 'text' || $1 eq 'html' || $1 eq 'side-by-side') {
     $mode = $1;
   } elsif ($1 =~ /^group=(.*)/) {
     $groupfile = $1;
   } elsif ($1 =~ /^rename=(.*)/) {
     $renamefile = $1;
   } else {
     print STDERR "unrecognised option `$arg'\n";
     die $usage;
   }
   shift(@ARGV);
 }
 
 die $usage if (scalar @ARGV < 3);
 my ($incfile, $libfile, $filter, $inclusive, @restargs) = @ARGV;
 my ($rinclusive, $xfile, $xinclusive, @rx, @rrx, @xrx) = (1, "/dev/null", 1);
 $inclusive = &validate_flag($inclusive, "INCLUSIVE?");
 
 while (scalar @restargs) {
   my $arg = shift(@restargs);
   if ($arg eq '!') {
     die $usage if (scalar @restargs < 2);
     $rinclusive = &validate_flag(shift(@restargs), "RESTRICT-INCLUSIVE?");
     while (scalar @restargs && $restargs[0] ne '--') {
       push(@rrx, shift(@restargs));
     }
   } elsif ($arg eq '--') {
     die $usage if (scalar @restargs < 2);
     $xfile = shift(@restargs);
     $xinclusive = &validate_flag(shift(@restargs), "EXTRA-INCLUSIVE?");
     @xrx = @restargs;
     $xrx[0] ||= '.*';
     last;
   } else {
     push(@rx, $arg);
   }
 }
 $rx[0] ||= '.*';
 $rrx[0] ||= '.*';
 
 ######################################################################
 my @incdeps = ();
 my @libdeps = ();
 my %nodes = ();
 my %gnodes = ();
 my %edges = ();
 my %gedges = ();
 my @roots = ();
 my @all = ();
 my @groups = ();
 my %grouping = ();
 my @renames = ();
 
 # Read in renames.
 &read_renames(\@renames, $renamefile);
 
 # Read in the files.  The count files are output from "sort | uniq -c".
 &read_counts(\@renames, \%edges, \%nodes, \@incdeps, 'includes', $incfile);
 &read_counts(\@renames, \%edges, \%nodes, \@libdeps, 'libraries', $libfile);
 
 # Read in the extra-deps file.
 &read_loglinks(\%edges, \%nodes, $xfile);
 
 # Remove the unwanted nodes
 &remove_nodes(\%edges, \%nodes, $filter) if ($filter ne "");
 &apply_renames(\@renames, \%edges, \%nodes);
 
 # recalculate the incdeps, libdeps
 &recalculate (\@renames, \%edges, \%nodes, \@incdeps);
 &recalculate (\@renames, \%edges, \%nodes, \@libdeps);
 
 # Read in grouping.
 &read_groups(\@groups, $groupfile);
 
 # Calculate which nodes can be reached.
 foreach my $node (keys %nodes) {
   push(@roots, $node) if (grep($node =~ /$_/, @rx) && 1) eq $inclusive;
 }
 
 foreach (@roots) {
   &do_node(\%gedges,\%gnodes, \%edges,\%nodes, $rinclusive,\@rrx, $xinclusive,\@xrx, undef,$_,1);
 }
 @all = grep(exists $gnodes{$_->[0]}, @incdeps, @libdeps);
 
 # Group nodes
 map { &group_node(\%grouping, \@groups, $_, $default_group) } keys %nodes;
 
 ######################################################################
 # Interleave and merge dependency counts.
 my @mixed = sort { $a->[0] cmp $b->[0]
                    || $a->[1] cmp $b->[1]
                    || $a->[3] cmp $b->[3]
                    || $a->[4] cmp $b->[4] } @all;
 
 for (my ($i, $skip) = (0, 0); $i < scalar @mixed; ++$i) {
   if ($skip) {
     $skip = 0;
     next;
   }
 
   if ($mixed[$i]->[3] eq 'includes'
       && $mixed[$i]->[4] eq ''
       && $i < scalar @mixed - 1
       && $mixed[$i+1]->[0] eq $mixed[$i]->[0]
       && $mixed[$i+1]->[1] eq $mixed[$i]->[1]) {
     $mixed[$i]->[5] = $mixed[$i+1]->[2];
     $skip = 1;
   } else {
     $mixed[$i]->[5] = 0;
   }
 }
 
 my @merged = grep { $_->[5] >= 0 } @mixed;
 
 ######################################################################
 # Tabulate dependency counts.
 my %packages = ();
 map { $packages{$_->[0]} = 1; $packages{$_->[1]} = 1; } @merged;
 
 my $i = 0;
 my @labels = ();
 foreach (sort { $a->[1] cmp $b->[1] }
          map { [ $_, &rename_node(\@renames, $_) ] }
          keys %packages) {
   push(@labels, $_->[0]);
   $packages{$_->[0]} = $i++;
 }
 
 my $nlabels = $i;
 my $longest = &max(map { length($_) } @labels) || 0;
 my @table = map { [ map { [ (0) x $CELL_N ] } @labels ] } @labels;
 my @summary = map { [ (0) x $SUM_N ] } @labels;
 
 foreach (@merged) {
   &dep_count(\@table, $packages{$_->[0]}, $packages{$_->[1]}, $_);
 }
 
 for (my $i = 0; $i < $nlabels; ++$i) {
   for (my $j = 0; $j < $nlabels; ++$j) {
     &dep_xcount(\%edges, $rinclusive, \@rrx, $xinclusive, \@xrx, \@labels, \@table, $i, $j);
   }
 }
 
 for (my $i = 0; $i < $nlabels; ++$i) {
   &dep_summarise(\@summary, \@labels, \@table, $i);
 }
 
 ######################################################################
 # Print out dependency counts.
 my $clear = '';
 my $shadow = ' bgcolor="#eeeeee"';
 
 sub cell_label {
   my ($cell, $part) = @_;
   die "internal error: no such part $part"
     if ! grep($part eq $_, qw(includes libraries logical all));
 
   if ($part eq 'all') {
     my $val = "";
     if ($cell->[$CELL_LIB_OUT_COUNT] || $cell->[$CELL_INC_OUT_COUNT]) {
       $val .= "$cell->[$CELL_LIB_OUT_COUNT]/$cell->[$CELL_INC_OUT_COUNT]";
     }
     if ($cell->[$CELL_LOG_OUT_EDGES]) {
       $val .= "/" if $val;
       $val .= "x$cell->[$CELL_LOG_OUT_EDGES]";
     }
     return $val;
   } elsif ($part eq 'libraries') {
     return $cell->[$CELL_LIB_OUT_COUNT];
   } elsif ($part eq 'includes') {
     return $cell->[$CELL_INC_OUT_COUNT];
   } elsif ($part eq 'logical') {
     return $cell->[$CELL_LOG_OUT_EDGES];
   }
 }
 
 sub print_html_table {
   my ($part, $caption, $dobreak) = @_;
 
   my $break = $dobreak ? " class='page-break'" : "";
   print "<?page-break?>\n" if $dobreak;
   print "<H3$break>$caption</H3>\n" if $caption;
   for (my $N = 0; $N*40 < $nlabels; ++$N) {
     print "<TABLE BORDER='0'>\n";
     print "  <TR><TH$shadow>&nbsp;</TH><TH$shadow>&nbsp;</TH>";
     for (my $j = $N*40; $j < $nlabels && $j < ($N+1)*40; ++$j) {
       print "<TH$shadow><A onMouseOver=\"window.status=\'".&rename_node(\@renames, $labels[$j])."\'; return true\">" . ($j+1) . "</A></TH>";
     }
     print "</TR>\n";
 
     for (my $i = 0; $i < $nlabels; ++$i) {
       print "  <TR><TH$shadow>" . ($i+1) . "</TH><TH align='left'$shadow>"
         . &rename_node(\@renames, $labels[$i]) . "</TH>";
       for (my $j = $N*40; $j < $nlabels && $j < ($N+1)*40; ++$j) {
         print "<TD" . (($i + $j) % 2 ? $shadow : $clear) . "><A onMouseOver=\"window.status=\'".&rename_node(\@renames, $labels[$j])."\'; return true\">";
         print (&cell_label($table[$i]->[$j], $part) || '&nbsp;');
         print "</A></TD>";
       }
       print "</TR>\n";
     }
     print "</TABLE>\n";
   }
 }
 
 sub print_html_summary {
   my $caption = shift;
 
   print "<?page-break?>\n";
   print "<H3 class='page-break'>$caption</H3>\n" if $caption;
   print "<OL>\n";
   print map { "  <LI> $_\n" } @SUM_LABELS;
   print "</OL>\n";
   print "<TABLE BORDER='0'>\n";
   print "  <TR><TH$shadow>&nbsp;</TH>";
   for (my $i = 0; $i < $SUM_N; ++$i) {
     print "<TH$shadow><A onMouseOver=\"window.status=\'".$SUM_LABELS[$i]."\'; return true\">". ($i+1) . "</A></TH>";
   }
   print "</TR>\n";
 
   my $in  = 0;
   my $out = 0;
   for (my $i = 0; $i < $nlabels; ++$i) {
     $in  += $summary[$i]->[$SUM_ALL_IN_EDGES];
     $out += $summary[$i]->[$SUM_ALL_OUT_EDGES];
 
     print "  <TR><TH align='left'$shadow>" . &rename_node(\@renames, $labels[$i]) . "</TH>";
     for(my $x=0;$x<scalar(@{$summary[$i]});$x++)
     {
       my $v=$summary[$i][$x];
       print "<TD" . ($i % 8 >= 4 ? $shadow : "") . "><A onMouseOver=\"window.status=\'".$SUM_LABELS[$x]."\'; return true\">$v</TD>";
       #print map { "<TD" . ($i % 8 >= 4 ? $shadow : "") . ">$_</TD>" }
       #  @{$summary[$i]};
     }
     print "</TR>\n";
   }
   # NB: $in == $out by now
   print "  <TR>\n";
   print "    <TD>&nbsp;</TD>\n";
   print "    <TD COLSPAN='@{[$SUM_N-2]}'>Average # of outgoing edges</TD>\n";
   if ($nlabels){
     print "    <TD COLSPAN='2'>" . sprintf("%.2f", $out / $nlabels) . "</TD>\n";
   }
   print "  </TR>\n";
   print "</TABLE>\n";
 }
 
 if ($mode eq 'text') {
   print '#' x 70, "\n# Mixed dependencies\n\n";
   foreach (@mixed) {
     print sprintf "%-12s", "$_->[2]";
     print "$_->[0] $_->[1] $_->[3] $_->[4]\n";
   }
 
   print "\n", '#' x 70, "\n# Merged dependencies\n\n";
   foreach (@merged) {
     print sprintf "%-12s",
       &cell_label($table[$packages{$_->[0]}] ->[$packages{$_->[1]}], 'all');
     print "$_->[0] $_->[1] $_->[4]\n";
   }
 
   print "\n", '#' x 70, "\n# Edge summary\n";
   for (my $i = 0; $i < $SUM_N; ++$i) {
     print "# (@{[$i+1]}) $SUM_LABELS[$i]\n";
   }
   print "\n";
   my $width  = (int(($longest+2)/8)+1)*8;
   my $format = "%-" . $width . "s";
   print sprintf $format, "# PACKAGE";
   print join("\t", map { "($_)" } (1 .. $SUM_N)), "\n";
   print "# ", '-' x ($width + $SUM_N * 8 - 2), "\n";
 
   my $out = 0;
   for (my $i = 0; $i < $nlabels; ++$i) {
     $out += $summary[$i]->[$SUM_ALL_OUT_EDGES];
     print sprintf $format, $labels[$i];
     print join("\t", @{$summary[$i]}), "\n";
   }
   print "# ", '-' x ($width + $SUM_N * 8 - 2), "\n";
   print sprintf $format, "# PACKAGE";
   print join("\t", map { "($_)" } (1 .. $SUM_N)), "\n";
   if ($nlabels){
     print "\nAverage # of outgoing edges: " . sprintf("%.2f", $out / $nlabels) . "\n";
   }
 } elsif ($mode eq 'html') {
   &print_html_table('libraries', "Symbol dependencies", 0);
   &print_html_table('includes', "Header file dependencies", 1);
   &print_html_table('logical', "Logical dependencies", 1) if $xfile ne '/dev/null';
   &print_html_table('all', "All dependencies", 1);
   &print_html_summary("Summary");
 } elsif ($mode eq 'side-by-side') {
   # reorder the nodes according to grouping; use group color
   my @order = sort { $grouping{$a}->[0]->[0] cmp $grouping{$b}->[0]->[0]
                      || $grouping{$a}->[1] cmp $grouping{$b}->[1]
                      || &file_part($a) cmp &file_part($b)
                      || $a cmp $b } @labels;
   my %ordering = ();
   for (my $i = 0; $i < $nlabels; ++$i) {
     $ordering{$order[$i]} = $i;
   }
 
   my $maxheight = 800;
   my $maxwidth  = 550;
   my $fontsize  = 8;
   my $boxheight = $fontsize + 4;
   my $freeheight= max(0, $maxheight - ($nlabels+1) * $boxheight);
   my $boxsep    = int(100 * $freeheight / ($nlabels+1))/100;
   my $boxwidth  = $fontsize * 20;
   my $boxoff    = 2;
   my $sidesplit = $maxwidth - 2*$boxwidth;
   my $height    = ($nlabels + 1) * ($boxheight + $boxsep);
   my $llx       = 20;
   my $lly       = 20;
   my @bbox      = ($llx, $lly,
                    int($llx + $sidesplit + $boxwidth*2 + .5),
                    int($lly + $height + .5));
   my %boxes     = ();
 
   for (my $i = 0; $i < $nlabels; ++$i) {
     $boxes{$order[$i]} =
       [ $llx, $lly + $height - ($i+1)*($boxheight+$boxsep) - $boxheight ];
   }
 
   my $ps_preamble =
     ("/dobox {\n" .
      "  /tb exch def /ts exch def /th exch def\n" .
      "  /bb exch def /bs exch def /bh exch def\n" .
      "  currentpoint /y exch def /x exch def\n" .
      "  newpath x y moveto boxwidth 0 rlineto 0 boxheight rlineto\n" .
      "  boxwidth neg 0 rlineto closepath\n" .
      "  gsave bh bs bb sethsbcolor fill grestore\n".
      "  0 0 0 sethsbcolor stroke\n" .
      "  x y moveto boxoff boxoff rmoveto\n" .
      "  th ts tb sethsbcolor show } bind def\n" .
      "/dashed { [9 9] 0 setdash } bind def\n" .
      "/dotted { [1 6] 0 setdash } bind def\n" .
      "/solid  { [] 0 setdash } bind def\n" .
      "/doline { moveto lineto cvx sethsbcolor stroke pop } bind def");
 
   print "%!PS-Adobe-3.0\n";
   print "%%BoundingBox: ", join(" ", @bbox), "\n";
   print "%%DocumentNeededFonts: font Helvetica Helvetica-Bold\n";
   print "%%BeginProlog\n$ps_preamble\n%%EndProlog\n";
   print "%%Pages: 1\n";
   print "%%Page: 1 1\n";
   print "/boxwidth $boxwidth def\n";
   print "/boxheight $boxheight def\n";
   print "/boxoff $boxoff def\n";
   print "save $llx $lly moveto\n";
   print "(Helvetica-Bold) findfont 8 scalefont setfont\n";
         
   foreach (@order) {
     my $name = &rename_node(\@renames, $_);
     my @hsvcolor = split(/\s+/, $grouping{$_}->[0]->[3]);
     my $y = (&rgb2yiq(&hsv2rgb(@hsvcolor)))[0];
     my $textcolor = ($y < .5 ? "0 0 1" : "0 0 0");
     print "\n($name) $boxes{$_}->[0] $boxes{$_}->[1] moveto "
       . join(" ", @hsvcolor) . " $textcolor dobox";
     print "\n($name) " . ($boxwidth+$sidesplit+$boxes{$_}->[0])
       . " $boxes{$_}->[1] moveto " . join(" ", @hsvcolor) . " $textcolor dobox";
   }
   print "\n\n(Helvetica-Bold) findfont 10 scalefont setfont 0 0 0 sethsbcolor\n";
   print sprintf "%d %d moveto (%s) show\n",
     $llx, $lly + $height - $boxheight, "Out";
   print sprintf "%d %d moveto (%s) show\n",
     $llx + $sidesplit + $boxwidth, $lly + $height - $boxheight, "In";
   print "(Helvetica) findfont 8 scalefont setfont\n";
 
   for (my $i = 0; $i < $nlabels; ++$i) {
     for (my $j = 0; $j < $nlabels; ++$j) {
       my $val = &cell_label($table[$i]->[$j], 'all');
       next if (! $val);
 
       print sprintf "(%s) %s %d %d %d %d doline\n",
         $val, ($val =~ m|^x| ? '0 0 .5' : '0 0 0'),
         $boxes{$order[$ordering{$labels[$i]}]}->[0] + $boxwidth,
         $boxes{$order[$ordering{$labels[$i]}]}->[1] + $boxheight / 2,
         $boxes{$order[$ordering{$labels[$j]}]}->[0] + $sidesplit + $boxwidth,
         $boxes{$order[$ordering{$labels[$j]}]}->[1] + $boxheight / 2;
     }
   }
   print "restore showpage\n";
   print "%%EOF\n";
 } else {
   die "internal error: unknown mode $mode";
 }

This page was automatically generated by the 2.2.1 LXR engine. The LXR team