File Coverage

blib/lib/Paranoid/Debug.pm

Criterion	Covered	Total	%
statement	203	212	95.7
branch	54	68	79.4
condition	7	8	87.5
subroutine	46	47	97.8
pod	9	9	100.0
total	319	344	92.7

# Paranoid::Debug -- Debug support for paranoid programs
#
# $Id: lib/Paranoid/Debug.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Debug;

use strict;
use warnings;
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS);
use base qw(Exporter);
use Paranoid;
use Carp;

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/sm );

@EXPORT = qw(PDEBUG pdebug pIn pOut subPreamble subPostamble
    PDEBUG1 PDEBUG2 PDEBUG3 PDEBUG4 PDEBUG5 PDEBUG6 PDEBUG7 PDEBUG8);
@EXPORT_OK = (
    @EXPORT,
    qw(pderror PDPREFIX PDLEVEL1 PDLEVEL2 PDLEVEL3 PDLEVEL4 PDMAXINDENT),
    );
%EXPORT_TAGS = (
    all       => [@EXPORT_OK],
    constants => [
        qw(PDEBUG1 PDEBUG2 PDEBUG3 PDEBUG4 PDEBUG5 PDEBUG6
            PDEBUG7 PDEBUG8)
        ],
        );

use constant PDLEVEL1 => 9;
use constant PDLEVEL2 => 10;
use constant PDLEVEL3 => 11;
use constant PDLEVEL4 => 12;

use constant PDMAXIND    => 40;
use constant PDMAXSCALAR => 20;

use constant PDEBUG1 => 1;
use constant PDEBUG2 => 2;
use constant PDEBUG3 => 3;
use constant PDEBUG4 => 4;
use constant PDEBUG5 => 5;
use constant PDEBUG6 => 6;
use constant PDEBUG7 => 7;
use constant PDEBUG8 => 8;

use constant CSF_PKG => 0;
use constant CSF_FNM => 1;
use constant CSF_LN  => 2;
use constant CSF_SUB => 3;
use constant CSF_HAS => 4;
use constant CSF_WNT => 5;
use constant CSF_EVL => 6;
use constant CSF_REQ => 7;
use constant CSF_HNT => 8;
use constant CSF_BIT => 9;
use constant CSF_HSH => 10;

#####################################################################
#
# Module code follows
#
#####################################################################

