File Coverage

blib/lib/Pg/Explain/Buffers.pm

Criterion	Covered	Total	%
statement	209	214	97.6
branch	79	106	74.5
condition	12	12	100.0
subroutine	24	24	100.0
pod	5	5	100.0
total	329	361	91.1

package Pg::Explain::Buffers;

# UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/
use v5.18;
use strict;
use warnings;
use warnings qw( FATAL utf8 );
use utf8;
use open qw( :std :utf8 );
use Unicode::Normalize qw( NFC );
use Unicode::Collate;
use Encode qw( decode );

if ( grep /\P{ASCII}/ => @ARGV ) {
    @ARGV = map { decode( 'UTF-8', $_ ) } @ARGV;
}

# UTF8 boilerplace, per http://stackoverflow.com/questions/6162484/why-does-modern-perl-avoid-utf-8-by-default/

use Carp;
use Clone qw( clone );
use autodie;

use overload
    '+'    => \&_buffers_add,
    '-'    => \&_buffers_subtract,
    'bool' => \&_buffers_bool;

=head1 NAME

Pg::Explain::Buffers - Object to store buffers information about node in PostgreSQL's explain analyze

=head1 VERSION

Version 2.9

=cut

our $VERSION = '2.9';

=head1 SYNOPSIS

Quick summary of what the module does.

Perhaps a little code snippet.

    use Pg::Explain;

    my $explain = Pg::Explain->new('source_file' => 'some_file.out');
    ...

    if ( $explain->top_node->buffers ) {
        print $explain->top_node->buffers->as_text();
    }
    ...

Alternatively you can build the object itself from either a string (conforming
to text version of EXPLAIN ANALYZE output) or a structure, containing keys like
in JSON/YAML/XML formats of the explain:

    use Pg::Explain::Buffers;

    my $from_string = Pg::Explain::Buffers->new( 'Buffers: shared hit=12101 read=73' );
    my $from_struct = Pg::Explain::Buffers->new( {
        'Shared Hit Blocks' => 12101,
        'Shared Read Blocks' => 73,
    } );

To such object you can later on add Timing information, though only with
string - if you had it in struct, make it available on creation.

    $buffers->add_timing( 'I/O Timings: read=58.316 write=1.672' );

=head1 FUNCTIONS

=head2 new

Object constructor.

Takes one argument, either a string or hashref to build data from.

=cut

sub new {
    my $class = shift;
    my $self  = bless {}, $class;
    croak( 'You have to provide base info.' )                     if 0 == scalar @_;
    croak( 'Too many arguments to Pg::Explain::Buffers->new().' ) if 1 < scalar @_;
    my $arg = shift;
    if ( 'HASH' eq ref $arg ) {
        $self->_build_from_struct( $arg );
    }
    elsif ( '' eq ref $arg ) {
        $self->_build_from_string( $arg );
    }
    else {
        croak( "Don't know how to build Pg::Explain::Buffers using " . ref( $arg ) );
    }
    return $self;
}

=head2 add_timing

Adds timing information to existing buffer info.

Takes one argument, either a string or hashref to build data from.

=cut

sub add_timing {
    my $self = shift;
    croak( 'You have to provide base info.' )                     if 0 == scalar @_;
    croak( 'Too many arguments to Pg::Explain::Buffers->new().' ) if 1 < scalar @_;
    my $arg = shift;
    croak( "Don't know how to add timing info in Pg::Explain::Buffers using " . ref( $arg ) ) unless '' eq ref( $arg );

    croak( "Invalid format of I/O Timing info: $arg" ) unless $arg =~ m{
        \A
        \s*
        I/O \s Timings:
        (
            (
                \s+
                (?: read | write )
                =
                \d+(\.\d+)?
            )+
            |
            \s+
            ( local | shared/local | shared | temp )
            (
                \s+
                (?: read | write )
                =
                \d+(\.\d+)?
            )+
            (
                , \s+
                ( local | shared/local | shared | temp )
                (
                    \s+
                    (?: read | write )
                    =
                    \d+(\.\d+)?
                )+
            )*
        )
        \s*
        \z
    }xms;

    my @matching = $arg =~ m{ (read|write) = (\d+(?:\.\d+)?) }xg;
    return if 0 == scalar @matching;

    $arg =~ s/\A\s*//;
    my $T = {
        'info' => $arg,
    };

    for ( my $i = 0 ; $i < scalar @matching ; $i += 2 ) {
        $T->{ $matching[ $i ] } += $matching[ $i + 1 ];
    }
    $self->{ 'data' }->{ 'timings' } = $T;
    return;
}

