/[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 974 by dpavlin, Fri Jan 9 19:48:30 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',
14            isa => 'Str',
15            default => 'Frey',
16    );
17    
18    has path => (
19          is => 'rw',          is => 'rw',
20          isa => 'Str',          isa => 'Str',
21          required => 1,          required => 1,
22          default => 'skeleton',          default => 'var/introspect/',
23    );
24    
25    has produce_dot => (
26            is => 'rw',
27            isa => 'Bool',
28  );  );
29    
30  sub as_markup {  sub as_markup {
31          my ($self) = @_;          my ($self) = @_;
32    
33          my $g = GraphViz->new();          my $g = GraphViz->new(
34                    rankdir => 1, # horizontal
35    #               layout => 'neato', # grabs too much memory
36    #               layout => 'twopi', # grabs too much memory
37    #               overlap => 'compress',
38    #               no_overlap => 1,
39            );
40    
41            our $count = {};
42            my $filter = $self->filter;
43    
44            foreach my $path ( $self->dir_extension( $self->path, qr{\.(ya?ml)$}) ) {
45    
46                    my $class = $self->strip_path_extension( $path ) || die "can't strip $path";
47                    my $data = $self->load( $path );
48    #               warn "## $class $path ", $self->dump( $data ); # if $self->debug;
49    
50                    sub count_label {
51                            my ($self,$package) = @_;
52                            my $label = $package;
53                            $label .= $self->dump( $count->{$package} );
54                            return $label;
55                    }
56    
57                    next if $filter && $class !~ m{$filter};
58    
59          $g->add_node( 'foo' );                  if ( my $includes = $data->{includes} ) {
60          $g->add_node( 'bar' );                          foreach my $type ( keys %$includes ) {
61                                    foreach my $package ( @{ $includes->{$type} } ) {
62    
63          $g->add_edge( 'foo' => 'bar' );                                          my $usage = $count->{$package}->{$type}->{$class}++;
64    
65                                            my $label = $self->count_label($package);
66    
67                                            next if $filter && $package !~ m{$filter};
68    
69                                            warn "# $class\t$type\t$package\n$label\n";
70    
71                                            $g->add_edge( $class => $package, label => $type );
72                                    }
73                            }
74                    }
75    
76    =for later
77    
78                    foreach my $role ( keys %{ $data->{roles} } ) {
79                            next if $filter && $role !~ m{$filter};
80                            $g->add_edge( $role => $class, label => 'role' );
81                    }
82    
83    =cut
84    
85            }
86    
87            warn "# count ",$self->dump( $count );
88    
89    
90            if ( $self->produce_dot ) {
91                    $self->content_type( 'text/plain' );
92                    $self->store( 'var/classes.dot', $g->as_canon );
93                    return $g->as_canon;
94            }
95    
96          $self->content_type( 'image/png' );          $self->content_type( 'image/png' );
97          return $g->as_png;          return $g->as_png;
98    
99  }  }
100    
101  1;  1;
Legend:
Removed from v.970  
changed lines
  Added in v.974
  ViewVC Help
Powered by ViewVC 1.1.26