/[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 970 by dpavlin, Fri Jan 9 16:21:26 2009 UTC revision 981 by dpavlin, Sat Jan 10 01:03:28 2009 UTC
# Line 3  use Moose; Line 3  use Moose;
3    
4  extends 'Frey';  extends 'Frey';
5  with 'Frey::Web';  with 'Frey::Web';
6  #with 'Frey::Storage';  with 'Frey::File';
7    with 'Frey::Storage';
8    
9  use GraphViz;  use GraphViz;
10    
11  has skeleton => (  has filter => (
12            documentation => 'Regex to select classes',
13          is => 'rw',          is => 'rw',
14          isa => 'Str',          isa => 'Str',
15          required => 1,          required => 1,
16          default => 'skeleton',          default => 'Frey',
17  );  );
18    
19    has show_extends => (
20            documentation => 'connect to superclasses',
21            is => 'rw',
22            isa => 'Bool',
23    );
24    
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 show_disconnected => (
39            is => 'ro',
40            isa => 'Bool',
41    );
42    
43    has portrait => (
44            documentation => 'vertical layout',
45            is => 'rw',
46            isa => 'Bool',
47    );
48    
49    has produce_dot => (
50            documentation => 'dump .dot text format',
51            is => 'rw',
52            isa => 'Bool',
53    );
54    
55    sub introspect_path { 'var/introspect/' };
56    
57  sub as_markup {  sub as_markup {
58          my ($self) = @_;          my ($self) = @_;
59    
60          my $g = GraphViz->new();          my $rankdir = $self->portrait;
61    
62          $g->add_node( 'foo' );          my $g = GraphViz->new(
63          $g->add_node( 'bar' );                  rankdir => $rankdir,
64    #               layout => 'neato', # grabs too much memory
65          $g->add_edge( 'foo' => 'bar' );  #               layout => 'twopi', # grabs too much memory
66    #               overlap => 'compress',
67    #               no_overlap => 1,
68    
69                    node => {
70                            shape => 'box',
71                            style =>'filled',
72                            color => 'grey',
73                            fillcolor =>'lightgray',
74                            fontname  => 'verdana',
75                            fontsize  => '12',
76    
77                    },
78                    edge => {
79                            color => 'grey',
80                            fontname  => 'verdana',
81                            fontsize  => '8',
82                            fontcolor => 'grey',
83                    }
84            );
85    
86            my $count;
87            my $filter = $self->filter;
88    
89            foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
90    
91                    my $class = $self->strip_path_extension( $path ) || die "can't strip $path";
92    
93                    $count->{$class}++ if $self->show_disconnected;
94    
95                    my $data = $self->load( $path );
96    #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;
97    
98                    next if $filter && $class !~ m{$filter};
99    
100                    if ( $self->show_includes && defined $data->{includes} ) {
101                            foreach my $type ( keys %{ $data->{includes} } ) {
102                                    foreach my $package ( @{ $data->{includes}->{$type} } ) {
103                                            next if $filter && $package !~ m{$filter};
104                                            warn "# $class\t$type\t$package\n";
105                                            $g->add_edge( $class => $package, label => $type, color => 'blue' );
106                                            $count->{$class}++;
107                                            $count->{$package}++;
108                                    }
109                            }
110                    }
111    
112                    if ( $self->show_roles && defined $data->{roles} ) {
113                            foreach my $role ( keys %{ $data->{roles} } ) {
114                                    next if $filter && $role !~ m{$filter};
115                                    warn "# $class\trole\t$role\n";
116                                    $g->add_edge( $role => $class, label => 'role', color => 'yellow' );
117    #                               $g->add_node( $role, rank => 'role' );
118                                    $count->{$class}++;
119                                    $count->{$role}++;
120                            }
121                    }
122    
123                    if ( $self->show_extends && defined $data->{superclass} ) {
124                            foreach my $extends ( keys %{ $data->{superclass} } ) {
125                                    next if $filter && $extends !~ m{$filter};
126                                    warn "# $class\textends\t$extends\n";
127                                    $g->add_edge( $extends => $class, label => 'extends', color => 'green' );
128                                    $count->{$class}++;
129                                    $count->{$extends}++;
130                            }
131                    }
132    
133            }
134    
135            warn "# count ",$self->dump( $count );
136    
137            my $max_count = 1;
138            foreach ( keys %$count ) {
139                    my $v = $count->{$_};
140                    $max_count = $v if $v > $max_count;
141            }
142            warn "# max_count: $max_count";
143    
144            foreach my $node ( keys %$count ) {
145                    my $v = $count->{$node};
146                    my $pcnt = $v / $max_count;
147                    my $color = join(",", ( $pcnt, $pcnt, 0.75 ) );
148    
149                    $g->add_node( $node,
150                            style =>'filled',
151                            color => $color,
152                            fillcolor => $color,
153    #                       label => "$node\n$v",
154                    );
155    
156            }
157    
158            if ( $self->produce_dot ) {
159                    $self->content_type( 'text/plain' );
160                    $self->store( 'var/classes.dot', $g->as_canon );
161                    return $g->as_canon;
162            }
163    
164          $self->content_type( 'image/png' );          $self->content_type( 'image/png' );
165          return $g->as_png;          return $g->as_png;
166    
167  }  }
168    
169  1;  1;
Legend:
Removed from v.970  
changed lines
  Added in v.981
  ViewVC Help
Powered by ViewVC 1.1.26