=head2 as_text

Returns text representation of stored buffers info, together with timings (if available).

=cut

sub as_text {
    my $self = shift;
    return unless $self->{ 'data' };
    return if 0 == scalar keys %{ $self->{ 'data' } };
    my @parts = ();
    for my $type ( qw( shared local temp ) ) {
        next unless my $x = $self->{ 'data' }->{ $type };
        my @elements = map { $_ . '=' . $x->{ $_ } } grep { $x->{ $_ } } qw( hit read dirtied written );
        next if 0 == scalar @elements;
        push @parts, join( ' ', $type, @elements );
    }
    return if 0 == scalar @parts;
    my $ret = sprintf 'Buffers: %s', join( ', ', @parts );
    return $ret unless my $T = $self->{ 'data' }->{ 'timings' };
    return $ret . "\n" . $T->{ 'info' };
}

=head2 get_struct

Returns hash(ref) with all data about buffers from this object. Keys in this hash:

=over

=item * shared (with subkeys: hit, read, dirtied, written)

=item * local (with subkeys: hit, read, dirtied, written)

=item * temp (with subkeys: read, written)

=item * timings (with subkeys: read, write, info)

=back

Only elements with non-zero values are returned. If there are no elements to be returned, it returns undef.

=cut

sub get_struct {
    my $self = shift;
    my $d    = $self->{ 'data' };
    my $map  = {
        'shared'  => [ qw{ hit read dirtied written } ],
        'local'   => [ qw{ hit read dirtied written } ],
        'temp'    => [ qw{ read written } ],
        'timings' => [ qw{ read write info } ],
    };
    my $ret = {};
    while ( my ( $type, $subtypes ) = each %{ $map } ) {
        next unless defined( my $t = $self->{ 'data' }->{ $type } );
        for my $subtype ( @{ $subtypes } ) {
            next unless defined( my $val = $t->{ $subtype } );
            $ret->{ $type }->{ $subtype } = $val;
        }
    }
    return if 0 == scalar keys %{ $ret };
    return $ret;
}

=head2 data

Accessor to internal data.

=cut

sub data {
    my $self = shift;
    $self->{ 'data' } = $_[ 0 ] if 0 < scalar @_;
    return $self->{ 'data' };
}

=head1 OPERATORS

To allow for easier work on buffer values + and - operators are overloaded, so you can:

    $buffers_out = $buffers1 - $buffers2;

While processing subtraction, it is important that it's not possible to get negative values,
so if any value would drop below 0, it will get auto-adjusted to 0.

=cut

=head1 INTERNAL METHODS

=head2 _build_from_struct

Gets data out of provided HASH.

=cut

