File Coverage

blib/lib/Pg/Explain/FromJSON.pm
Criterion Covered Total %
statement 78 79 98.7
branch 31 36 86.1
condition 6 9 66.6
subroutine 15 15 100.0
pod 1 1 100.0
total 131 140 93.5


line stmt bran cond sub pod time code
1             package Pg::Explain::FromJSON;
2              
3             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
4 73     73   988 use v5.18;
  73         292  
5 73     73   434 use strict;
  73         185  
  73         1514  
6 73     73   355 use warnings;
  73         160  
  73         2226  
7 73     73   391 use warnings qw( FATAL utf8 );
  73         206  
  73         2548  
8 73     73   401 use utf8;
  73         164  
  73         454  
9 73     73   2520 use open qw( :std :utf8 );
  73         193  
  73         489  
10 73     73   10196 use Unicode::Normalize qw( NFC );
  73         242  
  73         4274  
11 73     73   545 use Unicode::Collate;
  73         188  
  73         2873  
12 73     73   491 use Encode qw( decode );
  73         215  
  73         4496  
13              
14             if ( grep /\P{ASCII}/ => @ARGV ) {
15             @ARGV = map { decode( 'UTF-8', $_ ) } @ARGV;
16             }
17              
18             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
19              
20 73     73   16270 use base qw( Pg::Explain::From );
  73         186  
  73         8194  
21 73     73   35878 use JSON::MaybeXS;
  73         426308  
  73         4699  
22 73     73   602 use Carp;
  73         164  
  73         3832  
23 73     73   514 use Pg::Explain::JIT;
  73         175  
  73         1682  
24 73     73   417 use Pg::Explain::Buffers;
  73         242  
  73         53983  
25              
26             =head1 NAME
27              
28             Pg::Explain::FromJSON - Parser for explains in JSON format
29              
30             =head1 VERSION
31              
32             Version 2.3
33              
34             =cut
35              
36             our $VERSION = '2.3';
37              
38             =head1 SYNOPSIS
39              
40             It's internal class to wrap some work. It should be used by Pg::Explain, and not directly.
41              
42             =head1 FUNCTIONS
43              
44             =head2 parse_source
45              
46             Function which parses actual plan, and constructs Pg::Explain::Node objects
47             which represent it.
48              
49             Returns Top node of query plan.
50              
51             =cut
52              
53             sub parse_source {
54 74     74 1 151 my $self = shift;
55 74         156 my $source = shift;
56              
57             # We need to remove things before and/or after explain
58             # To do this, first - split explain into lines...
59 74         3826 my @source_lines = split( /[\r\n]+/, $source );
60              
61 74 100       397 if ( 1 < scalar @source_lines ) {
62              
63             # If there are many lines, there could be line prefix...
64 73         180 my $prefix = undef;
65              
66             # Now, find first line of explain, and cache it's prefix (some spaces ...)
67 73         199 for my $l ( @source_lines ) {
68 3954 100       7391 next unless $l =~ m{\A (\s*) \[ \s* \z }x;
69 69         243 $prefix = $1;
70             }
71              
72 73 100       287 if ( defined $prefix ) {
73              
74             # Now, extract lines with explain using known prefix
75 69         226 my @use_lines = grep { /\A$prefix\[\s*\z/ ... /\A$prefix\]\s*\z/ } @source_lines;
  3872         10205  
76 69         1283 $source = join( "\n", @use_lines );
77             }
78             }
79              
80             # And now parse the json...
81 74         3482 my $struct = decode_json( $source );
82 74 100 66     650 if ( ( 'ARRAY' eq ref $struct )
    50 33        
83             && ( defined $struct->[ 0 ]->{ 'Plan' } ) )
84             {
85             # This structure is used by normal "explain" command
86 70         243 $struct = $struct->[ 0 ];
87             }
88             elsif (( 'HASH' eq ref $struct )
89             && ( defined $struct->{ 'Plan' } ) )
90             {
91             # This structure is used by auto-explain command
92             # empty command block, so I can have simple else condition
93             }
94             else {
95 0         0 croak( 'Unknown JSON parsed' );
96             }
97              
98 74         443 my $top_node = $self->make_node_from( $struct->{ 'Plan' } );
99              
100 74 100       419 if ( $struct->{ 'Planning' } ) {
    100          
101 4         29 $self->explain->planning_time( $struct->{ 'Planning' }->{ 'Planning Time' } );
102 4         18 my $buffers = Pg::Explain::Buffers->new( $struct->{ 'Planning' } );
103 4 100       14 $self->explain->planning_buffers( $buffers ) if $buffers;
104             }
105             elsif ( $struct->{ 'Planning Time' } ) {
106 52         177 $self->explain->planning_time( $struct->{ 'Planning Time' } );
107             }
108 74 100       370 $self->explain->execution_time( $struct->{ 'Execution Time' } ) if $struct->{ 'Execution Time' };
109 74 100       282 $self->explain->total_runtime( $struct->{ 'Total Runtime' } ) if $struct->{ 'Total Runtime' };
110 74 100       272 if ( $struct->{ 'Triggers' } ) {
111 65         125 for my $t ( @{ $struct->{ 'Triggers' } } ) {
  65         228  
112 2         4 my $ts = {};
113 2 50       6 $ts->{ 'calls' } = $t->{ 'Calls' } if defined $t->{ 'Calls' };
114 2 50       7 $ts->{ 'time' } = $t->{ 'Time' } if defined $t->{ 'Time' };
115 2 50       6 $ts->{ 'relation' } = $t->{ 'Relation' } if defined $t->{ 'Relation' };
116 2 50       7 $ts->{ 'name' } = $t->{ 'Trigger Name' } if defined $t->{ 'Trigger Name' };
117 2         5 $self->explain->add_trigger_time( $ts );
118             }
119             }
120 74 100       243 $self->explain->jit( Pg::Explain::JIT->new( 'struct' => $struct->{ 'JIT' } ) ) if $struct->{ 'JIT' };
121              
122 74 100       260 $self->explain->query( $struct->{ 'Query Text' } ) if $struct->{ 'Query Text' };
123              
124 74 100 100     261 $self->explain->settings( $struct->{ 'Settings' } ) if ( $struct->{ 'Settings' } ) && ( 0 < scalar keys %{ $struct->{ 'Settings' } } );
  3         18  
125              
126 74         874 return $top_node;
127             }
128              
129             =head1 AUTHOR
130              
131             hubert depesz lubaczewski, C<< >>
132              
133             =head1 BUGS
134              
135             Please report any bugs or feature requests to C.
136              
137             =head1 SUPPORT
138              
139             You can find documentation for this module with the perldoc command.
140              
141             perldoc Pg::Explain
142              
143             =head1 COPYRIGHT & LICENSE
144              
145             Copyright 2008-2021 hubert depesz lubaczewski, all rights reserved.
146              
147             This program is free software; you can redistribute it and/or modify it
148             under the same terms as Perl itself.
149              
150             =cut
151              
152             1; # End of Pg::Explain::FromJSON