File Coverage

blib/lib/Pg/Explain/FromText.pm
Criterion Covered Total %
statement 211 216 97.6
branch 98 110 89.0
condition 3 3 100.0
subroutine 18 18 100.0
pod 4 4 100.0
total 334 351 95.1


line stmt bran cond sub pod time code
1             package Pg::Explain::FromText;
2              
3             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
4 74     74   949 use v5.18;
  74         252  
5 74     74   393 use strict;
  74         154  
  74         1498  
6 74     74   341 use warnings;
  74         151  
  74         2082  
7 74     74   367 use warnings qw( FATAL utf8 );
  74         140  
  74         2159  
8 74     74   370 use utf8;
  74         137  
  74         364  
9 74     74   1838 use open qw( :std :utf8 );
  74         134  
  74         341  
10 74     74   9358 use Unicode::Normalize qw( NFC );
  74         148  
  74         3285  
11 74     74   417 use Unicode::Collate;
  74         151  
  74         1698  
12 74     74   349 use Encode qw( decode );
  74         141  
  74         2904  
13 74     74   33990 use English qw( -no_match_vars );
  74         250748  
  74         408  
14              
15             if ( grep /\P{ASCII}/ => @ARGV ) {
16             @ARGV = map { decode( 'UTF-8', $_ ) } @ARGV;
17             }
18              
19             # UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
20              
21 74     74   43615 use Carp;
  74         162  
  74         4154  
22 74     74   40867 use Pg::Explain::Node;
  74         195  
  74         3217  
23 74     74   34033 use Pg::Explain::Buffers;
  74         193  
  74         2570  
24 74     74   33546 use Pg::Explain::JIT;
  74         209  
  74         230952  
25              
26             =head1 NAME
27              
28             Pg::Explain::FromText - Parser for text based explains
29              
30             =head1 VERSION
31              
32             Version 2.4
33              
34             =cut
35              
36             our $VERSION = '2.4';
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 new
45              
46             Object constructor.
47              
48             This is not really useful in this particular class, but it's to have the same API for all Pg::Explain::From* classes.
49              
50             =cut
51              
52             sub new {
53 301     301 1 689 my $class = shift;
54 301         763 my $self = bless {}, $class;
55 301         781 return $self;
56             }
57              
58             =head2 explain
59              
60             Get/Set master explain object.
61              
62             =cut
63              
64 1580 100   1580 1 2614 sub explain { my $self = shift; $self->{ 'explain' } = $_[ 0 ] if 0 < scalar @_; return $self->{ 'explain' }; }
  1580         4107  
  1580         5171  
