/[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 976 by dpavlin, Fri Jan 9 19:48:30 2009 UTC revision 977 by dpavlin, Fri Jan 9 23:02:36 2009 UTC
# Line 12  has filter => ( Line 12  has filter => (
12          documentation => 'Regex to select classes',          documentation => 'Regex to select classes',
13          is => 'rw',          is => 'rw',
14          isa => 'Str',          isa => 'Str',
15            required => 1,
16          default => 'Frey',          default => 'Frey',
17  );  );
18    
19  has path => (  has show_extends => (
20            documentation => 'connect to superclasses',
21          is => 'rw',          is => 'rw',
22          isa => 'Str',          isa => 'Bool',
23          required => 1,  );
24          default => 'var/introspect/',  
25    has show_includes => (
26            documentation => 'use and require connections',
27            is => 'rw',
28            isa => 'Bool',
29            default => 1,
30    );
31    
32    has show_roles => (
33            documentation => 'roles consumers connections',
34            is => 'rw',
35            isa => 'Bool',
36    );
37    
38    has portrait => (
39            documentation => 'vertical layout',
40            is => 'rw',
41            isa => 'Bool',
42  );  );
43    
44  has produce_dot => (  has produce_dot => (
45            documentation => 'dump .dot text format',
46          is => 'rw',          is => 'rw',
47          isa => 'Bool',          isa => 'Bool',
48  );  );
49    
50    sub introspect_path { 'var/introspect/' };
51    
52  sub as_markup {  sub as_markup {
53          my ($self) = @_;          my ($self) = @_;
54    
55            my $rankdir = $self->portrait;
56    
57          my $g = GraphViz->new(          my $g = GraphViz->new(
58                  rankdir => 1, # horizontal                  rankdir => $rankdir,
59  #               layout => 'neato', # grabs too much memory  #               layout => 'neato', # grabs too much memory
60  #               layout => 'twopi', # grabs too much memory  #               layout => 'twopi', # grabs too much memory
61  #               overlap => 'compress',  #               overlap => 'compress',
62  #               no_overlap => 1,  #               no_overlap => 1,
63                    node => {
64                            shape => 'box',
65    #                       style =>'filled',
66    #                       color => 'grey',
67    #                       fillcolor =>'lightgray',
68                    },
69                    edge => {
70                            color => 'grey',
71                    }
72          );          );
73    
74          our $count = {};          our $count = {};
75            our $max_count = {};
76          my $filter = $self->filter;          my $filter = $self->filter;
77    
78          foreach my $path ( $self->dir_extension( $self->path, qr{\.(ya?ml)$}) ) {          foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
79    
80                  my $class = $self->strip_path_extension( $path ) || die "can't strip $path";                  my $class = $self->strip_path_extension( $path ) || die "can't strip $path";
81                    $max_count->{$class} = ++$count->{$class};
82    
83                  my $data = $self->load( $path );                  my $data = $self->load( $path );
84  #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;  #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;
85    
                 sub count_label {  
                         my ($self,$package) = @_;  
                         my $label = $package;  
                         $label .= $self->dump( $count->{$package} );  
                         return $label;  
                 }  
   
86                  next if $filter && $class !~ m{$filter};                  next if $filter && $class !~ m{$filter};
87    
88                  if ( my $includes = $data->{includes} ) {                  if ( $self->show_includes && defined $data->{includes} ) {
89                          foreach my $type ( keys %$includes ) {                          foreach my $type ( keys %{ $data->{includes} } ) {
90                                  foreach my $package ( @{ $includes->{$type} } ) {                                  foreach my $package ( @{ $data->{includes}->{$type} } ) {
   
                                         my $usage = $count->{$package}->{$type}->{$class}++;  
   
                                         my $label = $self->count_label($package);  
   
91                                          next if $filter && $package !~ m{$filter};                                          next if $filter && $package !~ m{$filter};
92                                            warn "# $class\t$type\t$package\n";
93                                          warn "# $class\t$type\t$package\n$label\n";                                          $g->add_edge( $class => $package, label => $type, color => 'blue' );
94                                            $max_count->{$package} = ++$count->{$package};
                                         $g->add_edge( $class => $package, label => $type );  
95                                  }                                  }
96                          }                          }
97                  }                  }
98    
99  =for later                  if ( $self->show_roles && defined $data->{roles} ) {
100                            foreach my $role ( keys %{ $data->{roles} } ) {
101                  foreach my $role ( keys %{ $data->{roles} } ) {                                  next if $filter && $role !~ m{$filter};
102                          next if $filter && $role !~ m{$filter};                                  warn "# $class\trole\t$role\n";
103                          $g->add_edge( $role => $class, label => 'role' );                                  $g->add_edge( $role => $class, label => 'role', color => 'yellow' );
104    #                               $g->add_node( $role, rank => 'role' );
105                                    $max_count->{$role} = ++$count->{$role};
106                            }
107                  }                  }
108    
109  =cut                  if ( $self->show_extends && defined $data->{superclass} ) {
110                            foreach my $extends ( keys %{ $data->{superclass} } ) {
111                                    next if $filter && $extends !~ m{$filter};
112                                    warn "# $class\textends\t$extends\n";
113                                    $g->add_edge( $extends => $class, label => 'extends', color => 'green' );
114                                    $max_count->{$extends} = ++$count->{$extends};
115                            }
116                    }
117    
118          }          }
119    
120    =for xxx
121          warn "# count ",$self->dump( $count );          warn "# count ",$self->dump( $count );
122    
123            foreach my $node ( keys %$count ) {
124                    my $pcnt = $count->{$node} / $max_count->{$node};
125                    my $color = join(",", ( $pcnt, 0.5, 0.75 ) );
126    
127                    $g->add_node( $node,
128                            style =>'filled',
129                            color => $color,
130                            fillcolor => $color,
131                            label => "$node\n$pcnt",
132                    );
133    
134            }
135    =cut
136    
137          if ( $self->produce_dot ) {          if ( $self->produce_dot ) {
138                  $self->content_type( 'text/plain' );                  $self->content_type( 'text/plain' );
Legend:
Removed from v.976  
changed lines
  Added in v.977
  ViewVC Help
Powered by ViewVC 1.1.26