+ while ( my %i = caller_info( ++$i ) ) {
+ $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
+ }
+
+ return $mess;
+}
+
+sub ret_summary {
+ my ( $i, @error ) = @_;
+ my $err = join '', @error;
+ $i++;
+
+ my $tid_msg = '';
+ if ( defined &threads::tid ) {
+ my $tid = threads->tid;
+ $tid_msg = " thread $tid" if $tid;
+ }
+
+ my %i = caller_info($i);
+ return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+sub short_error_loc {
+ # You have to create your (hash)ref out here, rather than defaulting it
+ # inside trusts *on a lexical*, as you want it to persist across calls.
+ # (You can default it on $_[2], but that gets messy)
+ my $cache = {};
+ my $i = 1;
+ my $lvl = $CarpLevel;
+ {
+ my $cgc = _cgc();
+ my $called = $cgc ? $cgc->($i) : caller($i);
+ $i++;
+ my $caller = $cgc ? $cgc->($i) : caller($i);
+
+ return 0 unless defined($caller); # What happened?
+ redo if $Internal{$caller};
+ redo if $CarpInternal{$caller};
+ redo if $CarpInternal{$called};
+ redo if trusts( $called, $caller, $cache );
+ redo if trusts( $caller, $called, $cache );
+ redo unless 0 > --$lvl;
+ }
+ return $i - 1;
+}
+
+sub shortmess_heavy {
+ return longmess_heavy(@_) if $Verbose;
+ return @_ if ref( $_[0] ); # don't break references as exceptions
+ my $i = short_error_loc();
+ if ($i) {
+ ret_summary( $i, @_ );
+ }
+ else {
+ longmess_heavy(@_);
+ }
+}
+
+# If a string is too long, trims it with ...
+sub str_len_trim {
+ my $str = shift;
+ my $max = shift || 0;
+ if ( 2 < $max and $max < length($str) ) {
+ substr( $str, $max - 3 ) = '...';
+ }
+ return $str;
+}
+
+# Takes two packages and an optional cache. Says whether the
+# first inherits from the second.
+#
+# Recursive versions of this have to work to avoid certain
+# possible endless loops, and when following long chains of
+# inheritance are less efficient.
+sub trusts {
+ my $child = shift;
+ my $parent = shift;
+ my $cache = shift;
+ my ( $known, $partial ) = get_status( $cache, $child );
+
+ # Figure out consequences until we have an answer
+ while ( @$partial and not exists $known->{$parent} ) {
+ my $anc = shift @$partial;
+ next if exists $known->{$anc};
+ $known->{$anc}++;
+ my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
+ my @found = keys %$anc_knows;
+ @$known{@found} = ();
+ push @$partial, @$anc_partial;
+ }
+ return exists $known->{$parent};
+}
+
+# Takes a package and gives a list of those trusted directly
+sub trusts_directly {
+ my $class = shift;
+ no strict 'refs';
+ no warnings 'once';
+ return @{"$class\::CARP_NOT"}
+ ? @{"$class\::CARP_NOT"}
+ : @{"$class\::ISA"};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Carp - alternative warn and die for modules