line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Pg::Explain::Buffers; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/ |
4
|
73
|
|
|
73
|
|
70141
|
use v5.18; |
|
73
|
|
|
|
|
301
|
|
5
|
73
|
|
|
73
|
|
403
|
use strict; |
|
73
|
|
|
|
|
137
|
|
|
73
|
|
|
|
|
1845
|
|
6
|
73
|
|
|
73
|
|
325
|
use warnings; |
|
73
|
|
|
|
|
128
|
|
|
73
|
|
|
|
|
1976
|
|
7
|
73
|
|
|
73
|
|
310
|
use warnings qw( FATAL utf8 ); |
|
73
|
|
|
|
|
115
|
|
|
73
|
|
|
|
|
1999
|
|
8
|
73
|
|
|
73
|
|
878
|
use utf8; |
|
73
|
|
|
|
|
137
|
|
|
73
|
|
|
|
|
363
|
|
9
|
73
|
|
|
73
|
|
2028
|
use open qw( :std :utf8 ); |
|
73
|
|
|
|
|
1194
|
|
|
73
|
|
|
|
|
359
|
|
10
|
73
|
|
|
73
|
|
9282
|
use Unicode::Normalize qw( NFC ); |
|
73
|
|
|
|
|
2117
|
|
|
73
|
|
|
|
|
3417
|
|
11
|
73
|
|
|
73
|
|
1057
|
use Unicode::Collate; |
|
73
|
|
|
|
|
7788
|
|
|
73
|
|
|
|
|
1974
|
|
12
|
73
|
|
|
73
|
|
912
|
use Encode qw( decode ); |
|
73
|
|
|
|
|
9079
|
|
|
73
|
|
|
|
|
3770
|
|
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
6
|
if ( grep /\P{ASCII}/ => @ARGV ) { |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
13
|
|
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
|
|
32446
|
use Carp; |
|
73
|
|
|
|
|
143
|
|
|
73
|
|
|
|
|
5673
|
|
21
|
73
|
|
|
73
|
|
794
|
use Clone qw( clone ); |
|
73
|
|
|
|
|
3339
|
|
|
73
|
|
|
|
|
3974
|
|
22
|
73
|
|
|
73
|
|
850
|
use autodie; |
|
73
|
|
|
|
|
19070
|
|
|
73
|
|
|
|
|
458
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
use overload |
25
|
73
|
|
|
|
|
834
|
'+' => \&_buffers_add, |
26
|
|
|
|
|
|
|
'-' => \&_buffers_subtract, |
27
|
73
|
|
|
73
|
|
336310
|
'bool' => \&_buffers_bool; |
|
73
|
|
|
|
|
12561
|
|
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 NAME |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
Pg::Explain::Buffers - Object to store buffers information about node in PostgreSQL's explain analyze |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 VERSION |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
Version 2.2 |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=cut |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
our $VERSION = '2.2'; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 SYNOPSIS |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Quick summary of what the module does. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
Perhaps a little code snippet. |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
use Pg::Explain; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
my $explain = Pg::Explain->new('source_file' => 'some_file.out'); |
50
|
|
|
|
|
|
|
... |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
if ( $explain->top_node->buffers ) { |
53
|
|
|
|
|
|
|
print $explain->top_node->buffers->as_text(); |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
... |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
Alternatively you can build the object itself from either a string (conforming |
58
|
|
|
|
|
|
|
to text version of EXPLAIN ANALYZE output) or a structure, containing keys like |
59
|
|
|
|
|
|
|
in JSON/YAML/XML formats of the explain: |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
use Pg::Explain::Buffers; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
my $from_string = Pg::Explain::Buffers->new( 'Buffers: shared hit=12101 read=73' ); |
64
|
|
|
|
|
|
|
my $from_struct = Pg::Explain::Buffers->new( { |
65
|
|
|
|
|
|
|
'Shared Hit Blocks' => 12101, |
66
|
|
|
|
|
|
|
'Shared Read Blocks' => 73, |
67
|
|
|
|
|
|
|
} ); |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
To such object you can later on add Timing information, though only with |
70
|
|
|
|
|
|
|
string - if you had it in struct, make it available on creation. |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
$buffers->add_timing( 'I/O Timings: read=58.316 write=1.672' ); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
=head1 FUNCTIONS |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head2 new |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
Object constructor. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Takes one argument, either a string or hashref to build data from. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=cut |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub new { |
85
|
687
|
|
|
687
|
1
|
1820
|
my $class = shift; |
86
|
687
|
|
|
|
|
1281
|
my $self = bless {}, $class; |
87
|
687
|
50
|
|
|
|
1398
|
croak( 'You have to provide base info.' ) if 0 == scalar @_; |
88
|
687
|
50
|
|
|
|
1259
|
croak( 'Too many arguments to Pg::Explain::Buffers->new().' ) if 1 < scalar @_; |
89
|
687
|
|
|
|
|
866
|
my $arg = shift; |
90
|
687
|
100
|
|
|
|
1471
|
if ( 'HASH' eq ref $arg ) { |
|
|
50
|
|
|
|
|
|
91
|
571
|
|
|
|
|
1351
|
$self->_build_from_struct( $arg ); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
elsif ( '' eq ref $arg ) { |
94
|
116
|
|
|
|
|
256
|
$self->_build_from_string( $arg ); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
else { |
97
|
0
|
|
|
|
|
0
|
croak( "Don't know how to build Pg::Explain::Buffers using " . ref( $arg ) ); |
98
|
|
|
|
|
|
|
} |
99
|
687
|
|
|
|
|
1405
|
return $self; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=head2 add_timing |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
Adds timing information to existing buffer info. |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
Takes one argument, either a string or hashref to build data from. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
=cut |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub add_timing { |
111
|
28
|
|
|
28
|
1
|
44
|
my $self = shift; |
112
|
28
|
50
|
|
|
|
58
|
croak( 'You have to provide base info.' ) if 0 == scalar @_; |
113
|
28
|
50
|
|
|
|
51
|
croak( 'Too many arguments to Pg::Explain::Buffers->new().' ) if 1 < scalar @_; |
114
|
28
|
|
|
|
|
38
|
my $arg = shift; |
115
|
28
|
50
|
|
|
|
57
|
croak( "Don't know how to add timing info in Pg::Explain::Buffers using " . ref( $arg ) ) unless '' eq ref( $arg ); |
116
|
28
|
50
|
|
|
|
154
|
croak( "Invalid format of I/O Timing info: $arg" ) unless $arg =~ m{ |
117
|
|
|
|
|
|
|
\A |
118
|
|
|
|
|
|
|
\s* |
119
|
|
|
|
|
|
|
I/O \s Timings: |
120
|
|
|
|
|
|
|
( |
121
|
|
|
|
|
|
|
\s+ |
122
|
|
|
|
|
|
|
(?: read | write ) |
123
|
|
|
|
|
|
|
= |
124
|
|
|
|
|
|
|
\d+\.\d+ |
125
|
|
|
|
|
|
|
)+ |
126
|
|
|
|
|
|
|
\s* |
127
|
|
|
|
|
|
|
\z |
128
|
|
|
|
|
|
|
}xms; |
129
|
|
|
|
|
|
|
|
130
|
28
|
|
|
|
|
151
|
my @matching = $arg =~ m{ (read|write) = (\d+\.\d+) }xg; |
131
|
28
|
50
|
|
|
|
75
|
return if 0 == scalar @matching; |
132
|
28
|
|
|
|
|
77
|
my %matching = @matching; |
133
|
28
|
|
|
|
|
52
|
for my $key ( qw( read write ) ) { |
134
|
56
|
100
|
|
|
|
140
|
next unless my $val = $matching{ $key }; |
135
|
33
|
|
|
|
|
80
|
$self->{ 'data' }->{ 'timings' }->{ $key } = $val; |
136
|
|
|
|
|
|
|
} |
137
|
28
|
|
|
|
|
81
|
return; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head2 as_text |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Returns text representation of stored buffers info, together with timings (if available). |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub as_text { |
147
|
83
|
|
|
83
|
1
|
111
|
my $self = shift; |
148
|
83
|
50
|
|
|
|
166
|
return unless $self->{ 'data' }; |
149
|
83
|
50
|
|
|
|
99
|
return if 0 == scalar keys %{ $self->{ 'data' } }; |
|
83
|
|
|
|
|
180
|
|
150
|
83
|
|
|
|
|
123
|
my @parts = (); |
151
|
83
|
|
|
|
|
135
|
for my $type ( qw( shared local temp ) ) { |
152
|
249
|
100
|
|
|
|
486
|
next unless my $x = $self->{ 'data' }->{ $type }; |
153
|
92
|
|
|
|
|
147
|
my @elements = map { $_ . '=' . $x->{ $_ } } grep { $x->{ $_ } } qw( hit read dirtied written ); |
|
119
|
|
|
|
|
293
|
|
|
368
|
|
|
|
|
548
|
|
154
|
92
|
50
|
|
|
|
177
|
next if 0 == scalar @elements; |
155
|
92
|
|
|
|
|
231
|
push @parts, join( ' ', $type, @elements ); |
156
|
|
|
|
|
|
|
} |
157
|
83
|
50
|
|
|
|
153
|
return if 0 == scalar @parts; |
158
|
83
|
|
|
|
|
233
|
my $ret = sprintf 'Buffers: %s', join( ', ', @parts ); |
159
|
83
|
100
|
|
|
|
261
|
return $ret unless my $T = $self->{ 'data' }->{ 'timings' }; |
160
|
16
|
|
|
|
|
24
|
my $timing = join ' ', map { $_ . '=' . $T->{ $_ } } grep { $T->{ $_ } } qw{ read write }; |
|
18
|
|
|
|
|
57
|
|
|
32
|
|
|
|
|
57
|
|
161
|
16
|
50
|
|
|
|
31
|
return $ret unless $timing; |
162
|
16
|
|
|
|
|
65
|
return $ret . "\nI/O Timings: " . $timing; |
163
|
|
|
|
|
|
|
} |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=head2 get_struct |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Returns hash(ref) with all data about buffers from this object. Keys in this hash: |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=over |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=item * shared (with subkeys: hit, read, dirtied, written) |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
=item * local (with subkeys: hit, read, dirtied, written) |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=item * temp (with subkeys: read, written) |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=item * timings (with subkeys: read, write |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=back |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
Only elements with non-zero values are returned. If there are no elements to be returned, it returns undef. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=cut |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub get_struct { |
186
|
105
|
|
|
105
|
1
|
159
|
my $self = shift; |
187
|
105
|
|
|
|
|
152
|
my $d = $self->{ 'data' }; |
188
|
105
|
|
|
|
|
545
|
my $map = { |
189
|
|
|
|
|
|
|
'shared' => [ qw{ hit read dirtied written } ], |
190
|
|
|
|
|
|
|
'local' => [ qw{ hit read dirtied written } ], |
191
|
|
|
|
|
|
|
'temp' => [ qw{ read written } ], |
192
|
|
|
|
|
|
|
'timings' => [ qw{ read write } ], |
193
|
|
|
|
|
|
|
}; |
194
|
105
|
|
|
|
|
170
|
my $ret = {}; |
195
|
105
|
|
|
|
|
135
|
while ( my ( $type, $subtypes ) = each %{ $map } ) { |
|
525
|
|
|
|
|
1156
|
|
196
|
420
|
100
|
|
|
|
854
|
next unless defined( my $t = $self->{ 'data' }->{ $type } ); |
197
|
142
|
|
|
|
|
158
|
for my $subtype ( @{ $subtypes } ) { |
|
142
|
|
|
|
|
220
|
|
198
|
498
|
100
|
|
|
|
880
|
next unless defined( my $val = $t->{ $subtype } ); |
199
|
178
|
|
|
|
|
383
|
$ret->{ $type }->{ $subtype } = $val; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
} |
202
|
105
|
100
|
|
|
|
140
|
return if 0 == scalar keys %{ $ret }; |
|
105
|
|
|
|
|
219
|
|
203
|
104
|
|
|
|
|
371
|
return $ret; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=head2 data |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Accessor to internal data. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=cut |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub data { |
213
|
2210
|
|
|
2210
|
1
|
2390
|
my $self = shift; |
214
|
2210
|
100
|
|
|
|
3347
|
$self->{ 'data' } = $_[ 0 ] if 0 < scalar @_; |
215
|
2210
|
|
|
|
|
5538
|
return $self->{ 'data' }; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=head1 OPERATORS |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
To allow for easier work on buffer values + and - operators are overloaded, so you can: |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
$buffers_out = $buffers1 - $buffers2; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
While processing subtraction, it is important that it's not possible to get negative values, |
225
|
|
|
|
|
|
|
so if any value would drop below 0, it will get auto-adjusted to 0. |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=cut |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
=head1 INTERNAL METHODS |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head2 _build_from_struct |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
Gets data out of provided HASH. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
=cut |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub _build_from_struct { |
238
|
571
|
|
|
571
|
|
766
|
my $self = shift; |
239
|
571
|
|
|
|
|
715
|
my $in = shift; |
240
|
|
|
|
|
|
|
|
241
|
571
|
|
|
|
|
3493
|
my $map = { |
242
|
|
|
|
|
|
|
'shared' => [ qw{ hit read dirtied written } ], |
243
|
|
|
|
|
|
|
'local' => [ qw{ hit read dirtied written } ], |
244
|
|
|
|
|
|
|
'temp' => [ qw{ read written } ], |
245
|
|
|
|
|
|
|
'timings' => [ qw{ read write } ], |
246
|
|
|
|
|
|
|
}; |
247
|
|
|
|
|
|
|
|
248
|
571
|
|
|
|
|
939
|
while ( my ( $type, $subtypes ) = each %{ $map } ) { |
|
2855
|
|
|
|
|
6397
|
|
249
|
2284
|
100
|
|
|
|
3808
|
my $in_type = $type eq 'timings' ? 'I/O' : ucfirst( $type ); |
250
|
2284
|
100
|
|
|
|
3105
|
my $in_suffix = $type eq 'timings' ? 'Time' : 'Blocks'; |
251
|
2284
|
|
|
|
|
2387
|
for my $subtype ( @{ $subtypes } ) { |
|
2284
|
|
|
|
|
2914
|
|
252
|
6852
|
|
|
|
|
7690
|
my $in_subtype = ucfirst( $subtype ); |
253
|
6852
|
|
|
|
|
8844
|
my $in_key = join ' ', $in_type, $in_subtype, $in_suffix; |
254
|
6852
|
100
|
|
|
|
12613
|
next unless my $val = $in->{ $in_key }; |
255
|
165
|
100
|
|
|
|
332
|
next if 0 == $val; |
256
|
98
|
|
|
|
|
364
|
$self->{ 'data' }->{ $type }->{ $subtype } = $val; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
571
|
|
|
|
|
1638
|
return; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head2 _build_from_string |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
Gets data out of provided string. |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=cut |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
sub _build_from_string { |
270
|
116
|
|
|
116
|
|
154
|
my $self = shift; |
271
|
116
|
|
|
|
|
145
|
my $in = shift; |
272
|
116
|
|
|
|
|
317
|
my $single_type_re = qr{ |
273
|
|
|
|
|
|
|
(?: |
274
|
|
|
|
|
|
|
(?: shared | local ) |
275
|
|
|
|
|
|
|
(?: |
276
|
|
|
|
|
|
|
\s+ |
277
|
|
|
|
|
|
|
(?: hit | read | dirtied | written ) = [1-9]\d* |
278
|
|
|
|
|
|
|
)+ |
279
|
|
|
|
|
|
|
| |
280
|
|
|
|
|
|
|
temp |
281
|
|
|
|
|
|
|
(?: |
282
|
|
|
|
|
|
|
\s+ |
283
|
|
|
|
|
|
|
(?: read | written ) = [1-9]\d* |
284
|
|
|
|
|
|
|
)+ |
285
|
|
|
|
|
|
|
) |
286
|
|
|
|
|
|
|
}xms; |
287
|
116
|
50
|
|
|
|
2416
|
croak( 'Invalid format of string for Pg::Explain::Buffers: ' . $in ) unless $in =~ m{ |
288
|
|
|
|
|
|
|
\A |
289
|
|
|
|
|
|
|
\s* |
290
|
|
|
|
|
|
|
Buffers: |
291
|
|
|
|
|
|
|
\s+ |
292
|
|
|
|
|
|
|
( |
293
|
|
|
|
|
|
|
$single_type_re |
294
|
|
|
|
|
|
|
(?: |
295
|
|
|
|
|
|
|
, \s+ |
296
|
|
|
|
|
|
|
$single_type_re |
297
|
|
|
|
|
|
|
)* |
298
|
|
|
|
|
|
|
) |
299
|
|
|
|
|
|
|
\s* |
300
|
|
|
|
|
|
|
\z |
301
|
|
|
|
|
|
|
}xms; |
302
|
116
|
|
|
|
|
288
|
my $plain_info = $1; |
303
|
116
|
|
|
|
|
382
|
my @parts = split /,\s+/, $plain_info; |
304
|
116
|
|
|
|
|
461
|
$self->{ 'data' } = {}; |
305
|
|
|
|
|
|
|
|
306
|
116
|
|
|
|
|
205
|
for my $part ( @parts ) { |
307
|
129
|
|
|
|
|
365
|
my @words = split /\s+/, $part; |
308
|
129
|
|
|
|
|
213
|
my $type = shift @words; |
309
|
129
|
|
|
|
|
175
|
for my $word ( @words ) { |
310
|
159
|
|
|
|
|
401
|
my ( $op, $bufs ) = split /=/, $word; |
311
|
159
|
|
|
|
|
675
|
$self->{ 'data' }->{ $type }->{ $op } = $bufs; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
116
|
|
|
|
|
299
|
return; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
=head2 _buffers_add |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
Creates new Pg::Explain::Buffers object by adding values based on two objects. To be used like: |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
my $result = $buffers1 + $buffers2; |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
=cut |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
sub _buffers_add { |
327
|
8
|
|
|
8
|
|
20
|
my ( $left, $right ) = @_; |
328
|
8
|
50
|
|
|
|
26
|
return unless 'Pg::Explain::Buffers' eq ref $left; |
329
|
8
|
50
|
|
|
|
21
|
unless ( 'Pg::Explain::Buffers' eq ref $right ) { |
330
|
0
|
0
|
|
|
|
0
|
return if defined $right; |
331
|
0
|
|
|
|
|
0
|
my $res = Pg::Explain::Buffers->new( {} ); |
332
|
0
|
|
|
|
|
0
|
$res->data( clone( $left->data ) ); |
333
|
0
|
|
|
|
|
0
|
return $res; |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
8
|
|
|
|
|
18
|
my $D = {}; |
337
|
8
|
|
|
|
|
53
|
my $map = { |
338
|
|
|
|
|
|
|
'shared' => [ qw{ hit read dirtied written } ], |
339
|
|
|
|
|
|
|
'local' => [ qw{ hit read dirtied written } ], |
340
|
|
|
|
|
|
|
'temp' => [ qw{ read written } ], |
341
|
|
|
|
|
|
|
'timings' => [ qw{ read write } ], |
342
|
|
|
|
|
|
|
}; |
343
|
|
|
|
|
|
|
|
344
|
8
|
50
|
|
|
|
20
|
my $L = $left->data ? clone( $left->data ) : {}; |
345
|
8
|
100
|
|
|
|
29
|
my $R = $right->data ? clone( $right->data ) : {}; |
346
|
8
|
|
|
|
|
19
|
while ( my ( $type, $subtypes ) = each %{ $map } ) { |
|
40
|
|
|
|
|
96
|
|
347
|
32
|
|
|
|
|
37
|
for my $subtype ( @{ $subtypes } ) { |
|
32
|
|
|
|
|
41
|
|
348
|
96
|
|
100
|
|
|
304
|
my $val = ( $L->{ $type }->{ $subtype } // 0 ) + ( $R->{ $type }->{ $subtype } // 0 ); |
|
|
|
100
|
|
|
|
|
349
|
96
|
100
|
|
|
|
159
|
next if $val <= 0; |
350
|
22
|
|
|
|
|
38
|
$D->{ $type }->{ $subtype } = $val; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
8
|
50
|
|
|
|
13
|
return if 0 == scalar keys %{ $D }; |
|
8
|
|
|
|
|
32
|
|
354
|
|
|
|
|
|
|
|
355
|
8
|
|
|
|
|
31
|
my $ret = Pg::Explain::Buffers->new( {} ); |
356
|
8
|
|
|
|
|
34
|
$ret->data( $D ); |
357
|
8
|
|
|
|
|
52
|
return $ret; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=head2 _buffers_subtract |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
Creates new Pg::Explain::Buffers object by subtracting values based on two objects. To be used like: |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
my $result = $buffers1 - $buffers2; |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
=cut |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
sub _buffers_subtract { |
369
|
8
|
|
|
8
|
|
20
|
my ( $left, $right ) = @_; |
370
|
8
|
50
|
|
|
|
30
|
return unless 'Pg::Explain::Buffers' eq ref $left; |
371
|
8
|
50
|
|
|
|
20
|
return unless 'Pg::Explain::Buffers' eq ref $right; |
372
|
|
|
|
|
|
|
|
373
|
8
|
|
|
|
|
58
|
my $map = { |
374
|
|
|
|
|
|
|
'shared' => [ qw{ hit read dirtied written } ], |
375
|
|
|
|
|
|
|
'local' => [ qw{ hit read dirtied written } ], |
376
|
|
|
|
|
|
|
'temp' => [ qw{ read written } ], |
377
|
|
|
|
|
|
|
'timings' => [ qw{ read write } ], |
378
|
|
|
|
|
|
|
}; |
379
|
|
|
|
|
|
|
|
380
|
8
|
50
|
|
|
|
27
|
return unless $left->data; |
381
|
8
|
100
|
|
|
|
15
|
unless ( $right->data ) { |
382
|
1
|
|
|
|
|
3
|
my $res = Pg::Explain::Buffers->new( {} ); |
383
|
1
|
|
|
|
|
3
|
$res->data( clone( $left->data ) ); |
384
|
1
|
|
|
|
|
5
|
return $res; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
7
|
|
|
|
|
14
|
my $new_data = {}; |
388
|
7
|
|
|
|
|
12
|
while ( my ( $type, $subtypes ) = each %{ $map } ) { |
|
35
|
|
|
|
|
84
|
|
389
|
28
|
100
|
|
|
|
45
|
next unless my $L = $left->data->{ $type }; |
390
|
13
|
100
|
|
|
|
40
|
if ( my $R = $right->data->{ $type } ) { |
391
|
12
|
|
|
|
|
14
|
for my $subtype ( @{ $subtypes } ) { |
|
12
|
|
|
|
|
19
|
|
392
|
40
|
|
100
|
|
|
165
|
my $val = ( $L->{ $subtype } // 0 ) - ( $R->{ $subtype } // 0 ); |
|
|
|
100
|
|
|
|
|
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
# Weirdish comparison to get rid of floating point arithmetic errors, like: |
395
|
|
|
|
|
|
|
# 32.874 - 18.153 - 14.721 => 3.5527136788005e-15 |
396
|
40
|
100
|
|
|
|
95
|
next if $val <= 0.00001; |
397
|
4
|
|
|
|
|
10
|
$new_data->{ $type }->{ $subtype } = $val; |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
else { |
401
|
1
|
|
|
|
|
11
|
$new_data->{ $type } = clone( $L ); |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
} |
404
|
7
|
100
|
|
|
|
11
|
return if 0 == scalar keys %{ $new_data }; |
|
7
|
|
|
|
|
47
|
|
405
|
|
|
|
|
|
|
|
406
|
4
|
|
|
|
|
14
|
my $ret = Pg::Explain::Buffers->new( {} ); |
407
|
4
|
|
|
|
|
10
|
$ret->data( $new_data ); |
408
|
4
|
|
|
|
|
22
|
return $ret; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=head2 _buffers_bool |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
For checking if given variable is set, as in: |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
$r = $buffers1 - $buffers2; |
416
|
|
|
|
|
|
|
if ( $r ) {...} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=cut |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
sub _buffers_bool { |
421
|
1534
|
|
|
1534
|
|
2052
|
my $self = shift; |
422
|
1534
|
100
|
|
|
|
2511
|
return unless $self->data; |
423
|
566
|
|
|
|
|
643
|
return 0 < scalar keys %{ $self->data }; |
|
566
|
|
|
|
|
746
|
|
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=head1 AUTHOR |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
hubert depesz lubaczewski, C<< >> |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=head1 BUGS |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
Please report any bugs or feature requests to C. |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=head1 SUPPORT |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
perldoc Pg::Explain::Buffers |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
Copyright 2008-2021 hubert depesz lubaczewski, all rights reserved. |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
445
|
|
|
|
|
|
|
under the same terms as Perl itself. |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
=cut |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
1; # End of Pg::Explain::Buffers |