File Coverage

blib/lib/Pg/SQL/PrettyPrinter/Node/UpdateStmt.pm
Criterion Covered Total %
statement 146 147 99.3
branch 30 32 93.7
condition n/a
subroutine 19 19 100.0
pod 5 5 100.0
total 200 203 98.5


line stmt bran cond sub pod time code
1             package Pg::SQL::PrettyPrinter::Node::UpdateStmt;
2              
3             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
4 2     2   1531 use v5.26;
  2         10  
5 2     2   12 use strict;
  2         6  
  2         42  
6 2     2   10 use warnings;
  2         37  
  2         66  
7 2     2   11 use warnings qw( FATAL utf8 );
  2         4  
  2         67  
8 2     2   10 use utf8;
  2         5  
  2         11  
9 2     2   49 use open qw( :std :utf8 );
  2         4  
  2         10  
10 2     2   306 use Unicode::Normalize qw( NFC );
  2         6  
  2         122  
11 2     2   43 use Unicode::Collate;
  2         6  
  2         95  
12 2     2   13 use Encode qw( decode );
  2         3  
  2         156  
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   488 use autodie;
  2         5  
  2         13  
24 2     2   11109 use Carp qw( carp croak confess cluck );
  2         4  
  2         159  
25 2     2   12 use English qw( -no_match_vars );
  2         11  
  2         22  
26 2     2   787 use Data::Dumper qw( Dumper );
  2         5  
  2         478  
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   15 use parent qw( Pg::SQL::PrettyPrinter::Node );
  2         4  
  2         16  
