File Coverage

blib/lib/Pg/SQL/PrettyPrinter/Node/XmlExpr.pm
Criterion Covered Total %
statement 210 210 100.0
branch 44 52 84.6
condition n/a
subroutine 31 31 100.0
pod 17 17 100.0
total 302 310 97.4


line stmt bran cond sub pod time code
1             package Pg::SQL::PrettyPrinter::Node::XmlExpr;
2              
3             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
4 2     2   1714 use v5.26;
  2         8  
5 2     2   24 use strict;
  2         12  
  2         49  
6 2     2   11 use warnings;
  2         4  
  2         54  
7 2     2   10 use warnings qw( FATAL utf8 );
  2         3  
  2         83  
8 2     2   11 use utf8;
  2         5  
  2         22  
9 2     2   62 use open qw( :std :utf8 );
  2         4  
  2         21  
10 2     2   342 use Unicode::Normalize qw( NFC );
  2         4  
  2         162  
11 2     2   16 use Unicode::Collate;
  2         3  
  2         79  
12 2     2   12 use Encode qw( decode );
  2         14  
  2         163  
13              
14             if ( grep /\P{ASCII}/ => @ARGV ) {
15             @ARGV = map { decode( 'UTF-8', $_ ) } @ARGV;
16             }
17              
18             # If there is __DATA__,then uncomment next line:
19             # binmode( DATA, ':encoding(UTF-8)' );
20             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
21              
22             # Useful common code
23 2     2   443 use autodie;
  2         5  
  2         32  
24 2     2   11318 use Carp qw( carp croak confess cluck );
  2         7  
  2         176  
25 2     2   16 use English qw( -no_match_vars );
  2         5  
  2         12  
26 2     2   760 use Data::Dumper qw( Dumper );
  2         5  
  2         528  
27              
28             # give a full stack dump on any untrapped exceptions
29             local $SIG{ __DIE__ } = sub {
30             confess "Uncaught exception: @_" unless $^S;
31             };
32              
33             # now promote run-time warnings into stackdumped exceptions
34             # *unless* we're in an try block, in which
35             # case just generate a clucking stackdump instead
36             local $SIG{ __WARN__ } = sub {
37             if ( $^S ) { cluck "Trapped warning: @_" }
38             else { confess "Deadly warning: @_" }
39             };
40              
41             # Useful common code
42              
43 2     2   18 use parent qw( Pg::SQL::PrettyPrinter::Node );
  2         4  
  2         12  
44              
45             sub new {
46 13     13 1 435 my $class = shift;
47 13         52 my $self = $class->SUPER::new( @_ );
48 13         24 bless $self, $class;
49              
50 13         27 our %is_op_ok = map { $_ => 1 } qw(
  91         225  
51             IS_DOCUMENT
52             IS_XMLELEMENT
53             IS_XMLCONCAT
54             IS_XMLFOREST
55             IS_XMLPARSE
56             IS_XMLPI
57             IS_XMLROOT
58             );
59              
60 13 50       55 croak( 'Unknown XML op: ' . $self->{ 'op' } ) unless $is_op_ok{ $self->{ 'op' } };
61 13 50       78 croak( 'Unknown XML option: ' . $self->{ 'xmloption' } ) unless $self->{ 'xmloption' } =~ m{\AXMLOPTION_(DOCUMENT|CONTENT)\z};
62              
63 13         64 $self->objectify( qw( named_args args ) );
64              
65 13         28 return $self;
66             }
67              
68             sub as_text {
69 13     13 1 21 my $self = shift;
70 13 100       38 return $self->element_as_text if $self->{ 'op' } eq 'IS_XMLELEMENT';
71 12 100       32 return $self->forest_as_text if $self->{ 'op' } eq 'IS_XMLFOREST';
72 11 100       29 return $self->parse_as_text if $self->{ 'op' } eq 'IS_XMLPARSE';
73 9 100       31 return $self->pi_as_text if $self->{ 'op' } eq 'IS_XMLPI';
74 7 100       22 return $self->root_as_text if $self->{ 'op' } eq 'IS_XMLROOT';
75 3 100       10 return $self->concat_as_text if $self->{ 'op' } eq 'IS_XMLCONCAT';
76 2 50       11 return $self->isdocument_as_text if $self->{ 'op' } eq 'IS_DOCUMENT';
77             }
78              
79             sub pretty_print {
80 13     13 1 22 my $self = shift;
81 13 100       38 return $self->element_pretty_print if $self->{ 'op' } eq 'IS_XMLELEMENT';
82 12 100       34 return $self->forest_pretty_print if $self->{ 'op' } eq 'IS_XMLFOREST';
83 11 100       39 return $self->parse_pretty_print if $self->{ 'op' } eq 'IS_XMLPARSE';
84 9 100       34 return $self->pi_pretty_print if $self->{ 'op' } eq 'IS_XMLPI';
85 7 100       38 return $self->root_pretty_print if $self->{ 'op' } eq 'IS_XMLROOT';
86 3 100       14 return $self->concat_pretty_print if $self->{ 'op' } eq 'IS_XMLCONCAT';
87 2 50       12 return $self->isdocument_pretty_print if $self->{ 'op' } eq 'IS_DOCUMENT';
88             }
89              
90             sub element_as_text {
91 1     1 1 2 my $self = shift;
92 1         1 my @elements = ();
93 1         2 push @elements, 'XMLELEMENT(';
94 1         9 push @elements, 'NAME', $self->quote_ident( $self->{ 'name' } );
95 1 50       3 if ( exists $self->{ 'named_args' } ) {
96 1         3 $elements[ -1 ] .= ',';
97 1         2 push @elements, 'XMLATTRIBUTES(';
98 1         2 push @elements, map { $_->as_text . ',' } @{ $self->{ 'named_args' } };
  2         7  
  1         2  
99 1         5 $elements[ -1 ] =~ s/,\z//;
100 1         3 push @elements, ')';
101             }
102 1 50       3 if ( exists $self->{ 'args' } ) {
103 1         2 $elements[ -1 ] .= ',';
104 1         2 push @elements, map { $_->as_text . ',' } @{ $self->{ 'args' } };
  1         3  
  1         4  
105 1         8 $elements[ -1 ] =~ s/,\z//;
106             }
107 1         2 push @elements, ')';
108 1         5 return join( ' ', @elements );
109             }
110              
111             sub element_pretty_print {
112 1     1 1 2 my $self = shift;
113 1         2 my @lines = ();
114 1         2 push @lines, 'XMLELEMENT(';
115 1         4 push @lines, $self->increase_indent( 'NAME ' . $self->quote_ident( $self->{ 'name' } ) );
116 1 50       4 if ( exists $self->{ 'named_args' } ) {
117 1         2 $lines[ -1 ] .= ',';
118 1         3 push @lines, $self->increase_indent( 'XMLATTRIBUTES(' );
119 1         2 push @lines, map { $self->increase_indent_n( 2, $_->pretty_print ) . ',' } @{ $self->{ 'named_args' } };
  2         7  
  1         3  
120 1         5 $lines[ -1 ] =~ s/,\z//;
121 1         4 push @lines, $self->increase_indent( ')' );
122             }
123 1 50       4 if ( exists $self->{ 'args' } ) {
124 1         2 $lines[ -1 ] .= ',';
125 1         1 push @lines, map { $self->increase_indent( $_->pretty_print ) . ',' } @{ $self->{ 'args' } };
  1         6  
  1         8  
126 1         6 $lines[ -1 ] =~ s/,\z//;
127             }
128 1         2 push @lines, ')';
129 1         6 return join( "\n", @lines );
130             }
131              
132             sub concat_as_text {
133 1     1 1 2 my $self = shift;
134 1         1 my @elements = ();
135 1         3 push @elements, 'XMLCONCAT(';
136 1         2 push @elements, join( ', ', map { $_->as_text } @{ $self->{ 'args' } } );
  2         7  
  1         2  
137 1         3 push @elements, ')';
138 1         5 return join( ' ', @elements );
139             }
140              
141             sub concat_pretty_print {
142 1     1 1 2 my $self = shift;
143 1         2 my @lines = ();
144 1         2 push @lines, 'XMLCONCAT(';
145 1         2 push @lines, map { $self->increase_indent( $_->pretty_print ) . ',' } @{ $self->{ 'args' } };
  2         7  
  1         3  
146 1         6 $lines[ -1 ] =~ s/,\z//;
147 1         2 push @lines, ')';
148 1         5 return join( "\n", @lines );
149             }
150              
151             sub forest_as_text {
152 1     1 1 2 my $self = shift;
153 1         2 my @elements = ();
154 1         3 push @elements, 'XMLFOREST(';
155 1         2 push @elements, join( ', ', map { $_->as_text } @{ $self->{ 'named_args' } } );
  3         9  
  1         3  
156 1         3 push @elements, ')';
157 1         4 return join( ' ', @elements );
158             }
159              
160             sub forest_pretty_print {
161 1     1 1 3 my $self = shift;
162 1         3 my @lines = ();
163 1         2 push @lines, 'XMLFOREST(';
164 1         2 push @lines, map { $self->increase_indent( $_->pretty_print ) . ',' } @{ $self->{ 'named_args' } };
  3         10  
  1         3  
165 1         6 $lines[ -1 ] =~ s/,\z//;
166 1         3 push @lines, ')';
167 1         5 return join( "\n", @lines );
168             }
169              
170             sub parse_as_text {
171 2     2 1 4 my $self = shift;
172 2         5 my @elements = ();
173 2         4 push @elements, 'XMLPARSE(';
174 2         5 push @elements, $self->{ 'xmloption' };
175 2         8 $elements[ -1 ] =~ s/^XMLOPTION_//;
176 2         9 push @elements, $self->{ 'args' }->[ 0 ]->as_text;
177 2         5 push @elements, ')';
178 2         10 return join( ' ', @elements );
179             }
180              
181             sub parse_pretty_print {
182 2     2 1 6 my $self = shift;
183 2         5 my @lines = ();
184 2         5 push @lines, 'XMLPARSE(';
185 2         10 push @lines, $self->increase_indent( $self->{ 'xmloption' } );
186 2         15 $lines[ -1 ] =~ s/^(\s+)XMLOPTION_/$1/;
187 2         10 push @lines, $self->increase_indent( $self->{ 'args' }->[ 0 ]->pretty_print );
188 2         5 push @lines, ')';
189 2         9 return join( "\n", @lines );
190             }
191              
192             sub pi_as_text {
193 2     2 1 4 my $self = shift;
194 2         4 my @elements = ();
195 2         5 push @elements, 'XMLPI(';
196 2         9 push @elements, 'NAME', $self->quote_ident( $self->{ 'name' } );
197 2 100       19 if ( exists $self->{ 'args' } ) {
198 1         13 $elements[ -1 ] .= ',';
199 1         6 push @elements, $self->{ 'args' }->[ 0 ]->as_text;
200             }
201 2         8 push @elements, ')';
202 2         11 return join( ' ', @elements );
203             }
204              
205             sub pi_pretty_print {
206 2     2 1 4 my $self = shift;
207 2         5 my @lines = ();
208 2         4 push @lines, 'XMLPI(';
209 2         10 push @lines, $self->increase_indent( 'NAME ' . $self->quote_ident( $self->{ 'name' } ) );
210 2 100       11 if ( exists $self->{ 'args' } ) {
211 1         4 $lines[ -1 ] .= ',';
212 1         6 push @lines, $self->increase_indent( $self->{ 'args' }->[ 0 ]->pretty_print );
213             }
214 2         6 push @lines, ')';
215 2         8 return join( "\n", @lines );
216             }
217              
218             sub root_as_text {
219 4     4 1 6 my $self = shift;
220 4         8 my @elements = ();
221 4         11 push @elements, 'XMLROOT(';
222 4         17 push @elements, $self->{ 'args' }->[ 0 ]->as_text . ',';
223 4         14 my $ver = $self->{ 'args' }->[ 1 ]->as_text;
224 4 100       12 $ver = 'NO VALUE' if $ver eq 'NULL';
225 4         9 push @elements, 'VERSION', $ver;
226 4 100       12 if ( $self->{ 'args' }->[ 2 ]->as_text != 3 ) {
227 3         8 $elements[ -1 ] .= ',';
228 3         12 my $val = { 2 => 'NO VALUE', 0 => 'YES', 1 => 'NO' };
229 3         10 push @elements, 'STANDALONE', $val->{ $self->{ 'args' }->[ 2 ]->as_text };
230             }
231 4         10 push @elements, ')';
232 4         18 return join( ' ', @elements );
233             }
234              
235             sub root_pretty_print {
236 4     4 1 8 my $self = shift;
237 4         8 my @lines = ();
238 4         8 push @lines, 'XMLROOT(';
239 4         17 push @lines, $self->increase_indent( $self->{ 'args' }->[ 0 ]->pretty_print ) . ',';
240 4         17 my $ver = $self->{ 'args' }->[ 1 ]->pretty_print;
241 4 100       14 $ver = 'NO VALUE' if $ver eq 'NULL';
242 4         13 push @lines, $self->increase_indent( 'VERSION ' . $ver );
243 4 100       13 if ( $self->{ 'args' }->[ 2 ]->as_text != 3 ) {
244 3         10 $lines[ -1 ] .= ',';
245 3         13 my $val = { 2 => 'NO VALUE', 0 => 'YES', 1 => 'NO' };
246 3         9 push @lines, $self->increase_indent( 'STANDALONE ' . $val->{ $self->{ 'args' }->[ 2 ]->as_text } );
247             }
248 4         11 push @lines, ')';
249 4         19 return join( "\n", @lines );
250             }
251              
252             sub isdocument_as_text {
253 2     2 1 15 my $self = shift;
254 2         6 my @elements = ();
255 2         10 push @elements, $self->{ 'args' }->[ 0 ]->as_text;
256 2         5 push @elements, 'IS DOCUMENT';
257 2         9 return join( ' ', @elements );
258             }
259              
260             sub isdocument_pretty_print {
261 2     2 1 5 my $self = shift;
262 2         5 my @elements = ();
263 2         10 push @elements, $self->{ 'args' }->[ 0 ]->pretty_print;
264 2         6 push @elements, 'IS DOCUMENT';
265 2         8 return join( ' ', @elements );
266             }
267              
268             1;
269              
270             # vim: set ft=perl: