File Coverage

blib/lib/App/PerlPackage2PlantUMLClassDiagram/Package.pm
Criterion Covered Total %
statement 81 82 98.7
branch 25 36 69.4
condition 8 10 80.0
subroutine 18 18 100.0
pod 0 10 0.0
total 132 156 84.6


line stmt bran cond sub pod time code
1             package App::PerlPackage2PlantUMLClassDiagram::Package;
2 3     3   25559 use 5.014;
  3         9  
3 3     3   15 use strict;
  3         7  
  3         125  
4 3     3   14 use warnings;
  3         6  
  3         92  
5              
6 3     3   2555 use PPI::Document;
  3         464653  
  3         175  
7 3     3   2283 use Text::MicroTemplate::DataSection 'render_mt';
  3         70546  
  3         3210  
8              
9             sub new {
10 13     13 0 19853 my ($class, $source) = @_;
11              
12 13 100       337 unless (-f $source) {
13 1         11 die "file not exist: $source";
14             }
15              
16             bless {
17 12         59 source => $source,
18             }, $class;
19             }
20              
21             sub source {
22 13     13 0 390 my ($self) = @_;
23              
24 13         75 $self->{source};
25             }
26              
27             sub document {
28 44     44 0 64 my ($self) = @_;
29              
30 44   66     274 $self->{document} ||= PPI::Document->new($self->source);
31             }
32              
33             sub package_name {
34 13     13 0 11874 my ($self) = @_;
35              
36 13         34 my $package = $self->document->find_first('PPI::Statement::Package');
37 13 100       32295 return unless $package;
38 12         52 $package->namespace;
39             }
40              
41             sub parent_packages {
42 7     7 0 14 my ($self) = @_;
43              
44 7   100     21 my $includes = $self->document->find('PPI::Statement::Include') || [];
45 7 50       19759 return [] unless $includes;
46              
47 7         14 my $parent_packages = [];
48              
49             # see also: App::PRT::Command::RenameClass
50 7         19 for my $statement (@$includes) {
51 2 50       14 next unless defined $statement->pragma;
52 2 50       94 next unless $statement->pragma =~ /^parent|base$/; # only 'use parent' and 'use base' are supported
53              
54             # schild(2) is 'Foo' of use parent Foo
55 2         66 my $parent = $statement->schild(2);
56              
57 2 50       60 if ($parent->isa('PPI::Token::Quote')) {
    50          
58             # The 'literal' method is not implemented by ::Quote::Double or ::Quote::Interpolate.
59 0 0       0 push @$parent_packages, $parent->can('literal') ? $parent->literal : $parent->string;
60             } elsif ($parent->isa('PPI::Token::QuoteLike::Words')) {
61             # use parent qw(A B C) pattern
62             # literal is array when QuoteLike::Words
63 2         13 push @$parent_packages, $parent->literal;
64             }
65             }
66              
67 7         40 $parent_packages;
68             }
69              
70             sub _methods {
71 23     23   37 my ($self) = @_;
72              
73 23 100       54 $self->document->find('PPI::Statement::Sub') || [];
74             }
75              
76             sub _arguments ($) {
77 64     64   100 my ($sub) = @_;
78              
79 64         173 my $variable = $sub->find_first('PPI::Statement::Variable');
80 64 100       25107 return () unless $variable;
81              
82 62         164 my $list = $variable->find_first('PPI::Structure::List');
83 62 50       14665 return () unless $list;
84              
85 62   50     167 my $symbols = $list->find('PPI::Token::Symbol') || [];
86 62 50       14643 return () unless @$symbols;
87 62 100 100     197 my $receiver = shift @$symbols if $symbols->[0]->content eq '$self' || $symbols->[0]->content eq '$class';
88 62         583 ($receiver, @$symbols);
89             }
90              
91             sub _method_signature ($) {
92 18     18   32 my ($sub) = @_;
93              
94 18         34 my (undef, @arguments) = _arguments($sub);
95              
96 18         29 "@{[ $sub->name ]}(@{[ join ', ', @arguments ]})";
  18         58  
  18         565  
97             }
98              
99             sub static_methods {
100 6     6 0 515 my ($self) = @_;
101 5         89 [ map { _method_signature $_ } grep {
102 14         14862 my ($receiver) = _arguments $_;
103 14 50       84 $receiver && $receiver eq '$class';
104 6         11 } @{$self->_methods} ];
  6         21  
105             }
106              
107             sub public_methods {
108 10     10 0 648 my ($self) = @_;
109              
110 10         266 [ map { _method_signature $_ } grep { index($_->name, '_') != 0 } grep {
  13         250  
111 18         34587 my ($receiver) = _arguments $_;
112 18 100       98 !$receiver || $receiver eq '$self';
113 10         19 } @{$self->_methods} ];
  10         24  
114             }
115              
116             sub private_methods {
117 6     6 0 40 my ($self) = @_;
118              
119 3         73 [ map { _method_signature $_ } grep { index($_->name, '_') == 0 } grep {
  9         191  
120 14         14757 my ($receiver) = _arguments $_;
121 14 50       78 !$receiver || $receiver eq '$self';
122 6         10 } @{$self->_methods} ];
  6         15  
123             }
124              
125             sub to_class_syntax {
126 6     6 0 15 my ($self) = @_;
127              
128 6         22 my $package_name = $self->package_name;
129              
130 6 100       163 return '' unless $package_name;
131              
132 5         20 render_mt('class_syntax', {
133             package_name => $self->package_name,
134             static_methods => $self->static_methods,
135             public_methods => $self->public_methods,
136             private_methods => $self->private_methods,
137             });
138             }
139              
140             sub to_inherit_syntax {
141 6     6 0 16 my ($self) = @_;
142              
143 6         22 my $parent_packages = $self->parent_packages;
144              
145 6 100       34 return '' unless @$parent_packages;
146              
147 1         4 render_mt('inherit_syntax', {
148             package_name => $self->package_name,
149             parent_packages => $parent_packages,
150             });
151             }
152              
153             1;
154             __DATA__