Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

carp/croak may not show caller's module/line #1022

Closed
p5pRT opened this issue Jan 11, 2000 · 3 comments
Closed

carp/croak may not show caller's module/line #1022

p5pRT opened this issue Jan 11, 2000 · 3 comments

Comments

@p5pRT
Copy link

p5pRT commented Jan 11, 2000

Migrated from rt.perl.org#1973 (status was 'resolved')

Searchable as RT1973$

@p5pRT
Copy link
Author

p5pRT commented Jan 11, 2000

From wolfgang.laun@alcatel.at

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;

Perl Info


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

@p5pRT
Copy link
Author

p5pRT commented Jul 17, 2003

From perl@tmtm.com

Hi,

I've closed this bug, as (if I understand the bug report properly), this
has been fixed in perl 5.8

Sorry it took so long, and if the problem's still actually there, feel
free to re-open this!

Thanks,

Tony

@p5pRT
Copy link
Author

p5pRT commented Jul 19, 2003

perl@tmtm.com - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant