File Coverage

blib/lib/assign/0.pm
Criterion Covered Total %
statement 88 92 95.6
branch 16 22 72.7
condition 34 42 80.9
subroutine 20 20 100.0
pod 0 11 0.0
total 158 187 84.4


line stmt bran cond sub pod time code
1 5     5   35 use strict; use warnings;
  5     5   10  
  5         144  
  5         23  
  5         9  
  5         259  
2             package assign::0;
3              
4             our $VERSION = '0.0.15';
5              
6 5     5   2112 use assign::Array;
  5         1883  
  5         146  
7 5     5   1905 use assign::Hash;
  5         15  
  5         135  
8              
9 5     5   2804 use Filter::Simple;
  5         113747  
  5         31  
10 5     5   3080 use PPI;
  5         570489  
  5         232  
11 5     5   50 use XXX;
  5         10  
  5         37  
12              
13             our $var_prefix = '___';
14             our $var_id = 1000;
15             our $var_suffix = '';
16              
17             sub new {
18 22     22 0 48 my $class = shift;
19 22         74 my $self = bless { @_ }, $class;
20             my $code = $self->{code}
21 22 50       129 or die "$class\->new requires 'code' string";
22 22   100     114 $self->{line} //= 0;
23 22         171 $self->{doc} = PPI::Document->new(\$code);
24 22         321459 $self->{doc}->index_locations;
25 22         70798 return $self;
26             }
27              
28             # FILTER_ONLY code_no_comments => \&filter;
29             FILTER_ONLY all => \&filter;
30              
31             sub filter {
32 6     6 0 4401 my ($class) = @_;
33 6         86 $_ = $class->new(
34             code => $_,
35             line => ([caller(4)])->[2],
36             )->transform();
37             };
38              
39             sub debug {
40 1     1 0 123 my ($class, $code) = @_;
41 1 50       9 if (ref($code) eq 'SCALAR') {
    50          
42 0         0 $code = $$code;
43             } elsif (not ref($code)) {
44 1 50       31 if (not -f $code) {
45 0         0 XXX $code;
46 0         0 die "Argument to $class\->debug() is not a valid file.\n" .
47             "Code strings need to be passed as scalar refs.";
48             }
49 1 50       44 open my $fh, $code or die "Can't open '$code' for input";
50 1         6 $code = do { local $/; <$fh> };
  1         7  
  1         48  
51             } else {
52 0         0 die "Invalid arguments for $class->debug(...)";
53             }
54 1         12 $class->new(code => $code)->transform;
55             }
56              
57             sub transform {
58 22     22 0 93 my ($self) = @_;
59              
60             # Call the various possible assignment transformations:
61 22         93 $self->transform_assignment_statements_with_decl;
62 22         127 $self->transform_assignment_statements_no_decl;
63             # ... more to come ...
64              
65 22         99 $self->{doc}->serialize;
66             }
67              
68             sub transform_assignment_statements_with_decl {
69 22     22 0 48 my ($self) = @_;
70              
71 22         59 for my $node ($self->find_assignment_statements_with_decl) {
72 22         59 my ($decl, $lhs, $oper, @rhs) = $node->schildren;
73 22         418 my $rhs = join '', map $_->content, @rhs;
74 22         485 $self->transform_assignment_statement(
75             $node, $decl, $lhs, $oper, $rhs,
76             );
77             }
78             }
79              
80             sub transform_assignment_statements_no_decl {
81 22     22 0 3142 my ($self) = @_;
82              
83 22         65 for my $node ($self->find_assignment_statements_no_decl) {
84 2         7 my $decl = '';
85 2         8 my ($lhs, $oper, @rhs) = $node->schildren;
86 2         34 my $rhs = join '', map $_->content, @rhs;
87 2         21 $self->transform_assignment_statement(
88             $node, $decl, $lhs, $oper, $rhs,
89             );
90             }
91             }
92              
93             sub find_assignment_statements_with_decl {
94 22     22 0 47 my ($self) = @_;
95              
96 22   100     342 map { $_ ||= []; @$_ }
  22         114  
97             $self->{doc}->find(sub {
98 2737     2737   29956 my $n = $_[1];
99             return 0 unless
100             $n->isa('PPI::Statement::Variable') and
101 2737 100 100     8602 @{[$n->schildren]} >= 5 and
  61   66     151  
      66        
      100        
      66        
      66        
      66        
102             $n->schild(0)->isa('PPI::Token::Word') and
103             $n->schild(0)->content =~ /^(my|our|local)$/ and
104             (
105             $n->schild(1)->isa('PPI::Structure::Constructor') or
106             $n->schild(1)->isa('PPI::Structure::Block')
107             ) and
108             # or PPI::Structure::Block
109             $n->schild(2)->isa('PPI::Token::Operator') and
110             $n->schild(2)->content eq '=';
111 22         216 });
112             }
113              
114             sub find_assignment_statements_no_decl {
115 22     22 0 43 my ($self) = @_;
116              
117 22   100     325 map { $_ ||= []; @$_ }
  22         152  
118             $self->{doc}->find(sub {
119 3612     3612   38260 my $n = $_[1];
120             return 0 unless
121             ref($n) eq 'PPI::Statement' and
122 3612 100 100     9204 @{[$n->schildren]} >= 4 and
  137   66     317  
      100        
      66        
      66        
123             (
124             $n->schild(0)->isa('PPI::Structure::Constructor') or
125             $n->schild(0)->isa('PPI::Structure::Block')
126             ) and
127             $n->schild(1)->isa('PPI::Token::Operator') and
128             $n->schild(1)->content eq '=';
129 22         163 });
130             }
131              
132             sub transform_assignment_statement {
133 24     24 0 87 my ($self, $node, $decl, $lhs, $oper, $rhs) = @_;
134              
135 24 100       115 $decl = $decl ? $decl->{content} . ' ' : '';
136 24         51 $oper = $oper->{content};
137              
138 24 50       56 my $class =
    100          
139             $lhs->start->content eq '[' ? 'assign::Array' :
140             $lhs->start->content eq '{' ? 'assign::Hash' :
141             ZZZ $node, "Unsupported statement";
142              
143 24         197 my $from;
144 24         110 my $init = [];
145 24 100       144 if ($rhs =~ /^(\$\w+);/) {
146 16         56 $from = $1;
147             } else {
148 8         37 $from = $self->gen_var;
149 8         57 push @$init, "my $from = $rhs";
150             }
151              
152 24         156 my $code = $class->new(
153             node => $lhs,
154             )->parse->gen_code($decl, $oper, $from, $init);
155              
156 24         204 $self->replace_statement_node($node, $code);
157              
158 24         108 return;
159             }
160              
161             sub gen_var {
162 8     8 0 20 $var_id++;
163 8         36 return "\$$var_prefix$var_id$var_suffix";
164             }
165              
166             sub replace_statement_node {
167 24     24 0 59 my ($self, $node, $code) = @_;
168 24         116 my $line_number = $node->last_token->logical_line_number + $self->{line};
169             $node->insert_after($_->remove)
170 24         873 for reverse PPI::Document->new(\"\n#line $line_number")->elements;
171             $node->insert_after($_->remove)
172 24         15021 for reverse PPI::Document->new(\$code)->elements;
173 24         165954 $node->remove;
174 24         1491 return;
175             }
176              
177             1;