File Coverage

blib/lib/Devel/Chitin/OpTree/UNOP_AUX.pm
Criterion Covered Total %
statement 32 79 40.5
branch 14 48 29.1
condition 15 23 65.2
subroutine 4 5 80.0
pod 0 2 0.0
total 65 157 41.4


line stmt bran cond sub pod time code
1             package Devel::Chitin::OpTree::UNOP_AUX;
2 35     35   195 use base 'Devel::Chitin::OpTree::UNOP';
  35         61  
  35         3404  
3              
4             our $VERSION = '0.12'; # TRIAL
5              
6 35     35   181 use strict;
  35         55  
  35         603  
7 35     35   140 use warnings;
  35         80  
  35         26855  
8              
9             my @open_bracket = qw( [ { );
10             my @close_bracket = qw( ] } );
11              
12             my %hash_actions = map { $_ => 1 }
13             ( B::MDEREF_HV_pop_rv2hv_helem, B::MDEREF_HV_gvsv_vivify_rv2hv_helem,
14             B::MDEREF_HV_padsv_vivify_rv2hv_helem, B::MDEREF_HV_vivify_rv2hv_helem,
15             B::MDEREF_HV_padhv_helem, B::MDEREF_HV_gvhv_helem );
16             sub pp_multideref {
17 13     13 0 23 my $self = shift;
18              
19 13         28 my @aux_list = $self->op->aux_list($self->cv);
20              
21 13         26 my $deparsed = '';
22 13         35 while(@aux_list) {
23 13         26 my $aux = shift @aux_list;
24 13         32 while (($aux & B::MDEREF_ACTION_MASK) != B::MDEREF_reload) {
25              
26 22         39 my $action = $aux & B::MDEREF_ACTION_MASK;
27 22   100     56 my $is_hash = $hash_actions{$action} || 0;
28              
29 22 100 100     153 if ($action == B::MDEREF_AV_padav_aelem
    100 100        
    100 66        
    100 100        
    50 66        
30             or $action == B::MDEREF_HV_padhv_helem
31             ) {
32 5         20 $deparsed .= '$' . substr( $self->_padname_sv( shift @aux_list )->PVX, 1);
33              
34             } elsif ($action == B::MDEREF_HV_gvhv_helem
35             or $action == B::MDEREF_AV_gvav_aelem
36             ) {
37 2         11 $deparsed .= '$' . $self->_gv_name(shift @aux_list);
38              
39             } elsif ($action == B::MDEREF_HV_padsv_vivify_rv2hv_helem
40             or $action == B::MDEREF_AV_padsv_vivify_rv2av_aelem
41             ) {
42 3         8 $deparsed .= $self->_padname_sv( shift @aux_list )->PVX . '->';
43              
44             } elsif ($action == B::MDEREF_HV_gvsv_vivify_rv2hv_helem
45             or $action == B::MDEREF_AV_gvsv_vivify_rv2av_aelem
46             ) {
47 3         16 $deparsed .= '$' . $self->_gv_name(shift @aux_list) . '->';
48              
49             } elsif ($action == B::MDEREF_HV_vivify_rv2hv_helem
50             or $action == B::MDEREF_AV_vivify_rv2av_aelem
51             ) {
52 9         17 $deparsed .= '->';
53             }
54              
55              
56 22         51 $deparsed .= $open_bracket[$is_hash];
57              
58 22         32 my $index = $aux & B::MDEREF_INDEX_MASK;
59 22 100       55 if ($index == B::MDEREF_INDEX_padsv) {
    50          
60 2         6 $deparsed .= $self->_padname_sv(shift @aux_list)->PV;
61              
62             } elsif ($index == B::MDEREF_INDEX_const) {
63 20         33 my $sv = shift(@aux_list);
64 20 100       53 $deparsed .= $is_hash
65             ? $self->_quote_sv($sv)
66             : $sv;
67             }
68              
69 22         53 $deparsed .= $close_bracket[$is_hash];
70              
71             } continue {
72 22         53 $aux >>= B::MDEREF_SHIFT;
73             }
74             }
75              
76 13         43 $deparsed;
77             }
78              
79             my %multiconcat_skip_optimized_children = ( pp_padsv => 1, pp_const => 1, pp_pushmark => 1 );
80             sub pp_multiconcat {
81 0     0 0   my($self, %flags) = @_;
82              
83             # Skip children that were optimized away by the multiconcat
84 0           my @kids = grep { my $name = $_->op->name;
85 0 0         if ($name eq 'null') {
86 0           $name = 'ex-' . $_->_ex_name;
87             }
88 0   0       ! ( $_->is_null && $multiconcat_skip_optimized_children{ $_->_ex_name } )
89             }
90 0           @{$self->children};
  0            
91              
92 0           my $is_assign;
93 0           my $lhs = '';
94 0           my $op = $self->op;
95 0           my $is_append = $op->private & &B::OPpMULTICONCAT_APPEND;
96 0 0         if ($op->private & B::OPpTARGET_MY) {
    0          
97             # $var = ... or $var .= ...
98 0           $lhs = $self->_padname_sv($op->targ)->PV;
99 0           $is_assign = 1;
100             } elsif ($op->flags & B::OPf_STACKED) {
101             # expr = ,,, or expr .= ...
102 0 0         my $expr = $is_append ? shift(@kids) : pop(@kids);
103 0           $lhs = $expr->deparse;
104 0           $is_assign = 1;
105             }
106              
107 0 0         if ($is_assign) {
108 0 0         $lhs .= $is_append ? ' .= ' : ' = ';
109             }
110              
111             # extract a list of string constants from the combined string and list of substring lengths
112 0           my($nargs, $const_str, @substr_lengths) = $self->op->aux_list($self->cv);
113 0           my $str_idx = 0;
114 0           my @string_parts;
115 0           foreach my $len ( @substr_lengths ) {
116 0 0         if ($len == -1) {
117 0           push @string_parts, undef;
118             } else {
119 0           push @string_parts, substr($const_str, $str_idx, $len);
120 0           $str_idx += $len;
121             }
122             }
123              
124 0           my $rhs = '';
125 0 0 0       if ($op->private & &B::OPpMULTICONCAT_STRINGIFY
    0          
126             or $op->parent->name eq 'substcont'
127             ) {
128             # A double quoted string with variable interpolation: "foo = $foo bar = $bar"
129 0           foreach my $str_part ( @string_parts ) {
130 0 0         $rhs .= $str_part if defined $str_part;
131 0 0         $rhs .= shift(@kids)->deparse if @kids;
132             }
133 0           $rhs = $self->_quote_string($rhs, skip_quotes => 1, %flags);
134 0 0         $rhs = "qq($rhs)" unless $flags{skip_quotes};
135              
136             } elsif ($op->private & &B::OPpMULTICONCAT_FAKE) {
137             # sprintf() with only %s and %% formats
138 0           my $format_str = join('%s', map { s/%/%%/g }
139 0 0         map { defined ? $_ : '' }
  0            
140             @string_parts);
141             $rhs .= sprintf('sprintf(%s, %s)',
142             $format_str,
143 0           join(', ', map { $_->deparse } @kids));
  0            
144             } else {
145             # one or more explicit concats: "foo" . $foo
146 0           my @parts;
147 0           foreach my $str_part ( @string_parts ) {
148 0 0         if (defined $str_part) {
149 0 0         $str_part = $self->_quote_string($str_part) unless $flags{skip_quotes};
150 0           push @parts, $str_part;
151             }
152 0 0         push @parts, shift(@kids)->deparse if @kids;
153             }
154 0           $rhs .= join(' . ', @parts);
155             }
156              
157 0           return "${lhs}${rhs}";
158             }
159              
160             1;
161              
162             __END__