Frey/Class/Graph.pm

package Frey::Class::Graph;
use Moose;

extends 'Frey';
with 'Frey::Web', 'Frey::File', 'Frey::Storage';

use GraphViz;

has filter => (
        documentation => 'Regex to select classes',
        is => 'rw',
        isa => 'Str',
        required => 1,
        default => sub {
                '(' . join('|',  map { s{lib/}{}; $_ } sort grep { -d $_ } glob("lib/*") ) . ')'
        },
);


has filter_class => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_extends => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_includes => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has filter_roles => (
        is => 'rw',
        isa => 'Bool',
        default => 1,
);


has show_extends => (
        documentation => 'connect to superclasses',
        is => 'rw',
        isa => 'Bool',
);

has show_includes => (
        documentation => 'use and require connections',
        is => 'rw',
        isa => 'Bool',
        default => 1,
);

has show_roles => (
        documentation => 'roles consumers connections',
        is => 'rw',
        isa => 'Bool',
);

has show_disconnected => (
        is => 'ro',
        isa => 'Bool',
);


has layout => (
        documentation => 'layout algorithm',
        is => 'rw',
        isa => 'Str',
        required => 1,
);

sub layout_available { q/
dot             directed graph
neato   spring model
twopi   radial
circo   circular
fdp             force directed spring model
/ }

has portrait => (
        documentation => 'vertical layout',
        is => 'rw',
        isa => 'Bool',
);

has no_overlap => (
        documentation => 'avoid overlaping nodes',
        is => 'rw',
        isa => 'Bool',
);

has produce_dot => (
        documentation => 'dump .dot text format',
        is => 'rw',
        isa => 'Bool',
);

has clusters => (
        documentation => 'cluster by classes',
        is => 'rw',
        isa => 'Bool',
);

sub introspect_path { 'var/introspect/' };

sub as_markup {
        my ($self) = @_;

        my $rankdir = $self->portrait;

        my $g = GraphViz->new(
                rankdir => $rankdir,
                layout => $self->layout,
#               layout => 'neato', # grabs too much memory
#               layout => 'twopi', # grabs too much memory
#               overlap => 'compress',
                no_overlap => $self->no_overlap,

                node => {
                        shape => 'box',
                        style =>'filled',
                        color => 'grey',
                        fillcolor =>'lightgray',
                        fontname  => 'verdana',
                        fontsize  => '12',

                },
                edge => {
                        color => 'grey',
                        fontname  => 'verdana',
                        fontsize  => '8',
                        fontcolor => 'grey',
                }
        );

        my $count;
        my $filter = $self->filter;

        foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {

                my $class = $self->strip_path_extension( $path ) || die "can't strip $path";

                $count->{$class}++ if $self->show_disconnected;

                my $data = $self->load( $path );
#               warn "## $class $path ", $self->dump( $data ); # if $self->debug;

                next if $filter && $self->filter_class && $class !~ m{$filter};

                if ( $self->show_includes && defined $data->{includes} ) {

                        my $edge;

                        foreach my $type ( keys %{ $data->{includes} } ) {
                                foreach my $package ( @{ $data->{includes}->{$type} } ) {
                                        next if $filter && $self->filter_includes && $package !~ m{$filter};
                                        warn "# $class\t$type\t$package\n";
                                        my $e = "$class $package";
                                        if ( $edge->{$e} ) {
                                                $edge->{$e}->{style} = 'dashed';
                                                $edge->{$e}->{label} .= "\n$type";
                                        } else {
                                                $edge->{$e} = {
                                                        color => 'blue',
                                                        label => $type,
                                                };
                                        }
                                        $count->{$class}++;
                                        $count->{$package}++;
                                }
                        }

                        foreach my $e ( keys %$edge ) {
                                my ($c,$p) = split(/\s/, $e);
                                $g->add_edge( $c => $p, %{ $edge->{$e} } ) 
                        }

                }

                if ( $self->show_roles && defined $data->{roles} ) {
                        foreach my $role ( keys %{ $data->{roles} } ) {
                                next if $filter && $self->filter_roles && $role !~ m{$filter};
                                warn "# $class\trole\t$role\n";
                                $g->add_edge( $role => $class, label => 'with', color => 'yellow' );
                                $g->add_node( $role, shape => 'diamond' );
                                $count->{$class}++;
                                $count->{$role}++;
                        }
                }

                if ( $self->show_extends && defined $data->{superclass} ) {
                        foreach my $extends ( keys %{ $data->{superclass} } ) {
                                next if $filter && $self->filter_extends && $extends !~ m{$filter};
                                warn "# $class\textends\t$extends\n";
                                $g->add_edge( $extends => $class, label => 'extends', color => 'green' );
                                $count->{$class}++;
                                $count->{$extends}++;
                        }
                }

        }

        warn "# count ",$self->dump( $count );

        my $max_count = 1;
        foreach ( keys %$count ) {
                my $v = $count->{$_};
                $max_count = $v if $v > $max_count;
        }
        warn "# max_count: $max_count";

        foreach my $node ( keys %$count ) {
                my $v = $count->{$node};
                my $pcnt = $v / $max_count;
                my $color = join(",", ( $pcnt, $pcnt, 0.75 ) );

                my @cluster;
                if ( $self->clusters ) {
                        my $name = $1 if $node =~ m{^([^:]+)};
                        @cluster = ( 'cluster' => {
                                name => $name,
                                style => 'filled',
                                bgcolor => 'lightgrey',
                                color => 'lightgrey',
                        });
                }

                $g->add_node( $node, 
                        style =>'filled',
                        color => $color,
                        fillcolor => $color,
#                       label => "$node\n$v",
                        @cluster,
                );

        }

        if ( $self->produce_dot ) {
                $self->content_type( 'text/plain' );
                $self->store( 'var/classes.dot', $g->as_canon );
                return $g->as_canon;
        }

        $self->content_type( 'image/png' );
        return $g->as_png;

}