{
    my $dlevel   = 0;           # Start with no indentation
    my $pdebug   = 0;           # Start with debug output disabled
    my $maxLevel = PDMAXIND;    # Start with normal max indentation

    my $odefprefix = sub {

        # Old default Prefix to use with debug messages looks like:
        #
        #   [PID - $dlevel] Subroutine:
        #
        my $caller      = shift;
        my $indentation = shift;
        my $oi          = $indentation;
        my $prefix;

        # Cap indentation
        $indentation = $maxLevel if $indentation > $maxLevel;

        # Construct the prefix
        $prefix = ' ' x $indentation . "[$$-$oi] $caller: ";

        return $prefix;
    };
    my $defprefix = sub {

        # Default Prefix to use with debug messages looks like:
        #
        #   [PID-level caller]
        #
        my $caller      = shift;
        my $indentation = shift;
        my $prefix      = '';
        my $oi          = $indentation;

        # Cap indentation
        $indentation = ( $maxLevel / 3 ) if ( $indentation * 3 ) > $maxLevel;

        # Compose the prefix
        if ( $indentation == 1 ) {
            $prefix = '+> ';
        } elsif ( $indentation > 1 ) {
            $prefix = '|  ' x ( $indentation - 1 ) . '+> ';
        }
        $prefix .= "[$$-$oi $caller] ";

        return $prefix;
    };
    my $pdprefix = $defprefix;

    sub PDEBUG : lvalue {
        $pdebug;
    }

    sub PDPREFIX : lvalue {
        $pdprefix;
    }

    sub PDMAXINDENT : lvalue {
        $maxLevel;
    }

    sub pderror ($) {

        # Purpose:  Print passed string to STDERR
        # Returns:  Return value from print function
        # Usage:    $rv = pderror("Foo!");

        my $msg = shift;

        $@ = $msg;

        return print STDERR "$msg\n";
    }

    sub pdebug ($;$@) {

        # Purpose:  Calls pderror() if the message level is less than or equal
        #           to the value of PDBEBUG, after prepending the string
        #           returned by the PDPREFIX routine, if defined
        # Returns:  Always returns the passed message, regardless of PDEBUG's
        #           value
        # Usage:    pdebug($message, $level);

        my $msg    = shift;
        my $level  = shift || 1;
        my @pfargs = @_;
        my $prefix = PDPREFIX;
        my ( $ci, @crec, $caller, $n, $np );

        $msg = '' unless defined $msg;

        # If called with a negative level it merely means we
        # need to go a little bit deeper in the call stack to find the
        # true initiator of the message.  This provides the mechanism for
        # Paranoid::Log::plog to pass indirect debug messages
        $ci = $level < 0 ? 2 : 1;
        $level *= -1 if $level < 0;

        # Get the call stack info
        @crec = caller $ci;
        $caller =
              defined $crec[CSF_SUB] ? $crec[CSF_SUB]
            : defined $crec[CSF_FNM] ? "$crec[CSF_FNM]/$crec[CSF_LN]"
            :                          'undef';

        # Filter message through sprintf if args were passed
        $n = [ $msg =~ m#(%[\w.]+)#sg ];
        $np = $n = scalar @$n;
        if ($n) {

            # Adjust n upwards if we were given more list items than
            # we see placeholders for in the messsage string
            $n = scalar @pfargs if @pfargs > $n;

            # Make sure the requisite number of args are translated for undefs
            while ( $n > 0 ) {
                $n--;
                $pfargs[$n] = 'undef' unless defined $pfargs[$n];
            }

            # Consolidate extra args into the last placeholder's spot
            if ( scalar @pfargs > $np ) {
                $n = $np - 1;
                @pfargs =
                    ( @pfargs[ 0 .. ( $n - 1 ) ], "@pfargs[$n .. $#pfargs]" );
            }

            # Filter through sprintf
            {
                no warnings;
                $msg = sprintf $msg, @pfargs;
            }
        }

        return $msg if $level > PDEBUG;

        # Execute the code block, if that's what it is
        $prefix = &$prefix( $caller, $dlevel ) if ref($prefix) eq 'CODE';

        {
            no warnings;
            pderror("$prefix$msg");
        }

        return $msg;
    }

    sub pIn () {

        # Purpose:  Increases indentation level
        # Returns:  Always True (1)
        # Usage:    pIn();

        $dlevel++;

        return 1;
    }

    sub pOut () {

        # Purpose:  Decreases indentation level
        # Returns:  Always True (1)
        # Usage:    pOut();

        $dlevel--;

        return 1;
    }

    my %subprotos;

    sub _protos ($$) {

        # Purpose:  Converts a string prototype declaration to an array
        # Returns:  Array
        # Usage:    @proto = _protos($caller, $proto);

        my $caller = shift;
        my $proto  = shift;
        my ( $t, $p, @rv );

        if ( defined $proto and length $proto ) {

            if ( exists $subprotos{$caller} ) {

                # Return cached values if we have them
                @rv = @{ $subprotos{$caller} };

            } else {

                # Parse and generate list of argument types
                $p = $proto;
                while ( length $p ) {
                    if ( $p =~ /^\\/s ) {

                        # argument is a reference to... something.
                        push @rv, 'ref';
                        $p =~ s/^\\(\[[^\]]+\]|.)//s;

                    } elsif ( $p =~ /^([\$@%&\*pb])/s ) {

                        $t = $1;
                        push @rv,
                              $t eq '$' ? 'scalar'
                            : $t eq 'p' ? 'private'
                            : $t eq 'b' ? 'bytes'
                            : $t eq '@' ? 'array'
                            : $t eq '%' ? 'hash'
                            : $t eq '&' ? 'code'
                            :             'glob';
                        $p =~ s/^.//s;

                    } elsif ( $p =~ /^;/ ) {

                        # Remove the optional delimiter
                        $p =~ s/^;//s;

                    } else {
                        croak
                            "unknown prototype: $proto (stopped on $p) in\n\t"
                            . join ',',
                            caller 2;
                    }
                }

                # Cache results
                $subprotos{$caller} = [@rv];
            }

        }

        return @rv;
    }

    sub _summarize (\@@) {

        # Purpose:  Summarizes potentially long types of scalars
        # Returns:  Array
        # Usage:    @args = _summarize(@argt, @args);

        my $tref = shift;
        my @args = @_;
        my ( @tmp, %tmp, $i, $l );

        no warnings;
        use bytes;

        # Iterate over args/argt and summarize where appropriate
        for ( $i = 0; $i < @args; $i++ ) {
            if ( $$tref[$i] eq 'scalar' and not ref $args[$i] ) {
                if ( defined $args[$i] ) {
                    $l = length $args[$i];
                    $args[$i] =
                        substr( $args[$i], 0, PDMAXSCALAR ) . "... ($l bytes)"
                        if $l > PDMAXSCALAR;
                    $args[$i] =~ s/\n/\\n/sg;
                    $args[$i] =~ s/[^[:print:]]/./sg;
                }
            } elsif ( $$tref[$i] eq 'array' ) {
                @tmp = splice @args, $i;
                $args[$i] = sprintf 'list of %d items', scalar @tmp;
            } elsif ( $$tref[$i] eq 'hash' ) {
                %tmp = splice @args, $i;
                $args[$i] = sprintf 'hash of %d k/v pairs', scalar keys %tmp;
            } elsif ( $$tref[$i] eq 'private' ) {
                if ( defined $args[$i] ) {
                    $l = length $args[$i];
                    $args[$i] = "REDACTED ($l bytes)";
                }
            } elsif ( $$tref[$i] eq 'bytes' ) {
                if ( defined $args[$i] ) {
                    $l = length $args[$i];
                    $args[$i] = "$l bytes";
                }
            }

            $args[$i] = 'undef' unless defined $args[$i];
        }

        return @args;
    }

    sub subPreamble ($;$@) {

        # Purpose:  Specialized wrapper meant specifically for use in
        #           functions and methods
        # Returns:  Output of pdebug()
        # Usage:    subPreamble(PDEBUG1, '$$@', @_);

        my $level  = shift;
        my $proto  = shift;
        my @args   = splice @_;
        my @caller = caller(1);
        my @argt   = _protos $caller[CSF_SUB] . "-pre", $proto;
        my ( $rv, $msg );

        no warnings;

        # Summarize the args
        @args = _summarize( @argt, @args );

        # Print message
        $msg = 'entering';
        if (@args) {
            $msg .= ' w/' . '(%s)' x ( scalar @args );
        }
        $rv = pdebug( $msg, ( $level * -1 ), @args );

        # Increase indentation level
        $dlevel++;

        return $rv;
    }

    sub subPostamble ($$@) {

        # Purpose:  Specialized wrapper meant specifically for use in
        #           functions and methods
        # Returns:  Output of pdebug()
        # Usage:    subPostamble(PDEBUG1, '$', $rv);

        my $level  = shift;
        my $proto  = shift;
        my @args   = splice @_;
        my @caller = caller(1);
        my @argt   = _protos $caller[CSF_SUB] . '-post', $proto;
        my ( $rv, $msg );

        # Decrease indentation level
        $dlevel--;

        # Summarize the args
        @args = _summarize( @argt, @args );

        # Print message
        $msg = 'leaving w/rv: ';
        if (@args) {
            $msg .= '(%s)' x ( scalar @args );
        }
        $rv = pdebug( $msg, ( $level * -1 ), @args );

        return $rv;
    }

}

1;

__END__