/[Frey]/trunk/lib/Frey/Class/Graph.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Frey/Class/Graph.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 972 by dpavlin, Fri Jan 9 19:33:26 2009 UTC revision 1137 by dpavlin, Tue Jun 30 19:47:10 2009 UTC
# Line 2  package Frey::Class::Graph; Line 2  package Frey::Class::Graph;
2  use Moose;  use Moose;
3    
4  extends 'Frey';  extends 'Frey';
5  with 'Frey::Web';  with 'Frey::Web', 'Frey::File', 'Frey::Storage';
 with 'Frey::File';  
 with 'Frey::Storage';  
6    
7  use GraphViz;  use GraphViz;
8    
# Line 12  has filter => ( Line 10  has filter => (
10          documentation => 'Regex to select classes',          documentation => 'Regex to select classes',
11          is => 'rw',          is => 'rw',
12          isa => 'Str',          isa => 'Str',
13          default => 'Frey',          required => 1,
14            default => sub {
15                    '(' . join('|',  map { s{lib/}{}; $_ } sort grep { -d $_ } glob("lib/*") ) . ')'
16            },
17    );
18    
19    
20    has filter_class => (
21            is => 'rw',
22            isa => 'Bool',
23            default => 1,
24    );
25    
26    has filter_extends => (
27            is => 'rw',
28            isa => 'Bool',
29            default => 1,
30    );
31    
32    has filter_includes => (
33            is => 'rw',
34            isa => 'Bool',
35            default => 1,
36    );
37    
38    has filter_roles => (
39            is => 'rw',
40            isa => 'Bool',
41            default => 1,
42    );
43    
44    
45    has show_extends => (
46            documentation => 'connect to superclasses',
47            is => 'rw',
48            isa => 'Bool',
49    );
50    
51    has show_includes => (
52            documentation => 'use and require connections',
53            is => 'rw',
54            isa => 'Bool',
55            default => 1,
56  );  );
57    
58  has path => (  has show_roles => (
59            documentation => 'roles consumers connections',
60            is => 'rw',
61            isa => 'Bool',
62    );
63    
64    has show_disconnected => (
65            is => 'ro',
66            isa => 'Bool',
67    );
68    
69    
70    has layout => (
71            documentation => 'layout algorithm',
72          is => 'rw',          is => 'rw',
73          isa => 'Str',          isa => 'Str',
74          required => 1,          required => 1,
75          default => 'var/introspect/',  );
76    
77    sub layout_available { q/
78    dot             directed graph
79    neato   spring model
80    twopi   radial
81    circo   circular
82    fdp             force directed spring model
83    / }
84    
85    has portrait => (
86            documentation => 'vertical layout',
87            is => 'rw',
88            isa => 'Bool',
89    );
90    
91    has no_overlap => (
92            documentation => 'avoid overlaping nodes',
93            is => 'rw',
94            isa => 'Bool',
95  );  );
96    
97  has produce_dot => (  has produce_dot => (
98            documentation => 'dump .dot text format',
99          is => 'rw',          is => 'rw',
100          isa => 'Bool',          isa => 'Bool',
101  );  );
102    
103    sub introspect_path { 'var/introspect/' };
104    
105  sub as_markup {  sub as_markup {
106          my ($self) = @_;          my ($self) = @_;
107    
108            my $rankdir = $self->portrait;
109    
110          my $g = GraphViz->new(          my $g = GraphViz->new(
111                  rankdir => 1, # horizontal                  rankdir => $rankdir,
112                    layout => $self->layout,
113  #               layout => 'neato', # grabs too much memory  #               layout => 'neato', # grabs too much memory
114  #               layout => 'twopi', # grabs too much memory  #               layout => 'twopi', # grabs too much memory
115  #               overlap => 'compress',  #               overlap => 'compress',
116  #               no_overlap => 1,                  no_overlap => $self->no_overlap,
117    
118                    node => {
119                            shape => 'box',
120                            style =>'filled',
121                            color => 'grey',
122                            fillcolor =>'lightgray',
123                            fontname  => 'verdana',
124                            fontsize  => '12',
125    
126                    },
127                    edge => {
128                            color => 'grey',
129                            fontname  => 'verdana',
130                            fontsize  => '8',
131                            fontcolor => 'grey',
132                    }
133          );          );
134    
135          our $count = {};          my $count;
136          my $filter = $self->filter;          my $filter = $self->filter;
137    
138          foreach my $path ( $self->dir_extension( $self->path, qr{\.(ya?ml)$}) ) {          foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
139    
140                  my $class = $self->strip_path_extension( $path ) || die "can't strip $path";                  my $class = $self->strip_path_extension( $path ) || die "can't strip $path";
141    
142                    $count->{$class}++ if $self->show_disconnected;
143    
144                  my $data = $self->load( $path );                  my $data = $self->load( $path );
145  #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;  #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;
146    
147                  sub count_label {                  next if $filter && $self->filter_class && $class !~ m{$filter};
                         my ($self,$package) = @_;  
                         my $label = $package;  
                         $label .= $self->dump( $count->{$package} );  
                         return $label;  
                 }  
148    
149                  next if $filter && $class !~ m{$filter};                  if ( $self->show_includes && defined $data->{includes} ) {
150    
151                  if ( my $includes = $data->{includes} ) {                          my $edge;
                         foreach my $type ( keys %$includes ) {  
                                 foreach my $package ( @{ $includes->{$type} } ) {  
152    
153                                          my $usage = $count->{$package}->{$type}->{$class}++;                          foreach my $type ( keys %{ $data->{includes} } ) {
154                                    foreach my $package ( @{ $data->{includes}->{$type} } ) {
155                                            next if $filter && $self->filter_includes && $package !~ m{$filter};
156                                            warn "# $class\t$type\t$package\n";
157                                            my $e = "$class $package";
158                                            if ( $edge->{$e} ) {
159                                                    $edge->{$e}->{style} = 'dashed';
160                                                    $edge->{$e}->{label} .= "\n$type";
161                                            } else {
162                                                    $edge->{$e} = {
163                                                            color => 'blue',
164                                                            label => $type,
165                                                    };
166                                            }
167                                            $count->{$class}++;
168                                            $count->{$package}++;
169                                    }
170                            }
171    
172                                          my $label = $self->count_label($package);                          foreach my $e ( keys %$edge ) {
173                                    my ($c,$p) = split(/\s/, $e);
174                                    $g->add_edge( $c => $p, %{ $edge->{$e} } )
175                            }
176    
177                                          next if $filter && $package !~ m{$filter};                  }
178    
179                                          warn "# $class\t$type\t$package\n$label\n";                  if ( $self->show_roles && defined $data->{roles} ) {
180                            foreach my $role ( keys %{ $data->{roles} } ) {
181                                    next if $filter && $self->filter_roles && $role !~ m{$filter};
182                                    warn "# $class\trole\t$role\n";
183                                    $g->add_edge( $role => $class, label => 'with', color => 'yellow' );
184                                    $g->add_node( $role, shape => 'diamond' );
185                                    $count->{$class}++;
186                                    $count->{$role}++;
187                            }
188                    }
189    
190                                          $g->add_edge( $class => $package, label => $type );                  if ( $self->show_extends && defined $data->{superclass} ) {
191                                  }                          foreach my $extends ( keys %{ $data->{superclass} } ) {
192                                    next if $filter && $self->filter_extends && $extends !~ m{$filter};
193                                    warn "# $class\textends\t$extends\n";
194                                    $g->add_edge( $extends => $class, label => 'extends', color => 'green' );
195                                    $count->{$class}++;
196                                    $count->{$extends}++;
197                          }                          }
198                  }                  }
199    
# Line 77  sub as_markup { Line 201  sub as_markup {
201    
202          warn "# count ",$self->dump( $count );          warn "# count ",$self->dump( $count );
203    
204          $self->store( 'var/classes.dot', $g->as_text );          my $max_count = 1;
205            foreach ( keys %$count ) {
206                    my $v = $count->{$_};
207                    $max_count = $v if $v > $max_count;
208            }
209            warn "# max_count: $max_count";
210    
211            foreach my $node ( keys %$count ) {
212                    my $v = $count->{$node};
213                    my $pcnt = $v / $max_count;
214                    my $color = join(",", ( $pcnt, $pcnt, 0.75 ) );
215    
216                    $g->add_node( $node,
217                            style =>'filled',
218                            color => $color,
219                            fillcolor => $color,
220    #                       label => "$node\n$v",
221                    );
222    
223            }
224    
225          if ( $self->produce_dot ) {          if ( $self->produce_dot ) {
226                  $self->content_type( 'text/plain' );                  $self->content_type( 'text/plain' );
227                    $self->store( 'var/classes.dot', $g->as_canon );
228                  return $g->as_canon;                  return $g->as_canon;
229          }          }
230    
# Line 89  sub as_markup { Line 233  sub as_markup {
233    
234  }  }
235    
236    __PACKAGE__->meta->make_immutable;
237    no Moose;
238    
239  1;  1;
Legend:
Removed from v.972  
changed lines
  Added in v.1137
  ViewVC Help
Powered by ViewVC 1.1.26