Carp-Object-1.02000755000000000000 014615520211 14051 5ustar00unknownunknown000000000000Carp-Object-1.02/Build.PL000444000000000000 152014613502314 15502 0ustar00unknownunknown000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Carp::Object', license => 'perl', dist_author => 'Laurent Dami ', dist_version_from => 'lib/Carp/Object.pm', requires => { 'perl' => "5.010001", 'utf8' => 0, 'Devel::StackTrace' => 0, 'Module::Load' => 0, 'Clone' => 0, }, build_requires => { 'Test::More' => 0, }, add_to_cleanup => [ 'Carp-Object-*' ], meta_merge => { resources => { repository => 'https://github.com/damil/Carp-Object', bugtracker => 'https://github.com/damil/Carp-Object/issues', } }, ); $builder->create_build_script(); Carp-Object-1.02/Changes000444000000000000 25314615456541 15477 0ustar00unknownunknown000000000000Revision history for Carp-Object 1.02 04.05.2024 - Fix typos in module name of Devel::StackTrace (Michal Josef Špaček++) 1.01 28.04.2024 - initial version Carp-Object-1.02/MANIFEST000444000000000000 31614613230434 15322 0ustar00unknownunknown000000000000Build.PL Changes lib/Carp/Object.pm MANIFEST This list of files META.json META.yml t/01_object_oriented_API.t t/02_functional_API.t t/03_reexport.t t/04_clan_like.t t/05_carp_not.t t/lib/TestReexport.pm Carp-Object-1.02/META.json000444000000000000 256514615520211 15637 0ustar00unknownunknown000000000000{ "abstract" : "a replacement for Carp or Carp::Clan, object-oriented", "author" : [ "Laurent Dami " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Carp-Object", "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.42" } }, "runtime" : { "requires" : { "Clone" : "0", "Devel::StackTrace" : "0", "Module::Load" : "0", "perl" : "5.010001", "utf8" : "0" } } }, "provides" : { "Carp::Object" : { "file" : "lib/Carp/Object.pm", "version" : "1.02" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/damil/Carp-Object/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/damil/Carp-Object" } }, "version" : "1.02", "x_serialization_backend" : "JSON::PP version 4.16" } Carp-Object-1.02/META.yml000444000000000000 153114615520211 15457 0ustar00unknownunknown000000000000--- abstract: 'a replacement for Carp or Carp::Clan, object-oriented' author: - 'Laurent Dami ' build_requires: Test::More: '0' configure_requires: Module::Build: '0.42' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Carp-Object provides: Carp::Object: file: lib/Carp/Object.pm version: '1.02' requires: Clone: '0' Devel::StackTrace: '0' Module::Load: '0' perl: '5.010001' utf8: '0' resources: bugtracker: https://github.com/damil/Carp-Object/issues license: http://dev.perl.org/licenses/ repository: https://github.com/damil/Carp-Object version: '1.02' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Carp-Object-1.02/lib000755000000000000 014615520211 14617 5ustar00unknownunknown000000000000Carp-Object-1.02/lib/Carp000755000000000000 014615520211 15504 5ustar00unknownunknown000000000000Carp-Object-1.02/lib/Carp/Object.pm000444000000000000 4373214615456553 17457 0ustar00unknownunknown000000000000package Carp::Object; use 5.10.0; use utf8; use strict; use warnings; use Devel::StackTrace; use Module::Load qw/load/; use Clone qw/clone/; our $VERSION = 1.02; my %export_groups = (carp => [qw/carp croak confess/], all => [qw/carp croak confess cluck/], ); # ====================================================================== # METHODS # ====================================================================== sub new { my ($class, %args) = @_; # create $self, consume the 'verbose' arg my $self = {verbose => delete $args{verbose}}; # class for stack traces $self->{stacktrace_class} = delete $args{stacktrace_class} // 'Devel::StackTrace'; # if there is a 'clan' argument, compute a frame filter -- see L if (my $clan = delete $args{clan}) { not $args{frame_filter} or $class->new->croak("can't have arg 'clan' if arg 'frame_filter' is present"); $args{frame_filter} = sub {my $raw_frame_ref = shift; my $pkg = $raw_frame_ref->{caller}[0]; return $pkg !~ /$clan/}; } # handler for displaying stack frames $self->{display_frame} = delete $args{display_frame} // \&_default_display_frame; $self->{display_frame_param} = delete $args{display_frame_param}; # classes to be ignored by Devel::StackTrace : list supplied by caller + current class my $ignore_class = delete $args{ignore_class} // []; $ignore_class = [$ignore_class] if not ref $ignore_class; push @$ignore_class, $class; $args{ignore_class} = $ignore_class; # remaining args will be passed to Devel::StackTrace->new $args{message} //= ''; # to avoid the 'Trace begun' string from StackTrace::Frame::as_string $args{indent} //= 1; $self->{stacktrace_args} = \%args; # return the carper object bless $self, $class; } sub croak {my $self = shift; die $self->msg(join("", @_), 1)} # 1 means "just one frame" sub carp {my $self = shift; warn $self->msg(join("", @_), 1)} # idem sub confess {my $self = shift; die $self->msg(join("", @_) )} # no second arg means "the whole stack" sub cluck {my $self = shift; warn $self->msg(join("", @_) )} # idem sub msg { my ($self, $errstr, $n_frames) = @_; my $class = ref $self; $errstr //= "Died"; # is this call a croak (single stackframe) or a confess (full stack) ? my $want_full_stack = ! defined $n_frames || $self->{verbose} || do {no warnings 'once'; $Carp::Verbose || $Carp::Clan::Verbose}; # if not doing a "confess", tell Devel::Stacktrace to skip frames from the first outside caller my $stacktrace_args = clone $self->{stacktrace_args}; if (!$want_full_stack) { my $outside_caller; my $i = 0; do {$outside_caller = caller($i++) // ""} while $outside_caller->isa($class); push @{$stacktrace_args->{ignore_package}}, $outside_caller unless $outside_caller eq 'main'; } # get stack frames from Devel::StackTrace and truncate the list to the requested number load $self->{stacktrace_class}; my $trace = $self->{stacktrace_class}->new(%{$stacktrace_args}); my @frames = $trace->frames; splice @frames, $n_frames if @frames && !$want_full_stack; # complete the original $errstr with frame descriptions if (my $first_frame = shift @frames) { my $p = $self->{display_frame_param}; # see L $errstr .= $self->{display_frame}->($first_frame, 1, $p); # 1 means "is first" $errstr .= $self->{display_frame}->($_, undef, $p) foreach @frames; } return $errstr; } # ====================================================================== # SUBROUTINES (NOT METHODS) -- used as callback # ====================================================================== sub _default_display_frame { my ($frame, $is_first, $p) = @_; # let Devel::StackTrace::Frame compute a string representation my $str = $frame->as_string($is_first, $p); # if this seems to be a method call, make it look like so $str =~ s{^ (\t)? # optional tab -- capture in $1 ([\w:]+) # class name -- capture in $2 :: (\w+) # method name -- capture in $3 \(' # beginning arg list ( \2 # first arg: again the class name (?: = [^']+)? # .. possibly followed by the ref addr ) ' # end of fist arg -- capture in $4 (?: ,\h* )? # possibly followed by a comma } {$1$4->$3(}x; # rewrite as a method call $str .= "." if $is_first; # because Carp does add this colon to the first line return "$str\n"; } # ====================================================================== # IMPORT API (CLASS METHOD) # ====================================================================== sub import { my ($class, @import_list) = @_; my $calling_pkg = caller(0); # find out what the importer wants my ($exports, $options) = $class->parse_import_list(@import_list); # default exports : carp, croak and confess keys %$exports or $exports = { map {$_ => {name => $_}} @{$export_groups{carp}} }; # if required, apply prefix and suffix if (my $prefix = $options->{prefix}) { substr $exports->{$_}{name}, 0, 0, $prefix foreach keys %$exports; } if (my $suffix = $options->{suffix}) { $exports->{$_}{name} .= $suffix foreach keys %$exports; } # export the requested symbols into the caller while (my ($method, $hash) = each %$exports) { no strict "refs"; my $export_as = $hash->{as} // $hash->{name}; *{"$calling_pkg\::$export_as"} = sub (@) { # if present, the current value of %CARP_OBJECT_CONSTRUCTOR within the calling package # will be passed to the constructor my $constructor_args = *{"$calling_pkg\::CARP_OBJECT_CONSTRUCTOR"}{HASH} // {}; # if present, the current value of @CARP_NOT within the calling package # will be passed as 'ignore_package' to the Devel::StackTrace constructor if (my $carp_not = *{"$calling_pkg\::CARP_NOT"}{ARRAY}) { $constructor_args->{ignore_package} = $carp_not; } # build a one-shot instance and call the requested method $class->new(%$constructor_args)->$method(@_); }; } # install an import function into the caller if -reexport is requested if ($options->{reexport}) { no strict "refs"; not *{"$calling_pkg\::import"}{CODE} or $class->new->croak("use $class -reexport => ... : $calling_pkg already has an import function"); *{"$calling_pkg\::import"} = sub { my $further_calling_pkg = caller(0); foreach my $symbol (keys %$exports) { *{"$further_calling_pkg\::$symbol"} = *{"$calling_pkg\::$symbol"}{CODE}; } }; } # populate %CARP_OBJECT_CONSTRUCTOR within the caller from the 'constructor_args' option if (my $args = $options->{constructor_args}) { ref $args eq 'HASH' or $class->new->croak("use $class {-constructor_args => ...} : must be a hashref"); no strict 'refs'; *{"$calling_pkg\::CARP_OBJECT_CONSTRUCTOR"} = $args; } } sub parse_import_list { my ($class, @import_list) = @_; my %exports; my %options; my $last_export; # loop on import args while (my $arg = shift @import_list) { # hashref : options to the exporter if (my $ref = ref $arg) { $ref eq 'HASH' or $class->new->croak("$class->import() cannot handle $ref references"); while (my ($k, $v) = each %$arg) { if ($k =~ /^-(prefix|suffix|constructor_args|reexport)$/) { $options{$1} = $v; } elsif ($k eq '-as') { $last_export or $class->new->croak("use $class ... : {-as => ...} must follow the name of a symbol to import"); $exports{$last_export}{as} = $v; } else { $class->new->croak("$class->import(): unknown option: '$k'"); } } } # the 'reexport' option -- different syntax for better readability, for ex: use C:O -reexport => qw/carp croak/; elsif ($arg eq '-reexport') { $options{reexport} = 1; } # groups of symbols (:carp, :all) elsif ($arg =~ /^[:-](\w+)/) { undef $last_export; my $group = $export_groups{$1} or $class->new->croak("use $class qw/:$1/ : group '$1' is not exported"); $exports{$_}{name} = $_ foreach @$group; } # individual symbols elsif ($arg =~ /^(croak|carp|confess|cluck)$/) { $exports{$arg}{name} = $arg; $last_export = $arg; } # something that looks like a regexp -- probably intended for Carp::Clan-like behaviour elsif ($arg =~ /^\^/ or $arg =~ /[|(]/ ) { $options{constructor_args}{clan} = $arg; } else { $class->new->croak("use $class '$arg' : this symbol is not exported"); } } return (\%exports, \%options); } 1; __END__ =head1 NAME Carp::Object - a replacement for Carp or Carp::Clan, object-oriented =head1 SYNOPSIS =head2 Object-oriented API use Carp::Object (); my $carper = Carp::Object->new(%options); # warn of error (from the perspective of caller) $carper->carp("this is very wrong") if some_bad_condition(); # die of error (from the perspective of caller) $carper->croak("that's a dead end") if some_deadly_condition(); # warn with full stacktrace $carper->cluck("this is very wrong"); # die with full stacktrace $carper->confess("that's a dead end"); =head2 Functional API use Carp::Object qw/:all/; # many other import options are available, see below our %CARP_OBJECT_CONSTRUCTOR = (...); # optional opportunity to tune the carping behaviour our @CARP_NOT = (...); # optional opportunity to exclude packages from stack traces # warn of error (from the perspective of caller) carp "this is very wrong" if some_bad_condition(); # die of error (from the perspective of caller) croak "that's a dead end" if some_deadly_condition(); # full stacktrace cluck "this is very wrong"; confess "that's a dead end"; # temporary change some parameters, like for example the "clan" of modules to ignore { local %CARP_OBJECT_CONSTRUCTOR = (clan => qw(^(Foo|Bar))); croak "wrong call to Foo->.. or to Bar->.." if $something_is_wrong; } =head1 DESCRIPTION This is an object-oriented alternative to L or L, for reporting errors in modules from the perspective of the caller instead of reporting the internal implementation line where the error occurs. L or L were designed long ago, at a time when Perl had no support yet for object-oriented programming; therefore they only have a functional API that is not very well suited for extensions. The present module attemps to mimic the same behaviour, but with an object-oriented implementation that offers more tuning options, and also supports errors raised as Exception objects. Unlike L or L, where the presentation of stack frames is hard-coded, here it is delegated to L. This means that clients can also take advantage of options in L to tune the output -- or even replace it by another class. Clients can choose between the object-oriented API, presented in the next chapter, or a traditional functional API compatible with L or L, presented in the following chapter. B: this module is very young and not battle-proofed yet. Despite many efforts to make it behave as close as possible to the original L, there might be some edge cases where it is not strictly equivalent. If you encounter such situations, please open an issue at L. =head1 METHODS =head2 new use Carp::Object (); # '()' to avoid importing any symbols my $carper = Carp::Object->new(%options); This is the constructor for a "carper" object. Options are : =over =item verbose if true, a 'croak' method call is treated as a 'confess', and a 'carp' is treated as a 'cluck'. =item stacktrace_class The class to be used for inspecting stack traces. Default is L. =item clan A regexp for identifying packages that should be skipped in stack traces, like in L. This option internally computes a C and therefore is incompatible with the C option. =item display_frame A reference to a subroutine for computing a textual representation of a stack frame. The default is L<_default_display_frame>, which is a light wrapper on top of L, with improved representation of method calls. The given subroutine will receive three arguments : =over =item 1. a reference to a L instance =item 2. a boolean flag telling if this is the first stack frame in the list (because the display algorithm is usually different for the first stack frame). =item 3. A hashref of optional parameters. Currently there is only one option C, discribed in L. =back =item display_frame_param The optional hashref to be supplied as third parameter to the C subroutine. =item ignore_class an arrayref of classes that will be passed to L; any class that belongs to or inherits from that list will be ignored in stack traces. C will automatically add itself to the list supplied by the client. =back In addition to these options, the constructor also accepts all options to L, like for example C, C, C, C, etc. =head2 croak Die of error, from the perspective of the caller. =head2 carp Warn of error, from the perspective of the caller. =head2 confess Die of error, with full stack backtrace. =head2 cluck Warn of error, with full stack backtrace. =head2 msg my $msg = $carper->msg($errstr, $n_frames); Build the message to be used for dieing or warning. C<$errstr> is the initial error message; it may be a plain string or an exception object with a stringification method. C<$n_frames> is the number of stack frames to display (usually 1); if undefined, the whole stack trace is displayed. =head1 FUNCTIONAL API: THE IMPORT() METHOD use Carp::Object; # no import list => defaults to (':carp'); # or use Carp::Object @import_list; When using this functional API, subroutines equivalent to their corresponding object-oriented methods are exported into the caller's symbol table: the caller can then call C, C, etc. like with the venerable L module. =head2 Import list The import list accepts the following items : =over =item C, C, C and/or C Individual import of specific routines =item C<:carp> Import group equivalent to the list C, C, C. =item C<:all> Import group equivalent to the list C, C, C, C. =item C<\%options> A hashref within the import list is interpreted as a collection of importing options, in the spirit of L or L. Admitted options are : =over =item C<-as> use Carp::Object carp => {-as => 'complain'}, croak => {-as => 'explode'}; Local name for the last imported function. =item C<-prefix> use Carp::Object qw/carp croak/, {-prefix => 'CO_'}; ... CO_croak "aargh"; Names of imported functions will be prefixed by this string. =item C<-suffix> use Carp::Object qw/carp croak/, {-suffix => '_CO'}; ... croak_CO "ouch"; Names of imported functions will be suffixed by this string. =item C<-constructor_args> use Carp::Object qw/carp croak/, {-constructor_args => {indent => 0}}; The given hashref will be passed to L at each call to an imported function. =back =item C<-reexport> use Carp::Object -reexport => qw/carp croak/; Imported symbols will be reexported into the caller of the caller ! This is useful when several modules from a same family share a common carping module. See L for an example (actually, this was the initial motivation for working on C(). =item I use Carp::Object qw(^(MyClan::|FriendlyOther::)); If the import item "looks like a regexp", it is interpreted as syntactic sugar for C<< use Carp::Object {-constructor_args => {clan => ..}} >>, in order to be compatible with the API of L. The import item "looks like a regexp" if it starts with a C<'^'> character, or contains a C<'|'> or a C<'('>. =back =head2 Global variables When using the functional API, customization of C can be done indirectly through global variables in the calling package. Such variables can be localized in inner blocks if some specific behaviour is needed. =head3 C<%CARP_OBJECT_CONSTRUCTOR> { local %CARP_OBJECT_CONSTRUCTOR = (indent => 0); confess "I'm a great sinner"; # for this call, stack frames will not be indented } The content of this hash will be passed to L at each call to an imported function. =head3 C<@CARP_NOT> The content of this array will be passed as C argument to to L at each call to an imported function. =head3 C<$Carp::Verbose> if true, a 'croak' method call is treated as a 'confess', and a 'carp' is treated as a 'cluck'. =head1 INTERNAL SUBROUTINES =head2 _default_display_frame This is the internal routine for displaying a stack frame. It calls L for doing most of the work. An additional feature is that the presentation string is rewritten for frames that "look like a method call" : instead of C<< Foobar::method('Foobar=...', @other_args) >>, we write C<< Foobar=...->method(@other_args) >>, so that method calls become apparent within the stack trace. A frame "looks like a method call" if the first argument to the routine is a string identical to the class, or reference blessed into that class. =head1 AUTHOR Laurent Dami, Edami at cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2024 by Laurent Dami. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Carp-Object-1.02/t000755000000000000 014615520211 14314 5ustar00unknownunknown000000000000Carp-Object-1.02/t/01_object_oriented_API.t000444000000000000 1064014613472160 21016 0ustar00unknownunknown000000000000use utf8; use strict; use warnings; use Test::More; use Carp::Object (); # =============================================================================== # global vars, can be localized during tests # =============================================================================== our $note_msg; # if true, the error msg is printed out our %ctor_args; # used when building Carp::Object instances our %die_line; # remember source lines where some croaking occurs # =============================================================================== # infrastructure : a couple of packages to check how croak() skips calling packages # =============================================================================== package Serpent; sub induce {Eva->induce} $die_line{+__PACKAGE__} = __LINE__; # NOTE : '+' in the line above prevents __PACKAGE__ from being parsed as a bareword package Eva; sub induce {Adam->eat} $die_line{+__PACKAGE__} = __LINE__; package Adam; sub eat { my $carper = Carp::Object->new(%ctor_args); $carper->croak("that beautiful apple is forbidden"); $die_line{+__PACKAGE__} = __LINE__; } sub salivate { my $carper = Carp::Object->new(%ctor_args); $carper->carp("beware, that beautiful apple is forbidden"); } # =============================================================================== # infrastructure : wrappers around Test::More # =============================================================================== package main; sub croak_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__DIE__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; eval {$code->()}; } sub croak_at_line (&$;$) { my ($code, $line, $test_name) = @_; croak_msg_like \&$code, qr/\bline $line\.$/, $test_name; # NOTE : \&$ above : thanks https://stackoverflow.com/questions/54785472/type-of-arg-1-must-be-block-or-sub-not-subroutine-entry } sub carp_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__WARN__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; $code->(); } # =============================================================================== # beginning of tests # =============================================================================== # basic stuff croak_at_line {Carp::Object->new->croak('aargh')} __LINE__, "croak in main"; croak_msg_like {Carp::Object->new->confess('ouch')} qr/\n.*\n.*\n/, "confess in main"; # check if croaking is at the proper level croak_at_line {Serpent->induce} $die_line{Eva}, "croak at Eva (from Serpent)"; croak_at_line {Eva->induce} $die_line{Eva}, "croak at Eva (from Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main"; # verbose arg transforms a croak into a confess { local %ctor_args = (verbose => 1); # local $note_msg = 1; croak_msg_like {Adam->eat} qr/\n.*\n.*\n/, "verbose: croak => confess"; croak_msg_like {Adam->eat} qr/Adam->eat\(\)/, "frame rewrite for method calls"; } # global $Carp::Verbose is like the verbose arg { local $Carp::Verbose = 1; croak_msg_like {Adam->eat} qr/\n.*\n.*\n/, "Carp::verbose: croak => confess"; } # frame_filter { local %ctor_args = (verbose => 1, frame_filter => sub {my $raw_frame_ref = shift; my $first_arg = $raw_frame_ref->{args}[0] // ""; return $first_arg !~ /^CODE\b/}); # stupid criteria, just for the test croak_msg_like {Serpent->induce} qr/eval.*$/, "frame main::croak_msg was filtered out"; } # clan of packages to ignore { local %ctor_args = (clan => qr/^(Adam|Eva|Serpent)$/); croak_at_line {Serpent->induce} __LINE__, "croak in main (Serpent)"; croak_at_line {Eva->induce} __LINE__, "croak in main (Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main (Adam)"; } # custom display_frame() { local %ctor_args = (verbose => 1, display_frame => sub {my $frame = shift; return sprintf "line %d in %s\n", $frame->line, $frame->package}); croak_msg_like {Serpent->induce} qr/^line \d+ in Eva$/m, "custom sub for display_frame"; } # carp carp_msg_like {Adam->salivate} qr/beware/, "carp method"; done_testing; Carp-Object-1.02/t/02_functional_API.t000444000000000000 635314613472177 20020 0ustar00unknownunknown000000000000use utf8; use strict; use warnings; use Test::More; # =============================================================================== # global vars, can be localized during tests # =============================================================================== our $note_msg; # if true, the error msg is printed out our %die_line; # remember source lines where some croaking occurs # =============================================================================== # infrastructure : a couple of packages to check how croak() skips calling packages # =============================================================================== package Serpent; sub induce {Eva->induce} $die_line{+__PACKAGE__} = __LINE__; # NOTE : '+' in the line above prevents __PACKAGE__ from being parsed as a bareword package Eva; sub induce {Adam->eat} $die_line{+__PACKAGE__} = __LINE__; package Adam; use Carp::Object carp => {-as => 'acarp'}, croak => {-as => 'acroak'}; our %CARP_OBJECT_CONSTRUCTOR; sub eat { acroak "that beautiful apple is forbidden"; $die_line{+__PACKAGE__} = __LINE__; } sub salivate { acarp "beware, that beautiful apple is forbidden"; } # =============================================================================== # infrastructure : wrappers around Test::More # =============================================================================== package main; use Carp::Object qw/:carp/, {-prefix => 'co_', -suffix => '_wrapped', -constructor_args => {indent => 0}, }; sub croak_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__DIE__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; eval {$code->()}; } sub croak_at_line (&$;$) { my ($code, $line, $test_name) = @_; croak_msg_like \&$code, qr/\bline $line\.$/, $test_name; # NOTE : \&$ above : thanks https://stackoverflow.com/questions/54785472/type-of-arg-1-must-be-block-or-sub-not-subroutine-entry } sub carp_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__WARN__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; $code->(); } # =============================================================================== # beginning of tests # =============================================================================== # imported functions have been renamed croak_at_line {co_croak_wrapped 'aargh'} __LINE__, "croak in main"; croak_msg_like {co_confess_wrapped 'ouch'} qr/\n.*\n.*\n/, "confess in main"; # -constructor_args was handled croak_msg_like {co_confess_wrapped 'oops'} qr/^main.*\neval/m, "no indent"; # check if croaking is at the proper level croak_at_line {Serpent->induce} $die_line{Eva}, "croak at Eva (from Serpent)"; croak_at_line {Eva->induce} $die_line{Eva}, "croak at Eva (from Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main"; # verbose arg transforms a croak into a confess { local %Adam::CARP_OBJECT_CONSTRUCTOR = (verbose => 1); # local $note_msg = 1; croak_msg_like {Adam->eat} qr/\n.*\n.*\n/, "verbose: croak => confess"; } done_testing; Carp-Object-1.02/t/03_reexport.t000444000000000000 545114613472220 17021 0ustar00unknownunknown000000000000use utf8; use strict; use warnings; use Test::More; use FindBin qw/$Bin/; use lib "$Bin/lib"; # =============================================================================== # global vars, can be localized during tests # =============================================================================== our $note_msg; # if true, the error msg is printed out our %die_line; # remember source lines where some croaking occurs # =============================================================================== # infrastructure : a couple of packages to check how croak() skips calling packages # =============================================================================== package Serpent; sub induce {Eva->induce} $die_line{+__PACKAGE__} = __LINE__; # NOTE : '+' in the line above prevents __PACKAGE__ from being parsed as a bareword package Eva; sub induce {Adam->eat} $die_line{+__PACKAGE__} = __LINE__; package Adam; use TestReexport; sub eat { croak "that beautiful apple is forbidden"; $die_line{+__PACKAGE__} = __LINE__; } # =============================================================================== # infrastructure : wrappers around Test::More # =============================================================================== package main; use TestReexport; sub croak_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__DIE__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; eval {$code->()}; } sub croak_at_line (&$;$) { my ($code, $line, $test_name) = @_; croak_msg_like \&$code, qr/\bline $line\.$/, $test_name; # NOTE : \&$ above : thanks https://stackoverflow.com/questions/54785472/type-of-arg-1-must-be-block-or-sub-not-subroutine-entry } sub carp_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__WARN__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; $code->(); } # =============================================================================== # beginning of tests # =============================================================================== # basic calls from main croak_at_line {croak 'aargh'} __LINE__, "croak in main"; croak_msg_like {confess 'ouch'} qr/\n.*\n.*\n/, "confess in main"; # check if croaking is at the proper level croak_at_line {Serpent->induce} $die_line{Eva}, "croak at Eva (from Serpent)"; croak_at_line {Eva->induce} $die_line{Eva}, "croak at Eva (from Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main"; # verbose arg transforms a croak into a confess { no warnings 'once'; local %TestReexport::CARP_OBJECT_CONSTRUCTOR = (verbose => 1); croak_msg_like {Adam->eat} qr/\n.*\n.*\n/, "verbose: croak => confess"; } done_testing; Carp-Object-1.02/t/04_clan_like.t000444000000000000 437614613472265 17111 0ustar00unknownunknown000000000000use utf8; use strict; use warnings; use Test::More; # =============================================================================== # global vars, can be localized during tests # =============================================================================== our $note_msg; # if true, the error msg is printed out our %die_line; # remember source lines where some croaking occurs # =============================================================================== # infrastructure : a couple of packages to check how croak() skips calling packages # =============================================================================== package Serpent; sub induce {Eva->induce} $die_line{+__PACKAGE__} = __LINE__; # NOTE : '+' in the line above prevents __PACKAGE__ from being parsed as a bareword package Eva; sub induce {Adam->eat} $die_line{+__PACKAGE__} = __LINE__; package Adam; use Carp::Object qw/^(Adam|Eva|Serpent)$/; sub eat { croak "that beautiful apple is forbidden"; $die_line{+__PACKAGE__} = __LINE__; } sub salivate { carp "beware, that beautiful apple is forbidden"; } # =============================================================================== # infrastructure : wrappers around Test::More # =============================================================================== package main; sub croak_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__DIE__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; eval {$code->()}; } sub croak_at_line (&$;$) { my ($code, $line, $test_name) = @_; croak_msg_like \&$code, qr/\bline $line\.$/, $test_name; # NOTE : \&$ above : thanks https://stackoverflow.com/questions/54785472/type-of-arg-1-must-be-block-or-sub-not-subroutine-entry } # =============================================================================== # beginning of tests # =============================================================================== croak_at_line {Serpent->induce} __LINE__, "croak in main (Serpent)"; croak_at_line {Eva->induce} __LINE__, "croak in main (Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main (Adam)"; done_testing; Carp-Object-1.02/t/05_carp_not.t000444000000000000 441414613472313 16761 0ustar00unknownunknown000000000000use utf8; use strict; use warnings; use Test::More; # =============================================================================== # global vars, can be localized during tests # =============================================================================== our $note_msg; # if true, the error msg is printed out our %die_line; # remember source lines where some croaking occurs # =============================================================================== # infrastructure : a couple of packages to check how croak() skips calling packages # =============================================================================== package Serpent; sub induce {Eva->induce} $die_line{+__PACKAGE__} = __LINE__; # NOTE : '+' in the line above prevents __PACKAGE__ from being parsed as a bareword package Eva; sub induce {Adam->eat} $die_line{+__PACKAGE__} = __LINE__; package Adam; use Carp::Object; our @CARP_NOT = qw/Adam Eva Serpent/; sub eat { croak "that beautiful apple is forbidden"; $die_line{+__PACKAGE__} = __LINE__; } sub salivate { carp "beware, that beautiful apple is forbidden"; } # =============================================================================== # infrastructure : wrappers around Test::More # =============================================================================== package main; sub croak_msg_like (&$;$) { my ($code, $regexp, $test_name) = @_; local $SIG{__DIE__} = sub {note $_[0] if $note_msg; like $_[0], $regexp, $test_name}; eval {$code->()}; } sub croak_at_line (&$;$) { my ($code, $line, $test_name) = @_; croak_msg_like \&$code, qr/\bline $line\.$/, $test_name; # NOTE : \&$ above : thanks https://stackoverflow.com/questions/54785472/type-of-arg-1-must-be-block-or-sub-not-subroutine-entry } # =============================================================================== # beginning of tests # =============================================================================== croak_at_line {Serpent->induce} __LINE__, "croak in main (Serpent)"; croak_at_line {Eva->induce} __LINE__, "croak in main (Eva)"; croak_at_line {Adam->eat} __LINE__, "croak in main (Adam)"; done_testing; Carp-Object-1.02/t/lib000755000000000000 014615520211 15062 5ustar00unknownunknown000000000000Carp-Object-1.02/t/lib/TestReexport.pm000444000000000000 15014613012532 20201 0ustar00unknownunknown000000000000package TestReexport; use utf8; use strict; use warnings; use Carp::Object -reexport => qw/:carp/; 1;