File Coverage

blib/lib/Mojo/DOM/Role/Restrict.pm
Criterion Covered Total %
statement 86 116 74.1
branch 45 82 54.8
condition 29 36 80.5
subroutine 17 19 89.4
pod 5 7 71.4
total 182 260 70.0


line stmt bran cond sub pod time code
1             package Mojo::DOM::Role::Restrict;
2 9     9   77294 use strict; use warnings; our $VERSION = 0.04;
  9     9   30  
  9         269  
  9         50  
  9         18  
  9         442  
3 9     9   601 use Mojo::Base -role;
  9         206745  
  9         66  
4 9     9   4740 use Mojo::Util qw(xml_escape);
  9         20  
  9         480  
5 9     9   57 use File::Spec;
  9         16  
  9         9597  
6              
7 26 100   26 0 11247 sub to_string { $_[1] ? ${$_[0]}->render : $_[0]->render; }
  11         44  
8              
9 15     15 0 66 sub render { _render($_[0]->tree, $_[0]->xml, $_[0]->restrict_spec) }
10              
11             around parse => sub {
12             my ($orig, $self) = (shift, shift);
13             $self->restrict_spec($_[1] || $self->restrict_spec || {
14             '*' => { '*' => 1 }
15             });
16             return $self->$orig(@_);
17             };
18              
19             sub restrict_spec {
20 70 100   70 1 624 if ( $_[1] ) {
21 33   100     51 $_[1]->{$_} && ! ref $_[1]->{$_} && do { $_[1]->{$_} = { '*' => 1 } } for (keys %{$_[1]});
  33   66     345  
  24         98  
22 33         69 ${$_[0]}->{restrict_spec} = $_[1];
  33         628  
23             }
24 70         263 ${$_[0]}->{restrict_spec};
  70         193  
25             }
26              
27 9     9 1 4947 sub valid { _valid($_[0]->tree, $_[0]->restrict_spec($_[1])) }
28              
29 12 50   12 1 9385 sub restrict { _restrict($_[0]->tree, $_[0]->restrict_spec($_[1])) && $_[0] }
30              
31             sub diff_module {
32 0 0 0 0 1 0 if ( $_[1] && $_[0]->diff_module_name !~ $_[1]) {
33 0         0 $_[0]->diff_module_name($_[1]);
34 0         0 $_[0]->diff_module_loaded(0);
35             }
36 0 0       0 $_[0]->diff_module_method($_[2]) if $_[2];
37 0 0       0 $_[0]->diff_module_params($_[3]) if defined $_[3];
38             return (
39 0         0 $_[0]->diff_module_name,
40             $_[0]->diff_module_method,
41             $_[0]->diff_module_params
42             );
43             }
44              
45             has diff_module_name => 'Text::Diff';
46              
47             has diff_module_loaded => 0;
48              
49             has diff_module_method => 'diff';
50              
51             has diff_module_params => sub { { style => 'Unified' } };
52              
53             sub diff {
54 0     0 1 0 my ($self, $spec) = ($_[0], (shift)->restrict_spec(shift));
55 0         0 my ($module, $method, $params) = $self->diff_module(@_);
56 0 0       0 unless ( $self->diff_module_loaded ) {
57 0         0 my @parts = split /::|'/, $module, -1;
58 0 0 0     0 shift @parts if @parts && !$parts[0];
59 0         0 my $file = File::Spec->catfile( @parts );
60             LOAD_DIFF_MODULE: {
61 0         0 my $err;
  0         0  
62 0         0 for my $flag ( qw[1 0] ) {
63 0 0       0 my $load = $file . ($flag ? '.pm' : '');
64 0         0 eval { require $load };
  0         0  
65 0 0       0 $@ ? $err .= $@ : last LOAD_DIFF_MODULE;
66             }
67 0 0       0 die $err if $err;
68             }
69 0         0 $self->diff_module_loaded(1)
70             }
71             {
72 9     9   88 no strict 'refs';
  9         22  
  9         4091  
  0         0  
73 0         0 return *{"${module}::${method}"}->(\$self->to_string(1), \$self->to_string(), $params);
  0         0  
74             }
75             }
76              
77             # copy, paste and edit via Mojo::DOM::HTML::_render
78              
79             my %EMPTY = map { $_ => 1 } qw(area base br col embed hr img input keygen link menuitem meta param source track wbr);
80              
81             sub _render {
82 143     143   265 my ($tree, $xml, $spec) = @_;
83            
84             # Tag
85 143         261 my $type = $tree->[0];
86 143 100       292 if ($type eq 'tag') {
87              
88             # Start tag
89 90         138 my ($tag, $attrs) = _valid_tag($spec, $tree->[1], {%{$tree->[2]}});
  90         292  
90            
91 90 100       342 return '' unless $tag;
92            
93 76         152 my $result = "<$tag";
94              
95             # Attributes
96 76         110 for (sort keys %{$attrs}) {
  76         225  
97 78         426 my ($key, $value) = _valid_attribute($spec, $tag, $_, $attrs->{$_});
98 78 0       481 $result .= defined $value
    50          
    100          
99             ? qq{ $key="} . xml_escape($value) . '"'
100             : $xml
101             ? qq{ $key="$key"}
102             : " $key"
103             if $key;
104             }
105              
106             # No children
107 76 0       240 return $xml ? "$result />" : $EMPTY{$tag} ? "$result>" : "$result>" unless $tree->[4];
    0          
    50          
108              
109             # Children
110 9     9   75 no warnings 'recursion';
  9         20  
  9         10072  
111 76         175 $result .= '>' . join '', map { _render($_, $xml, $spec) } @$tree[4 .. $#$tree];
  113         445  
112              
113             # End tag
114 76         551 return "$result";
115             }
116              
117             # Text (escaped)
118 53 100       142 return xml_escape $tree->[1] if $type eq 'text';
119              
120             # Raw text
121 17 100       49 return $tree->[1] if $type eq 'raw';
122              
123             # Root
124 15 50       66 return join '', map { _render($_, $xml, $spec) } @$tree[1 .. $#$tree] if $type eq 'root';
  15         87  
125              
126             # DOCTYPE
127 0 0       0 return '[1] . '>' if $type eq 'doctype';
128              
129             # Comment
130 0 0       0 return '' if $type eq 'comment';
131              
132             # CDATA
133 0 0       0 return '[1] . ']]>' if $type eq 'cdata';
134              
135             # Processing instruction
136 0 0       0 return '[1] . '?>' if $type eq 'pi';
137              
138             # Everything else
139 0         0 return '';
140             }
141              
142             sub _valid_tag {
143 204     204   401 my ($spec, $tag, $attrs) = @_;
144 204   100     619 my $valid = $spec->{$tag} // $spec->{'*'};
145             return ref $valid && $valid->{validate_tag}
146 204 100 100     966 ? $valid->{validate_tag}($tag, $attrs)
    100          
147             : $valid
148             ? ($tag, $attrs)
149             : 0;
150             }
151              
152             sub _valid_attribute {
153 154     154   330 my ($spec, $tag, $attr, $value) = @_;
154 154   100     878 my $valid = $spec->{$tag}->{$attr} // $spec->{$tag}->{'*'} // $spec->{'*'}->{$attr} // $spec->{'*'}->{'*'};
      100        
      100        
155 154 100 100     887 return ref $valid
    100          
156             ? $valid->($attr, $value)
157             : ($valid and $valid =~ m/1/ || $value =~ m/$valid/)
158             ? ( $attr, $value )
159             : 0;
160             }
161              
162             sub _valid {
163 58     58   106 my ($tree, $spec) = @_;
164 58 100       131 if ($tree->[0] eq 'tag') {
    100          
165 38         57 my ($tag, $attrs) = _valid_tag($spec, $tree->[1], {%{$tree->[2]}});
  38         104  
166 38 100       113 return 0 unless $tag;
167             _valid_attribute($spec, $tag, $_, $attrs->{$_}) or return 0
168 34   100     49 for (sort keys %{$attrs});
  34         108  
169 32 50       73 if ($tree->[4]) {
170 32   100     98 _valid($_, $spec) or return 0 for ( @$tree[4 .. $#$tree] );
171             }
172             } elsif ($tree->[0] eq 'root') {
173 9   100     45 _valid($_, $spec) or return 0 for ( @$tree[1 .. $#$tree] );
174             }
175 36         98 return 1;
176             }
177              
178             sub _restrict {
179 120     120   205 my ($tree, $spec) = @_;
180 120 100       277 if ($tree->[0] eq 'tag') {
    100          
181 76         139 my ($tag, $attrs) = _valid_tag($spec, $tree->[1], $tree->[2]);
182 76 100       244 return 0 unless $tag;
183 64         112 $tree->[1] = $tag;
184 64         88 for (sort keys %{$attrs}) {
  64         184  
185 64         151 my ($key, $value) = _valid_attribute($spec, $tag, $_, delete $attrs->{$_});
186 64 100       348 $attrs->{$key} = $value if $key;
187             }
188 64 50       149 if ($tree->[4]) {
189 64         89 my $i = 4;
190 12         67 _restrict($_, $spec) ? $i++ : splice(@{$tree}, $i, 1)
191 64 100       240 for ( @$tree[$i .. $#$tree] );
192             }
193             } elsif ($tree->[0] eq 'root') {
194 12         23 my $i = 1;
195 0         0 _restrict($_, $spec) ? $i++ : splice(@{$tree}, $i, 1)
196 12 50       69 for ( @$tree[$i .. $#$tree] );
197             }
198 108         264 return 1;
199             }
200              
201              
202             1;
203              
204             # TODO pretty print (for diff) and minmize.
205              
206             __END__