File Coverage

blib/lib/Pg/SQL/PrettyPrinter.pm
Criterion Covered Total %
statement 77 93 82.8
branch 20 28 71.4
condition n/a
subroutine 21 22 95.4
pod 5 5 100.0
total 123 148 83.1


line stmt bran cond sub pod time code
1             package Pg::SQL::PrettyPrinter;
2              
3             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
4 15     15   1051929 use v5.26;
  15         206  
5 15     15   90 use strict;
  15         29  
  15         506  
6 15     15   83 use warnings;
  15         30  
  15         433  
7 15     15   77 use warnings qw( FATAL utf8 );
  15         51  
  15         644  
8 15     15   8765 use utf8;
  15         221  
  15         73  
9 15     15   7072 use open qw( :std :utf8 );
  15         18302  
  15         100  
10 15     15   10539 use Unicode::Normalize qw( NFC );
  15         32062  
  15         1513  
11 15     15   10869 use Unicode::Collate;
  15         131514  
  15         608  
12 15     15   8989 use Encode qw( decode );
  15         157903  
  15         1688  
13              
14 15     15   131 if ( grep /\P{ASCII}/ => @ARGV ) {
  15         41  
  15         193  
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 15     15   323705 use autodie;
  15         211614  
  15         82  
24 15     15   98676 use Carp qw( carp croak confess cluck );
  15         35  
  15         1188  
25 15     15   8586 use English qw( -no_match_vars );
  15         54633  
  15         96  
26 15     15   14811 use Data::Dumper qw( Dumper );
  15         93432  
  15         2995  
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 15     15   11120 use HTTP::Tiny;
  15         705271  
  15         814  
44 15     15   7685 use JSON::MaybeXS;
  15         118647  
  15         1072  
45 15     15   7646 use Pg::SQL::PrettyPrinter::Node;
  15         45  
  15         13320  
46              
47             our $VERSION = 0.7;
48              
49             sub new {
50 142     142 1 144569 my ( $class, %args ) = @_;
51 142         503 my $self = bless {}, $class;
52              
53 142 100       541 croak( 'SQL query was not provided!' ) unless $args{ 'sql' };
54 141         456 $self->{ 'sql' } = $args{ 'sql' };
55              
56 141 100       516 if ( exists $args{ 'service' } ) {
    100          
57 3 100       17 croak( 'You should provide only one of service/struct!' ) if $args{ 'struct' };
58 2 50       29 croak( 'Invalid syntax for service!' ) unless $args{ 'service' } =~ m{
59             \A
60             http://
61             \d{1,3} (?: \. \d{1,3} ){3} # IP address for parse microservice
62             :
63             [1-9]\d+ # Port number for parse microservice
64             /
65             \z
66             }x;
67 0         0 $self->{ 'service' } = $args{ 'service' };
68             }
69             elsif ( exists $args{ 'struct' } ) {
70 137         507 $self->validate_struct( $args{ 'struct' } );
71 130         291 $self->{ 'struct' } = $args{ 'struct' };
72             }
73             else {
74 1         10 croak( 'You have to provide either service or struct!' );
75             }
76 130         374 return $self;
77             }
78              
79             sub validate_struct {
80 137     137 1 285 my ( $self, $struct ) = @_;
81 137 100       453 croak( 'Invalid parse struct!' ) unless 'HASH' eq ref $struct;
82 135 100       447 croak( 'Invalid parse struct (#2)!' ) unless $struct->{ 'version' };
83 133 100       354 croak( 'Invalid parse struct (#3)!' ) unless $struct->{ 'stmts' };
84 132 100       399 croak( 'Invalid parse struct (#4)!' ) unless 'ARRAY' eq ref $struct->{ 'stmts' };
85 131 100       226 croak( 'Invalid parse struct (#5)!' ) unless 0 < scalar @{ $struct->{ 'stmts' } };
  131         381  
86 130         281 return;
87             }
88              
89             sub parse {
90 130     130 1 521 my $self = shift;
91 130         405 $self->fetch_struct();
92 130         224 $self->{ 'statements' } = [ map { Pg::SQL::PrettyPrinter::Node->make_from( $_->{ 'stmt' } ) } @{ $self->{ 'struct' }->{ 'stmts' } } ];
  130         740  
  130         412  
93 130         358 return;
94             }
95              
96             sub remove_irrelevant {
97 0     0 1 0 my $self = shift;
98 0         0 my $q = $self->{ 'sql' };
99 0         0 $q =~ s{
100             \A # Beginning of sql
101             \s* # Eventual spacing, including new lines
102             [a-z0-9_]* # optional dbname
103             [=-]? # optional prompt type
104             [>#\$] # prompt final character, depending on user level, or common(ish) '$'
105             \s* # optional spaces
106             }{}x;
107 0         0 $self->{ 'sql' } = $q;
108             }
109              
110             sub fetch_struct {
111 130     130 1 217 my $self = shift;
112 130 50       386 return if $self->{ 'struct' };
113 0           $self->remove_irrelevant();
114 0           my $http = HTTP::Tiny->new( 'timeout' => 0.5 ); # There really isn't a reason why it should take longer than 0.3s
115 0           my $res = $http->post_form( $self->{ 'service' }, { 'q' => $self->{ 'sql' } } );
116 0 0         unless ( $res->{ 'success' } ) {
117 0 0         croak( 'Timeout while parsing' ) if $res->{ 'content' } =~ m{\ATimed out while waiting for socket};
118 0           croak( "Couldn't parse the queries! : " . Dumper( $res ) );
119             }
120 0           my $struct = decode_json( $res->{ 'content' } );
121 0 0         croak( "Parse error: " . $struct->{ 'error' } ) if exists $struct->{ 'error' };
122 0           $self->validate_struct( $struct );
123 0           $self->{ 'struct' } = $struct;
124 0           return;
125             }
126              
127             1;