user-tools/symlinks2dot

   1 #!/usr/bin/env perl
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 symlinks2dot - Generate a graph in dot(1) format representing the symlink-target relations among the given files
   8
   9 =cut
  10
  11
  12 use Cwd qw/getcwd realpath/;
  13 use File::Basename;
  14 use Pod::Usage;
  15 use Data::Dumper;
  16 $LF = "\n";
  17
  18
  19 %shape_by_type = (qw/symlink diamond  dir box  missing none  normal oval/);
  20
  21
  22 sub normalize_path_1
  23 {
  24         my $path = shift;
  25         # reduce multiple slashes
  26         $path =~ s{/+}{/}g;
  27         # strip trailing slash
  28         $path =~ s{(.)/$}{$1}g;
  29         return $path;
  30 }
  31
  32 sub normalize_path_2
  33 {
  34         my $path = shift;
  35         # reduce self-dir elements
  36         $path =~ s{/\.(/|$)}{/}g;
  37         # reduce root-parent elements
  38         1 while $path =~ s{^/\.\.(/|$)}{/};
  39         return $path;
  40 }
  41
  42 sub normalize_path
  43 {
  44         return normalize_path_2(normalize_path_1(shift));
  45 }
  46
  47 sub gettype
  48 {
  49         my $path = shift;
  50         if(-l $path){ return "symlink" }
  51         elsif(-d $path){ return "dir" }
  52         elsif(!-e $path){ return "missing" }
  53         else { return "normal" }
  54 }
  55
  56 sub get_ancestors
  57 {
  58         my $path = shift;
  59         my @ancestors;
  60         my @elems = split /\//, $path;
  61         for my $depth (1 .. ($#elems-1))
  62         {
  63                 push @ancestors, join '/', @elems[0..$depth];
  64         }
  65         return @ancestors;
  66 }
  67
  68 sub add_symlink_target
  69 {
  70         my $path = shift;
  71         my $hashref = shift;
  72
  73         my $target = readlink $path;
  74         my $target_abs;
  75         if($target =~ /^\//)
  76         {
  77                 $target_abs = $target;
  78         }
  79         else
  80         {
  81                 $target_abs = dirname($path) . '/' . $target;
  82         }
  83         $target_abs = normalize_path($target_abs);
  84         $hashref->{$target_abs} = 1 unless exists $hashref->{$target_abs};
  85 }
  86
  87
  88 for my $path (@ARGV)
  89 {
  90         if($path !~ /^\//) { $path = getcwd . '/' . $path; }
  91         $path = normalize_path($path);
  92         $paths_to_traverse{$path} = 1;
  93         $paths_given_at_cli{$path} = 1;
  94 }
  95
  96
  97 $node{'/'} = {};
  98
  99
 100 while(grep {$paths_to_traverse{$_}} keys %paths_to_traverse)
 101 {
 102         for my $path (grep {$paths_to_traverse{$_}} keys %paths_to_traverse)
 103         {
 104                 for my $ancestor (get_ancestors($path))
 105                 {
 106                         my $basename = basename($ancestor);
 107                         if($basename eq '..')
 108                         {
 109                                 # we don't get here via symlinked dirs, because we stop walking through the path when a symlink is found, see below.
 110                                 # so it's safe to go back the same path where we got here.
 111                                 $ancestor =~ s{/[^/]+/\.\.$}{};
 112                         }
 113
 114                         $node{$ancestor} = {} unless exists $node{$ancestor};
 115
 116                         if(-l $ancestor)
 117                         {
 118                                 add_symlink_target($ancestor, \%paths_to_traverse);
 119                                 $soft_links{$ancestor} = 1;
 120                                 last;
 121                         }
 122                 }
 123
 124                 if($paths_given_at_cli{$path})
 125                 {
 126                         $node{$path}->{'emphasis'} = 1;
 127                 }
 128
 129                 if(-l $path)
 130                 {
 131                         add_symlink_target($path, \%paths_to_traverse);
 132                 }
 133
 134                 $paths_to_traverse{$path} = 0;
 135         }
 136 }
 137
 138
 139
 140 $\ = $LF;
 141
 142 print "digraph \"symlinks\" {
 143         rankdir=TB;
 144         concentrate=true;
 145         bgcolor=transparent;
 146         node [fontsize=10,width=.1,height=.1];";
 147
 148 for my $path (keys %node)
 149 {
 150         $node{$path}->{'basename'} = basename($path);
 151 }
 152
 153 for my $path (sort {$node{$a}->{'basename'} cmp $node{$b}->{'basename'}} keys %node)
 154 {
 155         my $basename = $node{$path}->{'basename'};
 156         my $shape = $shape_by_type{gettype($path)};
 157         my $attrs;
 158         if($node{$path}->{'emphasis'}) { $attrs .= ",style=\"bold\""; }
 159         print "\"$path\" [label=\"$basename\",shape=\"$shape\"$attrs];"
 160 }
 161
 162 my $level = 2;
 163 while(1)
 164 {
 165         my @same_rank_nodes = grep {scalar(split /\//, $_) == $level} keys %node;
 166         last if scalar @same_rank_nodes == 0;
 167         if(scalar @same_rank_nodes > 1)
 168         {
 169                 print "  { rank=\"same\";";
 170                 for my $path (@same_rank_nodes)
 171                 {
 172                         print "    \"$path\";";
 173                 }
 174                 print "  }";
 175         }
 176         $level++;
 177 }
 178
 179 for my $child (keys %solid_edge)
 180 {
 181         my $parent = $solidedge{$child};
 182         my $attrs;
 183         if(!-l $child and !-e $child) { $attrs .= ",style=\"dashed\""; }
 184         print "\"$parent\" -> \"$child\" [color=\"black\"$attrs]";
 185 }
 186
 187 for my $symlink_node_path (keys %soft_links)
 188 {
 189         my $target_node_path = $soft_links{$symlink_node_path};
 190         my $attrs;
 191         #TODOif($target !~ /^\// or !$node{$target_abs_path}->{'is_physical'}) {
 192         $attrs .= ",label=\"$target\"";
 193         my $color = "blue";
 194         if(!-e $symlink_node_path) { $color = "red"; }
 195         print "\"$symlink_abs_path\" -> \"$target_node_path\" [color=\"$color\",fontcolor=\"$color\"$attrs]";
 196 }
 197
 198 print "}";