File Coverage

blib/lib/Paranoid/Debug.pm

Criterion	Covered	Total	%
statement	97	103	94.1
branch	20	28	71.4
condition	2	2	100.0
subroutine	27	27	100.0
pod	7	7	100.0
total	153	167	91.6

# Paranoid::Debug -- Debug support for paranoid programs
#
# $Id: lib/Paranoid/Debug.pm, 2.08 2020/12/31 12:10:06 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;

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

@EXPORT = qw(PDEBUG pdebug pIn pOut
    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 => 60;

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;

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

{
    my $dlevel     = 0;           # Start with no debug level
    my $ilevel     = 0;           # Start with no identation
    my $pdebug     = 0;           # Start with debug output disabled
    my $maxLevel   = PDMAXIND;    # Start with normal max indentation
    my $indIgnored = 0;           # Start without ignoring indentation

    my $defprefix = sub {

        # Default Prefix to use with debug messages looks like:
        #
        #   [PID - $dlevel] Subroutine:
        #
        my $caller = shift;
        my $prefix = ' ' x $ilevel . "[$$-$dlevel] $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[3] ? $crec[3]
            : defined $crec[1] ? "$crec[1]/$crec[2]"
            :                    '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) if ref($prefix) eq 'CODE';

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

        return $msg;
    }

    sub pIn () {

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

        if ( $ilevel < PDMAXINDENT ) {
            $ilevel++;
        } else {
            $indIgnored = 1;
        }
        $dlevel++;

        return 1;
    }

    sub pOut () {

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

        if ($indIgnored) {
            $indIgnored = 0;
        } else {
            $ilevel-- if $ilevel > 0;
        }
        $dlevel--;

        return 1;
    }

}

1;

__END__