__PACKAGE__->meta->make_immutable;
no Moose;

1;
1	dpavlin	970	package Frey::Class::Graph;
2			use Moose;
3
4			extends 'Frey';
5	dpavlin	1133	with 'Frey::Web', 'Frey::File', 'Frey::Storage';
6	dpavlin	970
7			use GraphViz;
8
9	dpavlin	972	has filter => (
10			documentation => 'Regex to select classes',
11	dpavlin	970	is => 'rw',
12			isa => 'Str',
13	dpavlin	977	required => 1,
14	dpavlin	982	default => sub {
15			'(' . join('\|', map { s{lib/}{}; $_ } sort grep { -d $_ } glob("lib/*") ) . ')'
16			},
17	dpavlin	972	);
18
19	dpavlin	982
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	dpavlin	977	has show_extends => (
46			documentation => 'connect to superclasses',
47	dpavlin	972	is => 'rw',
48	dpavlin	977	isa => 'Bool',
49	dpavlin	970	);
50
51	dpavlin	977	has show_includes => (
52			documentation => 'use and require connections',
53			is => 'rw',
54			isa => 'Bool',
55			default => 1,
56			);
57
58			has show_roles => (
59			documentation => 'roles consumers connections',
60			is => 'rw',
61			isa => 'Bool',
62			);
63
64	dpavlin	981	has show_disconnected => (
65			is => 'ro',
66			isa => 'Bool',
67			);
68
69	dpavlin	982
70	dpavlin	1079	has layout => (
71			documentation => 'layout algorithm',
72			is => 'rw',
73			isa => 'Str',
74			required => 1,
75			);
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	dpavlin	977	has portrait => (
86			documentation => 'vertical layout',
87			is => 'rw',
88			isa => 'Bool',
89			);
90
91	dpavlin	1080	has no_overlap => (
92			documentation => 'avoid overlaping nodes',
93			is => 'rw',
94			isa => 'Bool',
95			);
96
97	dpavlin	972	has produce_dot => (
98	dpavlin	977	documentation => 'dump .dot text format',
99	dpavlin	972	is => 'rw',
100			isa => 'Bool',
101			);
102
103	dpavlin	1156	has clusters => (
104			documentation => 'cluster by classes',
105			is => 'rw',
106			isa => 'Bool',
107			);
108
109	dpavlin	977	sub introspect_path { 'var/introspect/' };
110
111	dpavlin	970	sub as_markup {
112			my ($self) = @_;
113
114	dpavlin	977	my $rankdir = $self->portrait;
115
116	dpavlin	972	my $g = GraphViz->new(
117	dpavlin	977	rankdir => $rankdir,
118	dpavlin	1079	layout => $self->layout,
119	dpavlin	972	# layout => 'neato', # grabs too much memory
120			# layout => 'twopi', # grabs too much memory
121			# overlap => 'compress',
122	dpavlin	1080	no_overlap => $self->no_overlap,
123	dpavlin	981
124	dpavlin	977	node => {
125			shape => 'box',
126	dpavlin	981	style =>'filled',
127			color => 'grey',
128			fillcolor =>'lightgray',
129			fontname => 'verdana',
130			fontsize => '12',
131
132	dpavlin	977	},
133			edge => {
134			color => 'grey',
135	dpavlin	981	fontname => 'verdana',
136			fontsize => '8',
137			fontcolor => 'grey',
138	dpavlin	977	}
139	dpavlin	972	);
140	dpavlin	970
141	dpavlin	981	my $count;
142	dpavlin	972	my $filter = $self->filter;
143	dpavlin	970
144	dpavlin	977	foreach my $path ( $self->dir_extension( $self->introspect_path, qr{\.(ya?ml)$}) ) {
145	dpavlin	970
146	dpavlin	972	my $class = $self->strip_path_extension( $path ) \|\| die "can't strip $path";
147	dpavlin	977
148	dpavlin	981	$count->{$class}++ if $self->show_disconnected;
149
150	dpavlin	972	my $data = $self->load( $path );
151			# warn "## $class $path ", $self->dump( $data ); # if $self->debug;
152
153	dpavlin	982	next if $filter && $self->filter_class && $class !~ m{$filter};
154	dpavlin	972
155	dpavlin	977	if ( $self->show_includes && defined $data->{includes} ) {
156	dpavlin	1137
157			my $edge;
158
159	dpavlin	977	foreach my $type ( keys %{ $data->{includes} } ) {
160			foreach my $package ( @{ $data->{includes}->{$type} } ) {
161	dpavlin	982	next if $filter && $self->filter_includes && $package !~ m{$filter};
162	dpavlin	977	warn "# $class\t$type\t$package\n";
163	dpavlin	1137	my $e = "$class $package";
164			if ( $edge->{$e} ) {
165			$edge->{$e}->{style} = 'dashed';
166			$edge->{$e}->{label} .= "\n$type";
167			} else {
168			$edge->{$e} = {
169			color => 'blue',
170			label => $type,
171			};
172			}
173	dpavlin	981	$count->{$class}++;
174			$count->{$package}++;
175	dpavlin	972	}
176			}
177	dpavlin	1137
178			foreach my $e ( keys %$edge ) {
179			my ($c,$p) = split(/\s/, $e);
180			$g->add_edge( $c => $p, %{ $edge->{$e} } )
181			}
182
183	dpavlin	972	}
184
185	dpavlin	977	if ( $self->show_roles && defined $data->{roles} ) {
186			foreach my $role ( keys %{ $data->{roles} } ) {
187	dpavlin	982	next if $filter && $self->filter_roles && $role !~ m{$filter};
188	dpavlin	977	warn "# $class\trole\t$role\n";
189	dpavlin	1099	$g->add_edge( $role => $class, label => 'with', color => 'yellow' );
190			$g->add_node( $role, shape => 'diamond' );
191	dpavlin	981	$count->{$class}++;
192			$count->{$role}++;
193	dpavlin	977	}
194			}
195	dpavlin	974
196	dpavlin	977	if ( $self->show_extends && defined $data->{superclass} ) {
197			foreach my $extends ( keys %{ $data->{superclass} } ) {
198	dpavlin	982	next if $filter && $self->filter_extends && $extends !~ m{$filter};
199	dpavlin	977	warn "# $class\textends\t$extends\n";
200			$g->add_edge( $extends => $class, label => 'extends', color => 'green' );
201	dpavlin	981	$count->{$class}++;
202			$count->{$extends}++;
203	dpavlin	977	}
204	dpavlin	974	}
205
206	dpavlin	972	}
207
208			warn "# count ",$self->dump( $count );
209
210	dpavlin	981	my $max_count = 1;
211			foreach ( keys %$count ) {
212			my $v = $count->{$_};
213			$max_count = $v if $v > $max_count;
214			}
215			warn "# max_count: $max_count";
216
217	dpavlin	977	foreach my $node ( keys %$count ) {
218	dpavlin	981	my $v = $count->{$node};
219			my $pcnt = $v / $max_count;
220			my $color = join(",", ( $pcnt, $pcnt, 0.75 ) );
221	dpavlin	972
222	dpavlin	1156	my @cluster;
223			if ( $self->clusters ) {
224			my $name = $1 if $node =~ m{^([^:]+)};
225			@cluster = ( 'cluster' => {
226			name => $name,
227			style => 'filled',
228			bgcolor => 'lightgrey',
229			color => 'lightgrey',
230			});
231			}
232
233	dpavlin	977	$g->add_node( $node,
234			style =>'filled',
235			color => $color,
236			fillcolor => $color,
237	dpavlin	981	# label => "$node\n$v",
238	dpavlin	1156	@cluster,
239	dpavlin	977	);
240
241			}
242
243	dpavlin	972	if ( $self->produce_dot ) {
244			$self->content_type( 'text/plain' );
245	dpavlin	974	$self->store( 'var/classes.dot', $g->as_canon );
246	dpavlin	972	return $g->as_canon;
247			}
248
249	dpavlin	970	$self->content_type( 'image/png' );
250			return $g->as_png;
251	dpavlin	972
252	dpavlin	970	}
253
254	dpavlin	1133	__PACKAGE__->meta->make_immutable;
255			no Moose;
256
257	dpavlin	970	1;