65              
66             =head2 split_into_lines
67              
68             Splits source into lines, while fixing (well, trying to fix) cases where input has been force-wrapped to some length.
69              
70             =cut
71              
72             sub split_into_lines {
73 301     301 1 544 my $self = shift;
74 301         521 my $source = shift;
75              
76 301         4951 my @lines = split /\r?\n/, $source;
77              
78 301         810 my @out = ();
79 301         728 for my $l ( @lines ) {
80              
81             # Ignore certain lines
82 2396 100       6118 next if $l =~ m{\A \s* \( \d+ \s+ rows? \) \s* \z}xms;
83 2395 50       6857 next if $l =~ m{\A \s* query \s plan \s* \z}xmsi;
84 2395 100       8727 next if $l =~ m{\A \s* (?: -+ | ─+ ) \s* \z}xms;
85              
86 2393 100       8347 if ( $l =~ m{ \A Trigger \s+ }xms ) {
    100          
    100          
87 18         33 push @out, $l;
88             }
89             elsif ( $l =~ m{ \A (?: Total \s+ runtime | Planning \s+ time | Execution \s+ time | Time | Filter | Output | JIT | Planning | Settings | Query \s+ Identifier ): }xmsi ) {
90 167         392 push @out, $l;
91             }
92             elsif ( $l =~ m{\A\S} ) {
93 231 100       644 if ( 0 < scalar @out ) {
94 26         97 $out[ -1 ] .= $l;
95             }
96             else {
97 205         540 push @out, $l;
98             }
99             }
100             else {
101 1977         4210 push @out, $l;
102             }
103             }
104              
105 301         1409 return @out;
106             }
107              
108             =head2 parse_source
109              
110             Function which parses actual plan, and constructs Pg::Explain::Node objects
111             which represent it.
112              
113             Returns Top node of query plan.
114              
115             =cut
116              
117             sub parse_source {
118 301     301 1 561 my $self = shift;
119 301         553 my $source = shift;
120              
121             # Store jit text info, and flag whether we're in JIT parsing phase
122 301         541 my $jit = undef;
123 301         523 my $in_jit = undef;
124              
125             # Store information about planning buffers
126 301         480 my $planning_buffers = undef;
127 301         518 my $in_planning = undef;
128              
129 301         502 my $top_node = undef;
130 301         609 my %element_at_depth = (); # element is hashref, contains 2 keys: node (Pg::Explain::Node) and subelement-type, which can be: subnode, initplan or subplan.
131              
132 301         943 my @lines = $self->split_into_lines( $source );
133              
134 301         1489 my $costs_re = qr{ \( cost=(?\d+\.\d+)\.\.(?\d+\.\d+) \s+ rows=(?\d+) \s+ width=(?\d+) \) }xms;
135 301         1050 my $analyze_re = qr{ \(
136             (?:
137             actual \s time=(?\d+\.\d+)\.\.(?\d+\.\d+) \s rows=(?\d+) \s loops=(?\d+)
138             |
139             actual \s rows=(?\d+) \s loops=(?\d+)
140             |
141             (? never \s+ executed )
142             )
143             \) }xms;
144              
145 301         836 my $guc_name = qr{ [a-zA-Z_.]+ }xms;
146 301         855 my $guc_value = qr{ ' (?:[^']+|'' )* ' }xms;
147 301         4976 my $single_guc = qr{ ( $guc_name ) \s* = \s* ( $guc_value ) }xms;
148 301         4660 my $multiple_gucs = qr{ $single_guc (?: , \s* $single_guc )* }xms;
149              
150 301         732 my $query = '';
151 301         588 my $plan_started = 0;
152             LINE:
153 301         669 for my $line ( @lines ) {
154              
155             # Remove trailing whitespace - it makes next line matches MUCH faster.
156 2367         12730 $line =~ s/\s+\z//;
157              
158             # There could be stray " at the end. No idea why, but some people paste such explains on explain.depesz.com
159 2367         5642 $line =~ s/\s*"\z//;
160              
161             # Replace tabs with 4 spaces
162 2367         4810 $line =~ s/\t/ /g;
163              
164 2367 100 100     63151 if (
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
165             ( $line =~ m{\(} )
166             && (
167             $line =~ m{
168             \A
169             (?\s* -> \s* | \s* )
170             (?\S.*?)
171             \s+
172             (?:
173             $costs_re \s+ $analyze_re
174             |
175             $costs_re
176             |
177             $analyze_re
178             )
179             \s*
180             \z
181             }xms
182             )
183             )
184             {
185 975         2055 $plan_started = 1;
186              
187 975         16505 my $new_node = Pg::Explain::Node->new( %+ );
188 975         4823 $new_node->explain( $self->explain );
189 975 100       5155 if ( defined $+{ 'never_executed' } ) {
190 22         74 $new_node->actual_loops( 0 );
191 22         55 $new_node->never_executed( 1 );
192             }
193 975         3543 my $element = { 'node' => $new_node, 'subelement-type' => 'subnode', };
194              
195 975         1639 $in_jit = undef;
196              
197 975         3680 my $prefix = $+{ 'prefix' };
198 975         5111 $prefix =~ s/->.*//;
199 975         2395 my $prefix_length = length $prefix;
200              
201 975 100       2610 if ( 0 == scalar keys %element_at_depth ) {
202 301         669 $element_at_depth{ '0' } = $element;
203 301         536 $top_node = $new_node;
204 301         1238 next LINE;
205             }
206 674         2531 my @existing_depths = sort { $a <=> $b } keys %element_at_depth;
  2869         5271  
207 674         1626 for my $key ( grep { $_ >= $prefix_length } @existing_depths ) {
  2218         4483  
208 321         884 delete $element_at_depth{ $key };
209             }
210              
211 674         1836 my $maximal_depth = ( sort { $b <=> $a } keys %element_at_depth )[ 0 ];
  2123         3230  
212 674 50       1668 if ( !defined $maximal_depth ) {
213 0         0 croak( "Didn't find current_element by depth - this shouldn't happen - please contact author.\n" );
214             }
215 674         1154 my $previous_element = $element_at_depth{ $maximal_depth };
216              
217 674         1605 $element_at_depth{ $prefix_length } = $element;
218              
219 674 100       2044 if ( $previous_element->{ 'subelement-type' } eq 'subnode' ) {
    100          
    100          
    50          
220 588         1913 $previous_element->{ 'node' }->add_sub_node( $new_node );
221             }
222             elsif ( $previous_element->{ 'subelement-type' } eq 'initplan' ) {
223 31         132 $previous_element->{ 'node' }->add_initplan( $new_node, $previous_element->{ 'metainfo' } );
224             }
225             elsif ( $previous_element->{ 'subelement-type' } eq 'subplan' ) {
226 32         137 $previous_element->{ 'node' }->add_subplan( $new_node );
227             }
228             elsif ( $previous_element->{ 'subelement-type' } =~ /^cte:(.+)$/ ) {
229 23         203 $previous_element->{ 'node' }->add_cte( $1, $new_node );
230 23         114 delete $element_at_depth{ $maximal_depth };
231             }
232             else {
233 0         0 croak( "Bad subelement-type in previous_element - this shouldn't happen - please contact author.\n" );
234             }
235             }
236             elsif ( $line =~ m{ \A (\s*) InitPlan \s* ( \d+ )? \s* (?: \( returns \s+ (.*) \) \s* )? \z }xms ) {
237 29         167 my ( $prefix, $name, $returns ) = ( $1, $2, $3 );
238 29         57 $in_jit = undef;
239              
240 29         91 my @remove_elements = grep { $_ >= length $prefix } keys %element_at_depth;
  63         190  
241 29 100       105 delete @element_at_depth{ @remove_elements } unless 0 == scalar @remove_elements;
242              
243 29         108 my $maximal_depth = ( sort { $b <=> $a } keys %element_at_depth )[ 0 ];
  60         92  
244 29 50       86 if ( !defined $maximal_depth ) {
245 0         0 croak( "Didn't find current_element by depth - this shouldn't happen - please contact author (subplan).\n" );
246             }
247 29         62 my $previous_element = $element_at_depth{ $maximal_depth };
248              
249 29         56 my $metainfo = {};
250 29 100       96 $metainfo->{ 'name' } = $name if defined $name;
251 29 100       144 $metainfo->{ 'returns' } = $returns if defined $returns;
252 29 100       61 $metainfo = undef if 0 == scalar keys %{ $metainfo };
  29         128  
253              
254             $element_at_depth{ 1 + length $prefix } = {
255 29         187 'node' => $previous_element->{ 'node' },
256             'subelement-type' => 'initplan',
257             'metainfo' => $metainfo,
258             };
259 29         114 next LINE;
260             }
261             elsif ( $line =~ m{ \A (\s*) SubPlan \s* (?: \d+ \s* )? \s* (?: \( returns .* \) \s* )? \z }xms ) {
262 28         91 my $prefix = $1;
263              
264 28         52 $in_jit = undef;
265              
266 28         78 my @remove_elements = grep { $_ >= length $prefix } keys %element_at_depth;
  82         224  
267 28 100       143 delete @element_at_depth{ @remove_elements } unless 0 == scalar @remove_elements;
268              
269 28         93 my $maximal_depth = ( sort { $b <=> $a } keys %element_at_depth )[ 0 ];
  34         63  
270 28 50       82 if ( !defined $maximal_depth ) {
271 0         0 croak( "Didn't find current_element by depth - this shouldn't happen - please contact author (subplan).\n" );
272             }
273 28         66 my $previous_element = $element_at_depth{ $maximal_depth };
274              
275             $element_at_depth{ 1 + length $prefix } = {
276 28         142 'node' => $previous_element->{ 'node' },
277             'subelement-type' => 'subplan',
278             };
279 28         105 next LINE;
280             }
281             elsif ( $line =~ m{ \A (\s*) CTE \s+ (\S+) \s* \z }xms ) {
282 23         105 my ( $prefix, $cte_name ) = ( $1, $2 );
283              
284 23         46 $in_jit = undef;
285              
286 23         64 my @remove_elements = grep { $_ >= length $prefix } keys %element_at_depth;
  32         123  
287 23 100       92 delete @element_at_depth{ @remove_elements } unless 0 == scalar @remove_elements;
288              
289 23         81 my $maximal_depth = ( sort { $b <=> $a } keys %element_at_depth )[ 0 ];
  4         9  
290 23 50       72 if ( !defined $maximal_depth ) {
291 0         0 croak( "Didn't find current_element by depth - this shouldn't happen - please contact author (CTE).\n" );
292             }
293 23         50 my $previous_element = $element_at_depth{ $maximal_depth };
294              
295             $element_at_depth{ length $prefix } = {
296 23         128 'node' => $previous_element->{ 'node' },
297             'subelement-type' => 'cte:' . $cte_name,
298             };
299              
300 23         122 next LINE;
301             }
302             elsif ( $line =~ m{ \A \s* (Planning|Execution) \s+ time: \s+ (\d+\.\d+) \s+ ms \s* \z }xmsi ) {
303 178         607 my ( $type, $time ) = ( $1, $2 );
304              
305 178         319 $in_jit = undef;
306              
307 178 100       710 $self->explain->planning_time( $time ) if 'planning' eq lc( $type );
308 178 100       667 $self->explain->execution_time( $time ) if 'execution' eq lc( $type );
309             }
310             elsif ( $line =~ m{ \A \s* Total \s+ runtime: \s+ (\d+\.\d+) \s+ ms \s* \z }xmsi ) {
311 52         193 my ( $time ) = ( $1 );
312              
313 52         107 $in_jit = undef;
314              
315 52         151 $self->explain->total_runtime( $time );
316             }
317             elsif ( $line =~ m{ \A \s* Settings: \s* ( $multiple_gucs ) \s* \z }xmsi ) {
318 3         13 my $gucs = $1;
319 3         8 my $settings = {};
320 3         92 my @elements = $gucs =~ m{ $single_guc }xmsg;
321 3         21 for ( my $i = 0 ; $i < @elements ; $i += 2 ) {
322 5         14 my $val = $elements[ $i + 1 ];
323 5         26 $val =~ s/\A'|'\z//g;
324 5         16 $val =~ s/''/'/g;
325 5         24 $settings->{ $elements[ $i ] } = $val;
326             }
327 3 50       8 $self->explain->settings( $settings ) if 0 < scalar keys %{ $settings };
  3         16  
328             }
329             elsif ( $line =~ m{ \A \s* Trigger \s+ (.*) : \s+ time=(\d+\.\d+) \s+ calls=(\d+) \s* \z }xmsi ) {
330 20         78 my ( $name, $time, $calls ) = ( $1, $2, $3 );
331              
332 20         34 $in_jit = undef;
333              
334 20         39 $self->explain->add_trigger_time(
335             {
336             'name' => $name,
337             'time' => $time,
338             'calls' => $calls,
339             }
340             );
341             }
342             elsif ( $line =~ m{ \A (\s*) JIT: \s* \z }xmsi ) {
343 6         24 $in_jit = 1;
344 6         29 $jit = [ $line ];
345             }
346             elsif ( $line =~ m{ \A (\s*) Planning: \s* \z }xmsi ) {
347 11         38 $in_planning = 1;
348             }
349             elsif ( $line =~ m{ \A \s* Query \s+ Text: \s+ ( .* ) \z }xms ) {
350 4         17 $query = $1;
351 4         15 $plan_started = 0;
352             }
353             elsif ( $plan_started == 0 ) {
354 34         181 $query = "$query\n$line";
355             }
356             elsif ( $line =~ m{ \A (\s*) ( \S .* \S ) \s* \z }xms ) {
357 999         4125 my ( $infoprefix, $info ) = ( $1, $2 );
358 999 100       2147 if ( $in_jit ) {
359 18         36 push @{ $jit }, $line;
  18         35  
360 18         42 next LINE;
361             }
362 981         2454 my $maximal_depth = ( sort { $b <=> $a } grep { $_ < length $infoprefix } keys %element_at_depth )[ 0 ];
  3220         4742  
  2872         8117  
363 981 100       2471 next LINE unless defined $maximal_depth;
364 976         1704 my $previous_element = $element_at_depth{ $maximal_depth };
365 976 50       2026 next LINE unless $previous_element;
366 976         1535 my $node = $previous_element->{ 'node' };
367 976 100       5249 if ( $info =~ m{ \A Workers \s+ Launched: \s+ ( \d+ ) \z }xmsi ) {
    100          
    100          
368 16         92 $node->workers_launched( $1 );
369 16         63 $node->add_extra_info( $info );
370             }
371             elsif ( $info =~ m{ \A Buffers: \s }xms ) {
372 98         173 eval {
373 98         403 my $buffers = Pg::Explain::Buffers->new( $info );
374 98 100       289 if ( $in_planning ) {
375 11         28 $planning_buffers = $buffers;
376             }
377             else {
378 87         256 $node->buffers( $buffers );
379             }
380             };
381 98 50       331 $node->add_extra_info( $info ) if $EVAL_ERROR;
382             }
383             elsif ( $info =~ m{ \A I/O \s Timings: \s }xms ) {
384 26         52 eval {
385 26 100       49 if ( $in_planning ) {
386 8 50       29 $planning_buffers->add_timing( $info ) if $planning_buffers;
387             }
388             else {
389 18 50       57 $node->buffers->add_timing( $info ) if $node->buffers;
390             }
391             };
392 26 50       114 $node->add_extra_info( $info ) if $EVAL_ERROR;
393             }
394             else {
395 836         2523 $node->add_extra_info( $info );
396             }
397             }
398             }
399 301 100       861 $self->explain->jit( Pg::Explain::JIT->new( 'lines' => $jit ) ) if defined $jit;
400 301 100       823 $self->explain->query( $query ) if $query;
401 301 100       764 $self->explain->planning_buffers( $planning_buffers ) if $planning_buffers;
402 301         2528 return $top_node;
403             }
404              
405             =head1 AUTHOR
406              
407             hubert depesz lubaczewski, C<< >>
408              
409             =head1 BUGS
410              
411             Please report any bugs or feature requests to C.
412              
413             =head1 SUPPORT
414              
415             You can find documentation for this module with the perldoc command.
416              
417             perldoc Pg::Explain
418              
419             =head1 COPYRIGHT & LICENSE
420              
421             Copyright 2008-2021 hubert depesz lubaczewski, all rights reserved.
422              
423             This program is free software; you can redistribute it and/or modify it
424             under the same terms as Perl itself.
425              
426             =cut
427              
428             1; # End of Pg::Explain::FromText