44              
45             sub new {
46 10     10 1 415 my $class = shift;
47 10         51 my $self = $class->SUPER::new( @_ );
48 10         22 bless $self, $class;
49              
50 10         69 $self->objectify(
51             qw( targetList whereClause fromClause returningList ),
52             [ 'withClause', 'ctes' ],
53             );
54              
55 10         50 $self->build_set_array();
56              
57 10         27 return $self;
58             }
59              
60             sub build_set_array {
61 10     10 1 32 my $self = shift;
62 10         23 my @set = ();
63 10         19 my $multi_join = 0;
64              
65 10         18 for my $item ( @{ $self->{ 'targetList' } } ) {
  10         31  
66 20         40 my $column = $item->{ 'name' };
67 20 100       46 if ( $multi_join > 0 ) {
68 6         10 push @{ $set[ -1 ]->{ 'cols' } }, $column;
  6         16  
69 6         11 $multi_join--;
70 6         25 next;
71             }
72 14         39 my $val = $item->{ 'val' };
73 14 100       42 if ( 'Pg::SQL::PrettyPrinter::Node::MultiAssignRef' eq ref $val ) {
74 3         13 push @set, { 'cols' => [ $column ], 'val' => $val->{ 'source' } };
75 3         11 $multi_join = $val->{ 'ncolumns' } - 1;
76             }
77             else {
78 11         42 push @set, { 'col' => $column, 'val' => $val };
79             }
80             }
81 10         37 $self->{ '_set' } = \@set;
82             }
83              
84             sub as_text {
85 10     10 1 49 my $self = shift;
86 10         21 my @elements = ();
87 10         18 push @elements, 'UPDATE';
88 10         30 push @elements, $self->relname;
89 10         20 push @elements, 'SET';
90 10         20 my @set_elements = ();
91 10         16 for my $item ( @{ $self->{ '_set' } } ) {
  10         28  
92 14 100       32 if ( exists $item->{ 'col' } ) {
93 11         33 push @set_elements, sprintf '%s = %s', $self->quote_ident( $item->{ 'col' } ), $item->{ 'val' }->as_text;
94             }
95             else {
96             push @set_elements, sprintf(
97             '( %s ) = %s',
98 3         19 join( ', ', @{ $item->{ 'cols' } } ),
99 3         6 $item->{ 'val' }->as_text
100             );
101             }
102             }
103 10         34 push @elements, join( ', ', @set_elements );
104 10 100       24 if ( exists $self->{ 'fromClause' } ) {
105 3         9 push @elements, 'FROM';
106 3         8 push @elements, join( ', ', map { $_->as_text } @{ $self->{ 'fromClause' } } );
  3         13  
  3         8  
107             }
108 10 100       30 if ( exists $self->{ 'whereClause' } ) {
109 6         15 push @elements, 'WHERE';
110 6         25 push @elements, $self->{ 'whereClause' }->as_text;
111             }
112 10 100       80 if ( exists $self->{ 'returningList' } ) {
113 2         5 push @elements, 'RETURNING';
114 2         4 push @elements, join( ', ', map { $_->as_text } @{ $self->{ 'returningList' } } );
  4         12  
  2         5  
115             }
116 10         24 my $prefix = '';
117 10 100       59 if ( exists $self->{ 'withClause' } ) {
118 1         3 $prefix = 'WITH ';
119 1 50       4 $prefix .= 'RECURSIVE ' if $self->{ 'withClause' }->{ 'recursive' };
120 1         3 $prefix .= join( ', ', map { $_->as_text } @{ $self->{ 'withClause' }->{ 'ctes' } } ) . ' ';
  1         4  
  1         3  
121             }
122 10         66 return $prefix . join( ' ', @elements );
123             }
124              
125             sub pretty_print {
126 10     10 1 8900 my $self = shift;
127 10         21 my @lines = ();
128 10         32 push @lines, 'UPDATE ' . $self->relname;
129 10         25 push @lines, 'SET';
130 10         18 for my $item ( @{ $self->{ '_set' } } ) {
  10         27  
131 14 100       40 if ( exists $item->{ 'col' } ) {
132             push @lines, $self->increase_indent(
133             sprintf(
134             '%s = %s,',
135             $self->quote_ident( $item->{ 'col' } ),
136 11         47 $item->{ 'val' }->pretty_print
137             )
138             );
139             }
140             else {
141             push @lines, $self->increase_indent(
142             sprintf(
143             '( %s ) = %s,',
144 3         16 join( ', ', @{ $item->{ 'cols' } } ),
145 3         9 $item->{ 'val' }->pretty_print
146             )
147             );
148             }
149             }
150              
151             # Remove unnecessary trailing , in last element
152 10         51 $lines[ -1 ] =~ s/,\z//;
153              
154 10 100       34 if ( exists $self->{ 'fromClause' } ) {
155 3         9 push @lines, 'FROM';
156 3         6 push @lines, map { $self->increase_indent( $_->pretty_print ) . ',' } @{ $self->{ 'fromClause' } };
  3         16  
  3         7  
157              
158             # Remove unnecessary trailing , in last element
159 3         21 $lines[ -1 ] =~ s/,\z//;
160             }
161              
162 10 100       31 if ( exists $self->{ 'whereClause' } ) {
163 6         15 push @lines, 'WHERE';
164 6         25 push @lines, $self->increase_indent( $self->{ 'whereClause' }->pretty_print );
165             }
166              
167 10 100       41 if ( exists $self->{ 'returningList' } ) {
168 2         5 push @lines, 'RETURNING ';
169 2         4 $lines[ -1 ] .= join( ', ', map { $_->pretty_print } @{ $self->{ 'returningList' } } );
  4         14  
  2         5  
170             }
171              
172 10         34 my $main_body = join( "\n", @lines );
173 10 100       48 return $main_body unless exists $self->{ 'withClause' };
174              
175 1         2 my @cte_def = ();
176              
177 1         14 push @cte_def, map { $_->pretty_print . ',' } @{ $self->{ 'withClause' }->{ 'ctes' } };
  1         4  
  1         3  
178              
179             # Remove unnecessary trailing , in last element
180 1         6 $cte_def[ -1 ] =~ s/,\z//;
181 1 50       5 if ( $self->{ 'withClause' }->{ 'recursive' } ) {
182 0         0 $cte_def[ 0 ] = 'WITH RECURSIVE ' . $cte_def[ 0 ];
183             }
184             else {
185 1         4 $cte_def[ 0 ] = 'WITH ' . $cte_def[ 0 ];
186             }
187              
188 1         3 @lines = ();
189 1         4 push @lines, join( ' ', @cte_def );
190 1         2 push @lines, $main_body;
191 1         5 return join( "\n", @lines );
192             }
193              
194             sub relname {
195 20     20 1 35 my $self = shift;
196 20 100       57 if ( !$self->{ '_relname' } ) {
197 10         19 my $R = $self->{ 'relation' };
198 10         53 my @elements = map { $self->quote_ident( $R->{ $_ } ) }
199 10         21 grep { exists $R->{ $_ } } qw{ catalogname schemaname relname };
  30         71  
200 10         36 $self->{ '_relname' } = join( '.', @elements );
201 10 100       36 if ( $R->{ 'alias' }->{ 'aliasname' } ) {
202 1         5 $self->{ '_relname' } .= ' AS ' . $self->quote_ident( $R->{ 'alias' }->{ 'aliasname' } );
203             }
204             }
205 20         57 return $self->{ '_relname' };
206             }
207              
208             1;
209              
210             # vim: set ft=perl: