[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]

[ID 20000111.001] carp/croak may not show caller's module/line




This is a bug report for perl from Wolfgang.Laun@alcatel.at,
generated with the help of perlbug 1.26 running under perl 5.00503.


-----------------------------------------------------------------
[Please enter your report here]

Perl bug report concerning the library module Carp

This concerns Carp::Heavy.pm (or Carp.pm) in all perl 5.x versions,
including the latest developer version.

*** Bug: carp and croak may fail to show "caller"

Carp's carp and croak used in some module M should report errors from
a caller's point of view. As the comment in Heavy.pm says, a "caller"
is some module not among M's ancestors or descendants.

Consider this set of modules (on file Animal.pm):

   #========================================================
   package Animal;
   use UNIVERSAL qw( can );
   use Carp;

   sub new {
       my $class = shift;
       bless( { @_ }, $class );
   }

   sub dump {
       my $self = shift();
       $self->name() if $self->can(name);
   }

   sub teeth {
       my $self = shift();
       carp( "Has no teeth" ) unless $self->{-teeth};
   }

   #========================================================
   package Mammal;
   @ISA = ( 'Animal' );

   sub new {
       my $class = shift;
       bless( $class->SUPER::new( @_ ), $class );
   }

   #========================================================
   package Rodent;
   use Carp;
   @ISA = ( 'Mammal' );

   sub new {
       my $class = shift();
       bless( $class->SUPER::new( @_ ), $class );
   }

   sub name {
       my $self = shift();
       carp( "Name called - no name" ) unless $self->{-name};
   }

   sub gnaw {
       my $self = shift();
       $self->teeth();
   }
   #========================================================

Now, let's run this program:

   use Animal;
   my $r = Rodent->new( -name => '', -teeth => 0 );
   $r->dump();
   $r->gnaw();

Output:
   Name called - no name at Animal.pm line 13
   Has no teeth at Animal.pm line 47

carp reports lines within Animal.pm! Both the call of Rodent::name
from Animal::dump and the call of Animal::teeth from Rodent::gnaw are
not detected to be within M's own domain.

The algorithm in shortmess_heavy is faulty as it fails to look beyond
a module's immediate ancestors and inheritors. The enclosed version
of Carp::Heavy.pm does not show this defect.

While fixing this, the $CarpLevel feature required some consideration.
This has led to the question:


*** Is $CarpLevel really useful?

While not in the official documentation, the comments in Heavy.pm would
give the impression that increasing $CarpLevel would enable a wrapper
module to shift the reporting of carp/croak/confess/cluck to the "right"
place.

I doubt that this can be achieved in this simple manner. First, any
wrapper wanting to appear transparent to carp & co. would have to
enclose all calls to the wrapped module's subroutines in $CarpLevel++
and $CarpLevel-- statements. (Clearly this increment cannot be done
statically as it would affect all modules around.) Second, what would
happen if a wrapper increments $CarpLevel dynamically, calls the wrapped
module which does a callback to a user subroutine and this calls the
wrapped module again, which then calls carp?

To make this feature robust, we'd need a call telling Carp to treat a
wrapper module W as "one of the family" with respect to some wrapped
module M, e.g.

   Carp::Adopt( M, W );

If some M subroutine carps, and the chain of callers passes into
W's family tree, the algorithm continues. 

This probably should also influence the longmess_heavy algorithm.

(As this goes way beyond a simple bugfix, I've refrained from touching
this.)


==== Carp::Heavy.pm ======================================================

package Carp;

=head1 NAME

Carp::Heavy - Carp guts

=head1 SYNOPIS

(internal use only)

=head1 DESCRIPTION

No user-serviceable parts inside.
 
=cut

# This package is heavily used. Be small. Be fast. Be good.

# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
# _almost_ complete understanding of the package.  Corrections and
# comments are welcome.

# longmess() crawls all the way up the stack reporting on all the function
# calls made.  The error string, $error, is originally constructed from the
# arguments passed into longmess() via confess(), cluck() or shortmess().
# This gets appended with the stack trace messages which are generated for
# each function call on the stack.

sub longmess_heavy {
    return @_ if ref $_[0];
    my $error = join '', @_;
    my $mess = "";
    my $i = 1 + $CarpLevel;
    my ($pack,$file,$line,$sub,$hargs,$eval,$require);
    my (@a);
    #
    # crawl up the stack....
    #
    while (do { { package DB; @a = caller($i++) } } ) {
	# get copies of the variables returned from caller()
	($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
	#
	# if the $error error string is newline terminated then it
	# is copied into $mess.  Otherwise, $mess gets set (at the end of
	# the 'else {' section below) to one of two things.  The first time
	# through, it is set to the "$error at $file line $line" message.
	# $error is then set to 'called' which triggers subsequent loop
	# iterations to append $sub to $mess before appending the "$error
	# at $file line $line" which now actually reads "called at $file line
	# $line".  Thus, the stack trace message is constructed:
	#
	#        first time: $mess  = $error at $file line $line
	#  subsequent times: $mess .= $sub $error at $file line $line
	#                                  ^^^^^^
	#                                 "called"
	if ($error =~ m/\n$/) {
	    $mess .= $error;
	} else {
	    # Build a string, $sub, which names the sub-routine called.
	    # This may also be "require ...", "eval '...' or "eval {...}"
	    if (defined $eval) {
		if ($require) {
		    $sub = "require $eval";
		} else {
		    $eval =~ s/([\\\'])/\\$1/g;
		    if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
			substr($eval,$MaxEvalLen) = '...';
		    }
		    $sub = "eval '$eval'";
		}
	    } elsif ($sub eq '(eval)') {
		$sub = 'eval {...}';
	    }
	    # if there are any arguments in the sub-routine call, format
	    # them according to the format variables defined earlier in
	    # this file and join them onto the $sub sub-routine string
	    if ($hargs) {
		# we may trash some of the args so we take a copy
		@a = @DB::args;	# must get local copy of args
		# don't print any more than $MaxArgNums
		if ($MaxArgNums and @a > $MaxArgNums) {
		    # cap the length of $#a and set the last element to '...'
		    $#a = $MaxArgNums;
		    $a[$#a] = "...";
		}
		for (@a) {
		    # set args to the string "undef" if undefined
		    $_ = "undef", next unless defined $_;
		    if (ref $_) {
			# force reference to string representation
			$_ .= '';
			s/'/\\'/g;
		    }
		    else {
			s/'/\\'/g;
			# terminate the string early with '...' if too long
			substr($_,$MaxArgLen) = '...'
			    if $MaxArgLen and $MaxArgLen < length;
		    }
		    # 'quote' arg unless it looks like a number
		    $_ = "'$_'" unless /^-?[\d.]+$/;
		    # print high-end chars as 'M-<char>'
		    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
		    # print remaining control chars as ^<char>
		    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
		}
		# append ('all', 'the', 'arguments') to the $sub string
		$sub .= '(' . join(', ', @a) . ')';
	    }
	    # here's where the error message, $mess, gets constructed
	    $mess .= "\t$sub " if $error eq "called";
	    $mess .= "$error at $file line $line";
	    if (defined &Thread::tid) {
		my $tid = Thread->self->tid;
		$mess .= " thread $tid" if $tid;
	    }
	    $mess .= "\n";
	}
	# we don't need to print the actual error message again so we can
	# change this to "called" so that the string "$error at $file line
	# $line" makes sense as "called at $file line $line".
	$error = "called";
    }
    # this kludge circumvents die's incorrect handling of NUL
    my $msg = \($mess || $error);
    $$msg =~ tr/\0//d;
    $$msg;
}


# ancestors() returns the complete set of ancestors of a module

sub ancestors($$){
    my( $pack, $href ) = @_;
    my $risa = \@{"${pack}::ISA"};
    if( @$risa  ){
	my %tree  = ();
	@tree{@$risa} = ();
	foreach my $mod ( @$risa ){
	    # visit ancestors - if not already in the gallery
	    if( ! defined( $$href{$mod} ) ){
		my @ancs = ancestors( $mod, $href );
		@tree{@ancs} = ();
	    }
	}
	return ( keys( %tree ) );
    } else {
	return ();
    }
}


# shortmess() is called by carp() and croak() to skip all the way up to
# the top-level caller's package and report the error from there.  confess()
# and cluck() generate a full stack trace so they call longmess() to
# generate that.  In verbose mode shortmess() calls longmess() so
# you always get a stack trace

sub shortmess_heavy {	# Short-circuit &longmess if called via multiple packages
    goto &longmess_heavy if $Verbose;
    return @_ if ref $_[0];
    my $error = join '', @_;
    my ($prevpack) = caller(1);
    my $extra = $CarpLevel;

    my @Clans = ( $prevpack );
    my $i = 2;
    my ($pack,$file,$line);
    # when reporting an error, we want to report it from the context of the
    # calling package.  So what is the calling package?  Within a module,
    # there may be many calls between methods and perhaps between sub-classes
    # and super-classes, but the user isn't interested in what happens
    # inside the package.  We start by building a hash array which keeps
    # track of all the packages to which the calling package belongs.  We
    # do this by examining its @ISA variable.  Any call from a base class
    # method (one of our caller's @ISA packages) can be ignored
    my %isa;

    # merge all the caller's @ISA packages and ancestors into %isa.
    my @pars = ancestors( $prevpack, \%isa );
    @isa{@pars} = () if @pars;
    $isa{$prevpack} = 1;

    # now we crawl up the calling stack and look at all the packages in
    # there.  For each package, we look to see if it has an @ISA and then
    # we see if our caller features in that list.  That would imply that
    # our caller is a derived class of that package and its calls can also
    # be ignored
CALLER:
    while (($pack,$file,$line) = caller($i++)) {

        # Chances are, the caller's caller (or its caller...) is already
        # in the gallery - if so, ignore this caller.
        next if exists( $isa{$pack} );

        # no: collect this module's ancestors.
        my @i = ancestors( $pack, \%isa );
        my %i;
        if( @i ){
 	    @i{@i} = ();
            # check whether our representative of one of the clans is
            # in this family tree.
	    foreach my $cl (@Clans){
                if( exists( $i{$cl} ) ){
    	            # yes: merge all of the family tree into %isa
	            @isa{@i,$pack} = ();
		    # and here's where we do some more ignoring...
		    # if the package in question is one of our caller's
		    # base or derived packages then we can ignore it (skip it)
		    # and go onto the next.
		    next CALLER if exists( $isa{$pack} );
		    last;
		}
            }
	}

	# Hey!  We've found a package that isn't one of our caller's
	# clan....but wait, $extra refers to the number of 'extra' levels
	# we should skip up.  If $extra > 0 then this is a false alarm.
	# We must merge the package into the %isa hash (so we can ignore it
	# if it pops up again), decrement $extra, and continue.
	if ($extra-- > 0) {
	    push( @Clans, $pack );
	    @isa{@i,$pack} = ();
	}
	else {
	    # OK!  We've got a candidate package.  Time to construct the
	    # relevant error message and return it.   die() doesn't like
	    # to be given NUL characters (which $msg may contain) so we
	    # remove them first.
	    my $msg;
	    $msg = "$error at $file line $line";
	    if (defined &Thread::tid) {
		my $tid = Thread->self->tid;
		$mess .= " thread $tid" if $tid;
	    }
	    $msg .= "\n";
	    $msg =~ tr/\0//d;
	    return $msg;
	}
    }

    # uh-oh!  It looks like we crawled all the way up the stack and
    # never found a candidate package.  Oh well, let's call longmess
    # to generate a full stack trace.  We use the magical form of 'goto'
    # so that this shortmess() function doesn't appear on the stack
    # to further confuse longmess() about it's calling package.
    goto &longmess_heavy;
}

1;


[Please do not change anything below this line]
-----------------------------------------------------------------

---
Site configuration information for perl 5.00503:

Configured by root at Mon Aug 30 23:08:56 EDT 1999.

Summary of my perl5 (5.0 patchlevel 5 subversion 3) configuration:
  Platform:
    osname=linux, osvers=2.2.5-22smp, archname=i386-linux
    uname='linux porky.devel.redhat.com 2.2.5-22smp #1 smp wed jun 2 09:11:51 edt 1999 i686 unknown '
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef useperlio=undef d_sfio=undef
  Compiler:
    cc='cc', optimize='-O2', gccversion=egcs-2.91.66 19990314/Linux (egcs-1.1.2 release)
    cppflags='-Dbool=char -DHAS_BOOL -I/usr/local/include'
    ccflags ='-Dbool=char -DHAS_BOOL -I/usr/local/include'
    stdchar='char', d_stdstdio=undef, usevfork=false
    intsize=4, longsize=4, ptrsize=4, doublesize=8
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    alignbytes=4, usemymalloc=n, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -ldl -lm -lc -lposix -lcrypt
    libc=, so=so, useshrplib=false, libperl=libperl.a
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    

---
@INC for perl 5.00503:
    /usr/lib/perl5/5.00503/i386-linux
    /usr/lib/perl5/5.00503
    /usr/lib/perl5/site_perl/5.005/i386-linux
    /usr/lib/perl5/site_perl/5.005
    .

---
Environment for perl 5.00503:
    HOME=/home/laune
    LANG=en
    LANGUAGE (unset)
    LC_ALL=en_US
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/usr/bin:/bin:/usr/X11R6/bin:/usr/local/bin:/opt/bin:/usr/X11R6/bin:/home/laune/bin:/usr/X11R6/bin:/home/laune/bin
    PERL_BADLANG (unset)
    SHELL=/bin/bash


[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]