File Coverage

blib/lib/Devel/Bug.pm

Criterion	Covered	Total	%
statement	140	147	95.2
branch	60	66	90.9
condition	43	58	74.1
subroutine	27	31	87.1
pod	1	2	50.0
total	271	304	89.1

# Devel::Bug - Transparent inline debugging probe (pure Perl)
#
# Copyright (C) 2026 Kevin Shea
# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.

package Devel::Bug;

our $VERSION = '0.07';

use v5.8;
use utf8;

use strict;
use warnings;

use Term::ANSIColor;
use Carp qw(croak carp);


use constant BUG_OPTIONS => {
    label      => [ ''                         ],
    noterm     => [ '',  qw(n noterminal)      ],
    out        => [ '*', qw(o output)          ],
    delims     => [ '+', qw(d delimiters)      ],
    color      => [ '+'                        ],
    infocolor  => [ '',  qw(ic)                ],
    labelcolor => [ '',  qw(lc)                ],
    valcolor   => [ '',  qw(vc valuecolor)     ],
    multiline  => [ '',  qw(m ml)              ],
    indices    => [ '',  qw(i @ index indexes) ],
    keyval     => [ '',  qw(k kv %)            ],
    package    => [ '',  qw(p pkg)             ],
    filename   => [ '',  qw(f fn)              ],
    lineno     => [ '',  qw(l ln line)         ],
    val        => [ '*', qw(v value override)  ],
    pp         => [ ''                         ],
};

use constant USE_OPTIONS => {
    %{ +BUG_OPTIONS },
    bug => [ '' ],
};

use constant OPTION_ALIASES => do {
    my (%h, $opt, $spec);
    @h{ @{$spec}[1..$#$spec] }= ( $opt ) x $#$spec while ($opt, $spec)= each %{ +USE_OPTIONS };
    \%h;
};

use constant CALLER_INFO => qw(package filename lineno);


# Terminal detection helpers. (Extracated from DESTROY to facilitate testing.)
sub _isTerm    { -t $_[0] }
sub _sttyWidth { (qx(stty size 2>/dev/null)=~/^\d+\s+(\d+)/)[0] || 0 }

sub _tspWidth {
    my $w= eval { require Term::Size::Perl; (Term::Size::Perl::chars($_[0]))[0] };
    $@ and carp qq(Unable to load Term::Size::Perl: specify option 'noterm => 1' to suppress this warning);
    $w || 0;
}

# Takes an ARRAY REF and returns a list of ARRAY refs of pairs of elements from it.
sub _pairs { my $a= $_[0]; map [ $a->[ $_<<1 ], $a->[ ($_<<1) + 1 ] ], 0..$#$a>>1 }


# Validate options according to provided definitions.
sub validate {
    my $optDefs= shift;

    # Get label and option flags, if present.
    my $label= @_ & 1? shift : '';
    ($label, my $flags)= split /:/, defined($label) && $label, 2;

    unshift @_,
        label => defined($label) && $label,
        map { $_ => 1 } split //, defined($flags) && $flags;

    # Get key/value options.
    my @options;

    foreach (_pairs \@_) {
        my $opt= lc $_->[0];    # option names are case insensitive
        local $_= $_->[1];

        # Convert an alias option name to its primary name.
        $opt= OPTION_ALIASES->{$opt} if exists OPTION_ALIASES->{$opt};

        # Confirm option name actually exists.
        exists $optDefs->{$opt} or croak qq(Unknown option '$opt');

        # Confirm and process option values and their types.
        my $type= $optDefs->{$opt}[0];

        $type eq '+'
        ?   (defined and $_= m{^(?:on|1)$}i? 1 : m{^(?:auto|)$}i? '' : m{^off$}i? undef : croak qq(Illegal option value: $opt => '$_'))
        :   ($type eq '*' or $optDefs->{$opt}[0] eq ref or croak qq(Option '$opt' may not be type '@{[ ref || '(SCALAR)' ]}'));

        push @options, $opt => $_;
    }

    @options;
}


my %OPTIONS;

sub import {
    shift;

    %OPTIONS= (
        validate(USE_OPTIONS, out => *STDERR, delims => 'auto', color => 'auto', lc => 'bold', vc => 'red on_grey23'),     # defaults
        validate(USE_OPTIONS, @_)
    );

    # Default name under which to export bug().
    my $bug= 'bug';

    # Caller may export bug() under a different name or suppress export.
    if (exists $OPTIONS{bug}) {
        # Don't export anything if explicity set to falsy.
        $bug= $OPTIONS{bug} or return;

        # Export bug() under a different name.
        $bug=~/^ (?: [a-z]\w* | _\w+ ) $/ix or croak qq(Illegal characters in 'bug' replacement subroutine name '$bug');
        delete $OPTIONS{bug};
    }

    # Export bug().
    no strict 'refs';
    *{ (caller).'::'.$bug }= \&bug;
}


# Debugging utility class.
#   Allows for inlining a temporary "bug" sub which will output intermediate expression data.
#   Ex:     my $infoPN= $CV_INFO_DIR."/".(bug('relpath')= substr($_, length($sourceDir) + 1));
#   Output: relpath=(...)

# To preserve list context, use form: (bug 'list')= ( some list );

sub bug :lvalue {
    # Create object and populate it with options from import and bug().
    my $self= bless { %OPTIONS, validate BUG_OPTIONS, @_ }, __PACKAGE__;

    # Get extra info to include with output.
    my %info;

    @info{ (CALLER_INFO) }= caller;
    $info{lineno}= "line $info{lineno}";

    $self->{info}= join(' ', map $info{$_}, grep $self->{$_}, CALLER_INFO);

    # Tie an array or scalar, for list or scalar context respectively.
    # Package variables localized per call: named vars are never "temporaries" (avoids
    # "Can't return a temporary from lvalue subroutine" on v5.8-5.12 and "Bizarre copy
    # of ARRAY" on affected versions). local() is reentrant via per-call save-points.
    our   (@lvArray, $lvScalar);
    local (@lvArray, $lvScalar);

    if (wantarray) {
        $self->{data}= [];

        tie @lvArray, __PACKAGE__, $self;
        @lvArray;
    } else {
        $self->{data}= \my $scalar;

        tie $lvScalar, __PACKAGE__, $self;
        $lvScalar;
    }
    # Implicit return used to avoid known perl bug: "Bizarre copy of ARRAY in return" in some perl versions.
}

# Just pass along self object constructed in bug(), which invokes these via tie().
sub TIESCALAR { $_[1] }
sub TIEARRAY  { $_[1] }

# Methods for tied array.
sub CLEAR     {    $_[0]->{data}= [] }
sub FETCHSIZE { @{ $_[0]->{data} }   }

# Shared methods:              SCALAR                           ARRAY
sub FETCH     { @_ == 1?  ${ $_[0]->{data} }         :  $_[0]->{data}[ $_[1] ]         }
sub STORE     { @_ == 2? (${ $_[0]->{data} }= $_[1]) : ($_[0]->{data}[ $_[1] ]= $_[2]) }

# Format and output captured values upon destruction of temporary tied variable.
sub DESTROY {
    my $self= $_[0];
    my $override= exists $self->{val};

    my ($data, $delims, $color, $multiline, $indices, $keyval, $ic, $lc, $vc)=
        @{$self}{ qw(data delims color multiline indices keyval infocolor labelcolor valcolor) };

    my $isScalar= ref($data) eq 'SCALAR';

    $indices||= '';

    # Get terminal width if requested and available.
    my $termW= (not $self->{noterm} and _isTerm($self->{out}))? _sttyWidth() || _tspWidth($self->{out}) : 0;

    # Get the pretty printer sub.
    my $ppSub;

    if (defined $self->{pp}) {
        eval {
            # Caller specified sub in Module::sub form.
            my $pp= $self->{pp};
            my ($ppPN)= $pp=~/^(.+)::.+$/i or die qq(Invalid pretty-printer '$pp' specified: expected 'Module::sub' form);

            $ppPN=~s{::}{/}g;  # get module path with slashes for require

            # Load the module.
            eval { require "$ppPN.pm" } or die $@;

            # Confirm sub callable and save ref to it.
            no strict 'refs';
            defined &$pp or die qq(Invalid pretty-printer '$pp');
            $ppSub= \&$pp;
        } or carp $@;
    }

    # If no pretty printer specified or loading it didn't work, try the default.
    $ppSub||= do { no warnings 'once'; require Data::Dumper; $Data::Dumper::Indent= 1; \&Data::Dumper::Dumper };

    # Make a string representation of the data.
    my $toString= sub {
        my $color= $_[0];   # color the text with ANSI colors?
        my $ml=    $_[1] || $multiline || $indices? "\n" : '';  # multiline?

        my $label= $self->{label};
        my $info=  $self->{info};

        local $_;

        # Return a string representation of the value, coloring if needed.
        my $cv= sub {
            my $txt= ref $_[0]? $ppSub->($_[0]) : defined $_[0]? $_[0] : 'UNDEF';
            ($color and $vc)? colored($txt, $vc) : $txt;
        };

        # Make a string representation of the data.
        my $i= 0;

        my $vals=
            $ml.(
            join $ml || ' ',
                map { $ml? "  $_" : $_ }    # multiline?
                      $override? ( $cv->($self->{val}) )                                                    # vals => ... override used
                    : $isScalar? ( $cv->($$data) )                                                          # single scalar
                    : $keyval?   ( map { ($indices && $i++.': ').$cv->($_->[0]).' => '.$cv->($_->[1]) } _pairs($data) ) # list of key/val pairs
                    :            ( map { ($indices && $i++.': ').$cv->($_) } @$data )                       # list
            ).$ml;

        # Format info, label and vals, coloring if needed.
        $info=  ($color and $ic)? colored($info, $ic).': ' : "$info: " if length $info;
        $label= ($color and $lc)? colored($label, $lc).'=' : "$label=" if length $label;
        $vals=  '('.$vals.')' if $delims or defined($delims) and ($ml or not $color or length($vals) == 0);

        $info.$label.$vals;
    };

    # Call toString once for possible sizing, then again if necessary for coloring and/or wrapping.
    my $str;

    $str= $toString->($color and not $termW);
    $str= $toString->(defined($color), $termW < length $str) if $termW;

    # Ouput the string.
    print { $self->{out} } $str."\n";
}


# Catch if user code attempts to use this like a regular object.
sub AUTOLOAD {
    our $AUTOLOAD;
    croak qq(Attempt to call unneeded non-existent subroutine '$AUTOLOAD': class @{[ __PACKAGE__ ]} intended for inline logging only);
}

# If these get called, they need to be no-ops, since we're only using the tied array for logging.
sub EXTEND    { }
sub STORESIZE { }



1;

__END__