sub _build_from_struct {
    my $self = shift;
    my $in   = shift;

    my $map = {
        'shared' => [ qw{ hit read dirtied written } ],
        'local'  => [ qw{ hit read dirtied written } ],
        'temp'   => [ qw{ read written } ],
    };

    while ( my ( $type, $subtypes ) = each %{ $map } ) {
        my $in_type   = $type eq 'timings' ? 'I/O'  : ucfirst( $type );
        my $in_suffix = $type eq 'timings' ? 'Time' : 'Blocks';
        for my $subtype ( @{ $subtypes } ) {
            my $in_subtype = ucfirst( $subtype );
            my $in_key     = join ' ', $in_type, $in_subtype, $in_suffix;
            next unless my $val = $in->{ $in_key };
            next if 0 == $val;
            $self->{ 'data' }->{ $type }->{ $subtype } = $val;
        }
    }

    # Timing information changes depending on version, so let's build it appropriately
    my $T = {};
    for my $key ( sort grep { m{I/O (?:Read|Write) Time$} } keys %{ $in } ) {
        next if $in->{ $key } == 0;
        if ( $key =~ /Read/ ) {
            $T->{ 'read' } += $in->{ $key };
        }
        else {
            $T->{ 'write' } += $in->{ $key };
        }
    }
    if ( 0 < scalar keys %{ $T } ) {
        $T->{ 'info' } = $self->_build_timing_info( $in );
        $self->{ 'data' }->{ 'timings' } = $T;
    }

    return;
}

=head2 _build_timing_info

Based on data from structure from json/yaml/xml, build I/O Timings: info line for textual representation of explain.

=cut

sub _build_timing_info {
    my $self = shift;
    my $in   = shift;

    my %parts = ();
    for my $type ( qw( old shared local temp ) ) {
        my @for_type    = ();
        my $type_prefix = $type eq 'old' ? '' : ( ucfirst( $type ) . ' ' );
        my $read_key    = $type_prefix . 'I/O Read Time';
        my $write_key   = $type_prefix . 'I/O Write Time';

        # +0 to make sure we're treating the thing as number, and not string
        # The key can be absent from input, or it can be there, but be as number, or as string.
        # The problem is that string '0.000' - as provided by YAML parsing, is causing issues, as it passes "if $val"
        push @for_type, sprintf( 'read=%.3f',  $in->{ $read_key } )  if ( ( $in->{ $read_key }  // 0 ) + 0 ) > 0;
        push @for_type, sprintf( 'write=%.3f', $in->{ $write_key } ) if ( ( $in->{ $write_key } // 0 ) + 0 ) > 0;
        next if 0 == scalar @for_type;
        $parts{ $type } = join( ' ', @for_type );
    }
    return if 0 == scalar keys %parts;

    if ( exists $in->{ 'Local I/O Read Time' } ) {

        # This is the newest format (pg17+)
        # Timings: shared read=? write=?, local read=? write=?, temp read=? write=?
        my @parts = ();
        for my $type ( qw( shared local temp ) ) {
            next unless $parts{ $type };
            push @parts, $type . ' ' . $parts{ $type };
        }
        return sprintf( 'I/O Timings: %s', join( ', ', @parts ) );
    }
    elsif ( exists $in->{ 'Temp I/O Read Time' } ) {

        # This is format from pg15 to pg16
        # I/O Timings: shared/local read=? write=?, temp read=? write=?
        my @parts = ();
        for my $type ( qw( old temp ) ) {
            next unless $parts{ $type };
            my $label = $type eq 'old' ? 'shared/local' : $type;
            push @parts, $label . ' ' . $parts{ $type };
        }
        return sprintf( 'I/O Timings: %s', join( ', ', @parts ) );
    }
    else {
        # This is the oldest format (pg14 and older)
        # I/O Timings: read=? write=?
        return sprintf( 'I/O Timings: %s', $parts{ 'old' } );
    }
}

=head2 _build_from_string

Gets data out of provided string.

=cut

sub _build_from_string {
    my $self           = shift;
    my $in             = shift;
    my $single_type_re = qr{
        (?:
                (?: shared | local )
                (?:
                    \s+
                    (?: hit | read | dirtied | written ) = [1-9]\d*
                )+
                |
                temp
                (?:
                    \s+
                    (?: read | written ) = [1-9]\d*
                )+
        )
    }xms;
    croak( 'Invalid format of string for Pg::Explain::Buffers: ' . $in ) unless $in =~ m{
        \A
        \s*
        Buffers:
        \s+
        (
            $single_type_re
            (?:
                , \s+
                $single_type_re
            )*
            )
        \s*
        \z
    }xms;
    my $plain_info = $1;
    my @parts      = split /,\s+/, $plain_info;
    $self->{ 'data' } = {};

    for my $part ( @parts ) {
        my @words = split /\s+/, $part;
        my $type  = shift @words;
        for my $word ( @words ) {
            my ( $op, $bufs ) = split /=/, $word;
            $self->{ 'data' }->{ $type }->{ $op } = $bufs;
        }
    }

    return;
}

=head2 _buffers_add

Creates new Pg::Explain::Buffers object by adding values based on two objects. To be used like:

    my $result = $buffers1 + $buffers2;

=cut

sub _buffers_add {
    my ( $left, $right ) = @_;
    return unless 'Pg::Explain::Buffers' eq ref $left;
    unless ( 'Pg::Explain::Buffers' eq ref $right ) {
        return if defined $right;
        my $res = Pg::Explain::Buffers->new( {} );
        $res->data( clone( $left->data ) );
        return $res;
    }

    my $D   = {};
    my $map = {
        'shared'  => [ qw{ hit read dirtied written } ],
        'local'   => [ qw{ hit read dirtied written } ],
        'temp'    => [ qw{ read written } ],
        'timings' => [ qw{ read write } ],
    };

    my $L = $left->data  ? clone( $left->data )  : {};
    my $R = $right->data ? clone( $right->data ) : {};
    while ( my ( $type, $subtypes ) = each %{ $map } ) {
        for my $subtype ( @{ $subtypes } ) {
            my $val = ( $L->{ $type }->{ $subtype } // 0 ) + ( $R->{ $type }->{ $subtype } // 0 );
            next if $val <= 0;
            $D->{ $type }->{ $subtype } = $val;
        }
    }
    return if 0 == scalar keys %{ $D };

    my $ret = Pg::Explain::Buffers->new( {} );
    $ret->data( $D );
    return $ret;
}

=head2 _buffers_subtract

Creates new Pg::Explain::Buffers object by subtracting values based on two objects. To be used like:

    my $result = $buffers1 - $buffers2;

=cut

sub _buffers_subtract {
    my ( $left, $right ) = @_;
    return unless 'Pg::Explain::Buffers' eq ref $left;
    return unless 'Pg::Explain::Buffers' eq ref $right;

    my $map = {
        'shared'  => [ qw{ hit read dirtied written } ],
        'local'   => [ qw{ hit read dirtied written } ],
        'temp'    => [ qw{ read written } ],
        'timings' => [ qw{ read write } ],
    };

    return unless $left->data;
    unless ( $right->data ) {
        my $res = Pg::Explain::Buffers->new( {} );
        $res->data( clone( $left->data ) );
        return $res;
    }

    my $new_data = {};
    while ( my ( $type, $subtypes ) = each %{ $map } ) {
        next unless my $L = $left->data->{ $type };
        if ( my $R = $right->data->{ $type } ) {
            for my $subtype ( @{ $subtypes } ) {
                my $val = ( $L->{ $subtype } // 0 ) - ( $R->{ $subtype } // 0 );

                # Weirdish comparison to get rid of floating point arithmetic errors, like:
                # 32.974 - 18.153 - 14.721 => 3.5527136788005e-15
                next if $val <= 0.00001;
                $new_data->{ $type }->{ $subtype } = $val;
            }
        }
        else {
            $new_data->{ $type } = clone( $L );
        }
    }
    return if 0 == scalar keys %{ $new_data };

    my $ret = Pg::Explain::Buffers->new( {} );
    $ret->data( $new_data );
    return $ret;
}

=head2 _buffers_bool

For checking if given variable is set, as in:

    $r = $buffers1 - $buffers2;
    if ( $r ) {...}

=cut

sub _buffers_bool {
    my $self = shift;
    return unless $self->data;
    return 0 < scalar keys %{ $self->data };
}

=head1 AUTHOR

hubert depesz lubaczewski, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Pg::Explain::Buffers

=head1 COPYRIGHT & LICENSE

Copyright 2008-2023 hubert depesz lubaczewski, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;    # End of Pg::Explain::Buffers