diff --git a/dev/import-perl5/patches/test.pl.patch b/dev/import-perl5/patches/test.pl.patch index 5eab8f277..14f3699aa 100644 --- a/dev/import-perl5/patches/test.pl.patch +++ b/dev/import-perl5/patches/test.pl.patch @@ -1,46 +1,17 @@ --- perl5/t/test.pl +++ t/test.pl -@@ -1,3 +1,10 @@ +@@ -1,3 +1,7 @@ +# -------------------------------------------- -+# Modified t/test.pl for running Perl test suite with PerlOnJava: -+# -+# - added subroutine `skip_internal` to workaround the use of non-local goto (`last SKIP`). -+# - no other changes. ++# Modified t/test.pl for running Perl test suite with PerlOnJava +# -------------------------------------------- + # # t/test.pl - most of Test::More functionality without the fuss -@@ -587,16 +594,44 @@ +@@ -587,16 +591,16 @@ last SKIP; } -+sub skip_internal { -+ my $why = shift; -+ my $n = @_ ? shift : 1; -+ my $bad_swap; -+ my $both_zero; -+ { -+ local $^W = 0; -+ $bad_swap = $why > 0 && $n == 0; -+ $both_zero = $why == 0 && $n == 0; -+ } -+ if ($bad_swap || $both_zero || @_) { -+ my $arg = "'$why', '$n'"; -+ if (@_) { -+ $arg .= join(", ", '', map { qq['$_'] } @_); -+ } -+ die qq[$0: expected skip(why, count), got skip($arg)\n]; -+ } -+ for (1..$n) { -+ _print "ok $test # skip $why\n"; -+ $test = $test + 1; -+ } -+ local $^W = 0; -+ # last SKIP; -+ 1; -+} -+ sub skip_if_miniperl { - skip(@_) if is_miniperl(); + ## PerlOnJava is not miniperl diff --git a/src/main/java/org/perlonjava/codegen/EmitBlock.java b/src/main/java/org/perlonjava/codegen/EmitBlock.java index 2dbf29cfb..166ce3ec1 100644 --- a/src/main/java/org/perlonjava/codegen/EmitBlock.java +++ b/src/main/java/org/perlonjava/codegen/EmitBlock.java @@ -99,6 +99,44 @@ public static void emitBlock(EmitterVisitor emitterVisitor, BlockNode node) { element.accept(voidVisitor); } + // Check for non-local control flow after each statement in labeled blocks + // Only for simple blocks to avoid ASM VerifyError + if (node.isLoop && node.labelName != null && i < list.size() - 1 && list.size() <= 3) { + // Check if block contains loop constructs (they handle their own control flow) + boolean hasLoopConstruct = false; + for (Node elem : list) { + if (elem instanceof For1Node || elem instanceof For3Node) { + hasLoopConstruct = true; + break; + } + } + + if (!hasLoopConstruct) { + Label continueBlock = new Label(); + + // if (!RuntimeControlFlowRegistry.hasMarker()) continue + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/RuntimeControlFlowRegistry", + "hasMarker", + "()Z", + false); + mv.visitJumpInsn(Opcodes.IFEQ, continueBlock); + + // Has marker: check if it matches this loop + mv.visitLdcInsn(node.labelName); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/RuntimeControlFlowRegistry", + "checkLoopAndGetAction", + "(Ljava/lang/String;)I", + false); + + // If action != 0, jump to nextLabel (exit block) + mv.visitJumpInsn(Opcodes.IFNE, nextLabel); + + mv.visitLabel(continueBlock); + } + } + // NOTE: Registry checks are DISABLED in EmitBlock because: // 1. They cause ASM frame computation errors in nested/refactored code // 2. Bare labeled blocks (like TODO:) don't need non-local control flow diff --git a/src/main/java/org/perlonjava/parser/StatementParser.java b/src/main/java/org/perlonjava/parser/StatementParser.java index 18fcb22e7..f19332eb5 100644 --- a/src/main/java/org/perlonjava/parser/StatementParser.java +++ b/src/main/java/org/perlonjava/parser/StatementParser.java @@ -237,9 +237,6 @@ public static Node parseIfStatement(Parser parser) { elseBranch = parseIfStatement(parser); } - // Use a macro to emulate Test::More SKIP blocks - TestMoreHelper.handleSkipTest(parser, thenBranch); - return new IfNode(operator.text, condition, thenBranch, elseBranch, parser.tokenIndex); } diff --git a/src/main/java/org/perlonjava/parser/StatementResolver.java b/src/main/java/org/perlonjava/parser/StatementResolver.java index fbca51260..d8a62a5d3 100644 --- a/src/main/java/org/perlonjava/parser/StatementResolver.java +++ b/src/main/java/org/perlonjava/parser/StatementResolver.java @@ -572,11 +572,6 @@ yield dieWarnNode(parser, "die", new ListNode(List.of( parser.ctx.symbolTable.exitScope(scopeIndex); - if (label != null && label.equals("SKIP")) { - // Use a macro to emulate Test::More SKIP blocks - TestMoreHelper.handleSkipTest(parser, block); - } - yield new For3Node(label, true, null, null, diff --git a/src/main/java/org/perlonjava/parser/TestMoreHelper.java b/src/main/java/org/perlonjava/parser/TestMoreHelper.java deleted file mode 100644 index 75d775021..000000000 --- a/src/main/java/org/perlonjava/parser/TestMoreHelper.java +++ /dev/null @@ -1,52 +0,0 @@ -package org.perlonjava.parser; - -import org.perlonjava.astnode.*; -import org.perlonjava.runtime.GlobalVariable; -import org.perlonjava.runtime.NameNormalizer; - -import java.util.List; - -public class TestMoreHelper { - - // Use a macro to emulate Test::More SKIP blocks - static void handleSkipTest(Parser parser, BlockNode block) { - // Locate skip statements - // TODO create skip visitor - for (Node node : block.elements) { - if (node instanceof BinaryOperatorNode op) { - if (!op.operator.equals("(")) { - // Possible if-modifier - if (op.left instanceof BinaryOperatorNode left) { - handleSkipTestInner(parser, left); - } - if (op.right instanceof BinaryOperatorNode right) { - handleSkipTestInner(parser, right); - } - } else { - handleSkipTestInner(parser, op); - } - } - } - } - - private static void handleSkipTestInner(Parser parser, BinaryOperatorNode op) { - if (op.operator.equals("(")) { - int index = op.tokenIndex; - if (op.left instanceof OperatorNode sub && sub.operator.equals("&") && sub.operand instanceof IdentifierNode subName && subName.name.equals("skip")) { - // skip() call - // op.right contains the arguments - - // Becomes: `skip_internal() && last SKIP` - // But first, test if the subroutine exists - String fullName = NameNormalizer.normalizeVariableName(subName.name + "_internal", parser.ctx.symbolTable.getCurrentPackage()); - if (GlobalVariable.existsGlobalCodeRef(fullName)) { - subName.name = fullName; - op.operator = "&&"; - op.left = new BinaryOperatorNode("(", op.left, op.right, index); - op.right = new OperatorNode("last", - new ListNode(List.of(new IdentifierNode("SKIP", index)), index), index); - } - } - } - } -} diff --git a/src/main/perl/lib/Test/More.pm b/src/main/perl/lib/Test/More.pm index 6ef2e2be9..ddb69cd9d 100644 --- a/src/main/perl/lib/Test/More.pm +++ b/src/main/perl/lib/Test/More.pm @@ -16,7 +16,6 @@ our @EXPORT = qw( pass fail diag note done_testing is_deeply subtest use_ok require_ok BAIL_OUT skip - skip_internal eq_array eq_hash eq_set ); @@ -286,21 +285,15 @@ sub BAIL_OUT { exit 255; } -sub skip { - die "Test::More::skip() is not implemented"; -} - -# Workaround to avoid non-local goto (last SKIP). -# The skip_internal subroutine is called from a macro in TestMoreHelper.java -# -sub skip_internal { +sub skip($;$) { my ($name, $count) = @_; + $count ||= 1; for (1..$count) { $Test_Count++; my $result = "ok"; print "$Test_Indent$result $Test_Count # skip $name\n"; } - return 1; + last SKIP; } # Legacy comparison functions - simple implementations using is_deeply diff --git a/src/main/perl/lib/Test2/Handle.pm b/src/main/perl/lib/Test2/Handle.pm new file mode 100644 index 000000000..fea091828 --- /dev/null +++ b/src/main/perl/lib/Test2/Handle.pm @@ -0,0 +1,296 @@ +package Test2::Handle; +use strict; +use warnings; + +our $VERSION = '1.302219'; + +require Carp; +require Test2::Util; + +use Test2::Util::HashBase qw{ + +namespace + +base + +include + +import + +stomp +}; + +my $NS = 1; + +# Things we do not want to import automagically +my %EXCLUDE_SYMBOLS = ( + BEGIN => 1, + DESTROY => 1, + DOES => 1, + END => 1, + VERSION => 1, + does => 1, + can => 1, + isa => 1, + import => 1, +); + +sub DEFAULT_HANDLE_BASE { Carp::croak("Not Implemented") } + +sub HANDLE_BASE { $_[0]->{+BASE} } + +sub HANDLE_NAMESPACE { $_[0]->{+NAMESPACE} } + +sub _HANDLE_INCLUDE { + my $self = shift; + + return $self->{+IMPORT} if $self->{+IMPORT}; + + my $ns = $self->{+NAMESPACE}; + + my $line = __LINE__ + 3; + $self->{+IMPORT} = eval <<" EOT" or die $@; +#line $line ${ \__FILE__ } + package $ns; + sub { + my (\$module, \$caller, \@imports) = \@_; + unless (eval { require(Test2::Util::pkg_to_file(\$module)); 1 }) { + my \$err = \$@; + chomp(\$err); + \$err =~ s/\.\$//; + die "\$err (called from \$caller->[1] line \$caller->[2]).\n"; + } + \$module->import(\@imports); + }; + EOT +} + +sub HANDLE_INCLUDE { + my $self = shift; + my ($mod, @imports) = @_; + @imports = @{$imports[0]} if @imports == 1 && ref($imports[0]) eq 'ARRAY'; + + my $caller = [caller]; + + $self->_HANDLE_INCLUDE->($mod, $caller, @imports); + $self->_HANDLE_WRAP($_) for @imports; +} + +sub HANDLE_SUBS { + my $self = shift; + + my @out; + + my $seen = {class => {}, export => {}}; + my @todo = ($self->{+NAMESPACE}); + + while (my $check = shift @todo) { + next if $seen->{class}->{$check}++; + + no strict 'refs'; + my $stash = \%{"$check\::"}; + push @out => grep { !$seen->{export}->{$_}++ && !$EXCLUDE_SYMBOLS{$_} && $_ !~ m/^_/ && $check->can($_) } keys %$stash; + push @todo => @{"$check\::ISA"}; + } + + return @out; +} + +sub _HANDLE_WRAP { + my $self = shift; + my ($name) = @_; + + return if $self->SUPER::can($name); + + my $wrap = sub { + my $handle = shift; + my $ns = $handle->{+NAMESPACE}; + my @caller = caller; + my $sub = $ns->can($name) or die qq{"$name" is not provided by this T2 handle at $caller[1] line $caller[2].\n}; + goto &$sub; + }; + + { + no strict 'refs'; + *$name = $wrap; + } + + return $wrap; +} + +sub import { + my $class = shift; + my ($name, %params) = @_; + + my $self = $class->new(%params); + + my $caller = caller; + no strict 'refs'; + *{"$caller\::$name"} = sub() { $self }; +} + +sub init { + my $self = shift; + + my $stomp = $self->{+STOMP} ||= 0; + my $inc = $self->{+INCLUDE} ||= []; + my $base = $self->{+BASE} ||= $self->DEFAULT_HANDLE_BASE; + + require(Test2::Util::pkg_to_file($base)); + + my $new; + my $ns = $self->{+NAMESPACE} ||= do { $new = 1; __PACKAGE__ . '::GEN_' . $NS++ }; + + my $stash = do { no strict 'refs'; \%{"$ns\::"} }; + + Carp::croak("Namespace '$ns' already appears to be populated") if !$stomp && keys %$stash; + + $INC{Test2::Util::pkg_to_file($ns)} ||= __FILE__ if $new; + + { + no strict 'refs'; + push @{"$ns\::ISA"} => $self->{+BASE}; + } + + if (my $include = $self->{+INCLUDE}) { + my $r = ref($include); + if ($r eq 'ARRAY') { + $self->HANDLE_INCLUDE(ref($_) ? @{$_} : $_) for @$include; + } + elsif ($r eq 'HASH') { + $self->HANDLE_INCLUDE($_ => $include->{$_}) for keys %$include; + } + else { + die "Not sure what to do with '$r'"; + } + } +} + +sub can { + my $self = shift; + my ($name) = @_; + + my $sub = $self->SUPER::can($name); + return $sub if $sub; + + return undef unless ref $self; + + $self->{+NAMESPACE}->can($name) or return undef; + return $self->_HANDLE_WRAP($name); +} + +sub AUTOLOAD { + my ($self) = @_; + + my ($name) = (our $AUTOLOAD =~ m/^(?:.*::)?([^:]+)$/); + return if $EXCLUDE_SYMBOLS{$name}; + + my $wrap = $self->_HANDLE_WRAP($name); + goto &$wrap; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Handle - Base class for Test2 handles used in V# bundles. + +=head1 DESCRIPTION + +This is what you interact with when you use the C function in a test that +uses L. + +=head1 SYNOPSIS + +=head2 RECOMMENDED + + use Test2::V1; + + my $handle = T2(); + + $handle->ok(1, "Passing Test"); + +=head2 WITHOUT SUGAR + + use Test2::Handle(); + + my $handle = Test2::Handle->new(base => 'Test2::V1::Base'); + + $handle->ok(1, "Passing test"); + +=head1 METHODS + +Most methods are delegated to the base class provided at construction. There +are however a few methods that are defined by this package itself. + +=over 4 + +=item $base = $class_or_inst->DEFAULT_HANDLE_BASE + +Get the default handle base. This throws an exception on the base handle class, +you should override it in a subclass. + +=item $base = $inst->HANDLE_BASE + +In this base class this method always throws an exception. In a subclass it +should return the default base class to use for that subclass. + +=item $namespace = $inst->HANDLE_NAMESPACE + +Get the namespace used to store function we wrap as methods. + +=item @sub_names = $inst->HANDLE_SUBS + +Get a list of all subs available in the handle namespace. + +=item $inst->HANDLE_INCLUDE($package, @subs) + +Import the specified subs from the specified package into our internal +namespace. + +=item $inst = $class->import() + +Used to create a C sub in your namsepace at import. + +=item $inst->init() + +Internally used to intialize and validate the handle object. + +=item AUTOLOAD + +Internally used to wrap functions as methods. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/src/main/perl/lib/Test2/V1.pm b/src/main/perl/lib/Test2/V1.pm new file mode 100644 index 000000000..0016663e7 --- /dev/null +++ b/src/main/perl/lib/Test2/V1.pm @@ -0,0 +1,1102 @@ +package Test2::V1; +use strict; +use warnings; + +our $VERSION = '1.302219'; + +use Carp qw/croak/; + +use Test2::V1::Base(); +use Test2::V1::Handle(); + +use Test2::Plugin::ExitSummary(); +use Test2::Plugin::SRand(); +use Test2::Plugin::UTF8(); +use Test2::Tools::Target(); + +# Magic reference to check against later +my $SET = \'set'; + +# Lists of pragmas and plugins +my @PRAGMAS = qw/strict warnings/; +my @PLUGINS = qw/utf8 srand summary target/; + +sub import { + my $class = shift; + + my $caller = caller; + + croak "Got One or more undefined arguments, this usually means you passed in a single-character flag like '-p' without quoting it, which conflicts with the -p builtin" + if grep { !defined($_) } @_; + + my ($requested_exports, $options) = $class->_parse_args(\@_); + + my $pragmas = $class->_compute_pragmas($options); + my $plugins = $class->_compute_plugins($options); + + my ($handle_name, $handle) = $class->_build_handle($options); + my $ns = $handle->HANDLE_NAMESPACE; + + unshift @$requested_exports => $handle->HANDLE_SUBS() if delete $options->{'-import'}; + + unshift @$requested_exports => grep { my $p = prototype($ns->can($_)); $p && $p =~ '&' } $handle->HANDLE_SUBS() if delete $options->{'-x'}; + + my $exports = $class->_build_exports($handle, $requested_exports); + unless (delete $options->{'-no-T2'}) { + my $h = $handle; + $exports->{$handle_name} = sub() { $h }; + } + + croak "Unknown option(s): " . join(', ', sort keys %$options) if keys %$options; + + strict->import() if $pragmas->{strict}; + 'warnings'->import() if $pragmas->{warnings}; + Test2::Plugin::UTF8->import() if $plugins->{utf8}; + Test2::Plugin::ExitSummary->import() if $plugins->{summary}; + + if (my $set = $plugins->{srand}) { + Test2::Plugin::SRand->import((ref($set) && "$set" ne "$SET") ? $set->{seed} : ()); + } + + if (my $target = $plugins->{target}) { + Test2::Tools::Target->import_into($caller, $plugins->{target}) unless "$target" eq "$SET"; + } + + for my $exp (keys %$exports) { + no strict 'refs'; + *{"$caller\::$exp"} = $exports->{$exp}; + } +} + +sub _build_exports { + my $class = shift; + my ($handle, $requested) = @_; + + my %exports; + + while (my $exp = shift @$requested) { + if ($exp =~ m/^!(.+)$/) { + delete $exports{$1}; + next; + } + + my $code = $handle->HANDLE_NAMESPACE->can($exp) or croak "requested export '$exp' is not available"; + + my $args = shift @$requested if @$requested && ref($requested->[0]) eq 'HASH'; + + my $name = $exp; + if ($args) { + $name = delete $args->{-as} if $args->{-as}; + $name = delete($args->{-prefix}) . $name if $args->{-prefix}; + $name = $name . delete($args->{-postfix}) if $args->{-postfix}; + } + + $exports{$name} = $code; + } + + return \%exports; +} + +sub _build_handle { + my $class = shift; + my ($options) = @_; + + my $handle_opts = delete $options->{'-T2'} || {}; + my $handle_name = delete $handle_opts->{'-as'} || delete $handle_opts->{'as'} || 'T2'; + my $handle = Test2::V1::Handle->new(%$handle_opts); + + return ($handle_name, $handle); +} + +sub _compute_plugins { + my $class = shift; + my ($options) = @_; + + my $plugins = { summary => $SET }; + + if (my $plug = delete $options->{'-plugins'}) { + if (ref($plug)) { + $plugins = $plug; + } + else { + $plugins = { map { $_ => $SET } @PLUGINS }; + } + } + + for my $plug (@PLUGINS) { + my $set = delete $options->{"-$plug"}; + $plugins->{$plug} = $set if $set && "$set" ne "$SET"; + $plugins->{$plug} = $set unless defined $plugins->{$plug}; + } + + return $plugins; +} + +sub _compute_pragmas { + my $class = shift; + my ($options) = @_; + + my $pragmas = {}; + if (my $prag = delete $options->{'-pragmas'}) { + if (ref($prag) && "$prag" ne "$SET") { + $pragmas = $prag; + } + else { + $pragmas = { map { $_ => $SET } @PRAGMAS }; + } + } + + for my $prag (@PRAGMAS) { + my $set = delete $options->{"-$prag"}; + $pragmas->{$prag} = $set if $set && "$set" ne "$SET"; + $pragmas->{$prag} = $set unless defined $pragmas->{$prag}; + } + + return $pragmas +} + +sub _parse_args { + my $class = shift; + my ($args) = @_; + + my (@exports, %options); + + while (my $arg = shift @$args) { + $arg = '-T2' if $arg eq 'T2'; + push @exports => $arg and next unless substr($arg, 0, 1) eq '-'; + $options{$arg} = shift @$args and next if $arg eq '-target'; + $options{$arg} = (@$args && (ref($args->[0]) || "$args->[0]" eq "1" || "$args->[0]" eq "0")) ? shift @$args : $SET; + } + + if (my $inc = delete $options{'-include'}) { + $options{'-T2'}->{include} = $inc; + } + + for my $key (keys %options) { + next unless $key =~ m/^-([ipP]{1,3})$/; + delete $options{$key}; + for my $flag (split //, $1) { + $options{"-$flag"} = 1; + } + } + + $options{'-import'} ||= 1 if delete $options{'-i'}; + $options{'-pragmas'} ||= 1 if delete $options{'-p'}; + $options{'-plugins'} ||= 1 if delete $options{'-P'}; + + return (\@exports, \%options); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::V1 - V1 edition of the Test2 recommended bundle. + +=head1 DESCRIPTION + +This is the first sequel to L. This module is recommended over +L for new tests. + +=head2 Key differences from L + +=over 4 + +=item Only 1 export by default: T2() + +=item No pragmas by default + +=item srand and utf8 are not enabled by default + +=item Easy to still import everything + +=item East to still enable pragmas + +=back + +=head1 NAMING, USING, DEPENDING + +This bundle should not change in a I incompatible way. Some minor +breaking changes, specially bugfixes, may be allowed. If breaking changes are +needed then a new C module should be released instead. + +Adding new optional exports, and new methods on the T2() handle are not +considered breaking changes, and are allowed without bumping the V# number. +Adding new plugin shortcuts is also allowed, but they cannot be added to the +C<-P> or C<-plugins> shortcuts without a bump in V# number. + +As new C modules are released old ones I be moved to different cpan +distributions. You should always use a specific bundle version and list that +version in your distributions testing requirements. You should never simply +list L as your modules dep, instead list the specific bundle, or +tools and plugins you use directly in your metadata. + +See the L section for an explanation of why L was +created. + +=head1 SYNOPSIS + +=head2 RECOMMENDED + + use Test2::V1 -utf8; + + T2->ok(1, "pass"); + + T2->is({1 => 1}, {1 => 1}, "Structures Match"); + + # Note that prototypes do not work in method form: + my @foo = (1, 2, 3); + T2->is(scalar(@foo), 3, "Needed to force scalar context"); + + T2->done_testing; + +=head2 WORK LIKE V0 DID + + use Test2::V1 -ipP; + + ok(1, "pass"); + + is({1 => 1}, {1 => 1}, "Structures Match"); + + my @foo = (1, 2, 3); + is(@foo, 3, "Prototype forces @foo into scalar context"); + + # You still have access to T2 + T2->ok(1, "Another Pass"); + + done_testing; + +The C<-ipP> argument is short for C<-include, -pragmas, -plugins> which together enable all +pragmas, plugins, and import all symbols. + +B The order in which C, C

, and C

appear is not important; +C<-Ppi> and C<-piP> and any other order are all perfectly valid. + +=head2 IMPORT ARGUMENT GUIDE + +=over 4 + +=item C<-P> or C<-plugins> + +Shortcut to include the following plugins: L, +L, L. + +=item C<-p> or C<-pragmas> + +Shortcut to enable the following pragmas: C, C. + +=item C<-i> or C<-import> + +Shortcut to import all possible exports. + +=item C<-x> + +Shortcut to import any sub that has '&' in its prototype, things like +C<< dies { ... } >>, C<< warns { ... } >>, etc. + +While these can be used in method form: C<< T2->dies(sub { ... }) >> it is a +little less convenient than having them imported. '-x' will import all of +these, and any added in the future or included via an C<< -include => ... >> +import argument. + +=item C<-ipP>, C<-pPi>, C<-pP>, C<-Pix>, etc.. + +The C, C

, C

, and C short options may all be grouped in any order +following a single dash. + +=item C<@EXPORT_LIST> + +Any arguments provided that are not prefixed with a C<-> will be assumed to be +export requests. If there is an exported sub by the given name it will be +imported into your namespace. If there is no such sub an exception will be +thrown. + +=item C + +You can prefix an export name with C to exclude it at import time. This is +really only usedul when combined with C<-import> or C<-i>. + +=item C<< EXPORT_NAME => { -as => "ALT_NAME" } >> + +=item C<< EXPORT_NAME => { -prefix => "PREFIX_" } >> + +=item C<< EXPORT_NAME => { -postfix => "_POSTFIX" } >> + +You may specify a hashref after an export name to rename it, or add a +prefix/postfix to the name. + +=back + +=head2 RENAMING IMPORTS + + use Test2::V1 '-import', '!ok', ok => {-as => 'my_ok'}; + +Explanation: + +=over 4 + +=item '-import' + +Bring in ALL imports, no need to list them all by hand. + +=item '!ok' + +Do not import C (remove it from the list added by '-import') + +=item ok => {-as => 'my_ok'} + +Actually, go ahead and import C but under the name C. + +=back + +If you did not add the C<'!ok'> argument then you would have both C and +C + +=head1 PRAGMAS AND PLUGINS + +B +B + +This is a significant departure from L. + +You can enable all of these with the C<-pP> argument, which is short for +C<-plugins, -pragmas>. C

is short for plugins, and C

is short for +pragmas. When using the single-letter form they may both be together following +a single dash, and can be in any order. They may also be combined with C to +bring in all imports. C<-p> or C<-P> ont heir own are also perfectly valid. + +=over 4 + +=item strict + +You can enable this with any of these arguments: C<-strict>, C<-p>, C<-pragmas>. + +This enables strict for you. + +=item warnings + +You can enable this with any of these arguments: C<-warnings>, C<-p>, C<-pragmas>. + +This enables warnings for you. + +=item srand + +You can enable this in multiple ways: + + use Test2::V1 -srand + use Test2::V1 -P + use Test2::V1 -plugins + +See L. + +This will set the random seed to today's date. + +You can also set a random seed: + + use Test2::V1 -srand => { seed => 'my seed' }; + +=item utf8 + +You can enable this in multiple ways: + + use Test2::V1 -utf8 + use Test2::V1 -P + use Test2::V1 -plugins + +See L. + +This will set the file, and all output handles (including formatter handles), to +utf8. This will turn on the utf8 pragma for the current scope. + +=item summary + +This is turned on by default. + +You can avoid enabling it at import this way: + + use Test2::V1 -summary => 0; + +See L. + +This plugin has no configuration. + +=back + +=head1 ENVIRONMENT VARIABLES + +See L for a list of meaningful environment variables. + +=head1 API FUNCTIONS + +See L for these + +=over 4 + +=item $ctx = T2->context() + +=item $events = T2->intercept(sub { ... }); + +=back + +=head1 THE T2() HANDLE + +The C subroutine imported into your namespace returns an instance of +L. This gives you a handle on all the tools included by +default. It also creates a completely new namespace for use by your test that +can have additional tools added to it. + +=head2 ADDING/OVERRIDING TOOLS IN YOUR T2 HANDLE + + # Method 1 + use Test2::V1 T2 => { + include => [ + ['Test2::Tools::MyTool', 'my_tool', 'my_other_tool'], + ['Data::Dumper', 'Dumper'], + ], + }; + + # Method 2 + use Test2::V1 T2 => { + include => { + 'Test2::Tools::MyTool' => ['my_tool', 'my_other_tool'], + 'Data::Dumper' => 'Dumper', + }, + }; + + # Method 3 (This also works with a hashref instead of an arrayref) + use Test2::V1 -include => [ + ['Test2::Tools::MyTool', 'my_tool', 'my_other_tool'], + ['Data::Dumper', 'Dumper'], + ]; + + # Method 4 + T2->include('Test2::Tools::MyTool', 'my_tool', 'my_other_tool'); + T2->include('Data::Dumper', 'Dumper'); + + # Using them: + + T2->my_tool(...); + + T2->Dumper({hi => 'there'}); + +Note that you MAY override original tools such as ok(), note(), etc. by +importing different copies this way. The first time you do this there should be +no warnings or errors. If you pull in multiple tools of the same name an +redefine warning is likely. + +This also effects exports: + + use Test2::V1 -import, -include => ['Data::Dumper']; + + print Dumper("Dumper can be imported from your include!"); + +=head2 OTHER HANDLE OPTIONS + + use Test2::V1 T2 => { + include => $ARRAYREF_OR_HASHREF, + namespace => $NAMESPACE, + base => $BASE_PACKAGE // 'Test2::V1::Base', + stomp => $BOOL, + }; + +=over 4 + +=item include => $ARRAYREF_OR_HASHREF + +See L. + +=item namespace => $NAMESPACE + +Normally a new namespace will be generated for you. You B rely on the +package name being anything specific unless you provide your own. + +The namespace here will be where any tools you 'include' will be imported into. +It will also have its base class set to the base class you specify, or the +L module if you do not provide any. + +If this namespace already has any symbols defined in it an exception will be +thrown unless the C argument is set to true (not recommended). + +=item stomp => $BOOL + +Used to allow the handle to stomp on an existing namespace (NOT RECOMMENDED). + +=item base => $BASE + +Set the base class from which functions should be inherited. Normally this is +set to L. + +Another interesting use case is to have multiple handles that use eachothers +namespaces as base classes: + + use Test2::V1; + + use Test2::V1::Handle( + 'T3', + base => T2->HANDLE_NAMESPACE, + include => {'Alt::Ok' => 'ok'}; + ); + + T3->ok(1, "This uses ok() from Alt::Ok, but all other -> methods are the original"); + T3->done_testing(); # Uses the original done_testing + +=back + +=head1 EXAMPLE USE CASES + +=head2 OVERRIDING INCLUDED TOOLS WITH ALTERNATES + +Lets say you want to use the L version of C, +C instead of the L versions, and also +wanted to import everything else L provides. + + use Test2::V1 -import, -include => ['Test2::Warnings']; + +The C<< -include => ['Test2::Warnings'] >> option means we want to import the +default set of imports from L into our C handle's +private namespace. This will override any methods that were also previously +defined by default. + +The C<-import> option means we want to import all subs into the current namespace. +This includes anything we got from L, and we will get the +L version of those subs. + + like( + warning { warn 'xxx' }, # This is the Test2::Warnings version of 'warning' + qr/xxx/, + "Got expected warning" + ); + +=head1 TOOLS + +=head2 TARGET + +I + +See L. + +You can specify a target class with the C<-target> import argument. If you do +not provide a target then C<$CLASS> and C will not be imported. + + use Test2::V1 -target => 'My::Class'; + + print $CLASS; # My::Class + print CLASS(); # My::Class + +Or you can specify names: + + use Test2::V1 -target => { pkg => 'Some::Package' }; + + pkg()->xxx; # Call 'xxx' on Some::Package + $pkg->xxx; # Same + +=over 4 + +=item $CLASS + +Package variable that contains the target class name. + +=item $class = CLASS() + +Constant function that returns the target class name. + +=back + +=head2 DEFER + +See L. + +=over 4 + +=item def $func => @args; + +I + +=item do_def() + +I + +=back + +=head2 BASIC + +See L. + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +I + +=item pass($name) + +=item pass($name, @diag) + +I + +=item fail($name) + +=item fail($name, @diag) + +I + +=item diag($message) + +I + +=item note($message) + +I + +=item $todo = todo($reason) + +=item todo $reason => sub { ... } + +I + +=item skip($reason, $count) + +I + +=item plan($count) + +I + +=item skip_all($reason) + +I + +=item done_testing() + +I + +=item bail_out($reason) + +I + +=back + +=head2 COMPARE + +See L. + +=over 4 + +=item is($got, $want, $name) + +I + +=item isnt($got, $do_not_want, $name) + +I + +=item like($got, qr/match/, $name) + +I + +=item unlike($got, qr/mismatch/, $name) + +I + +=item $check = match(qr/pattern/) + +I + +=item $check = mismatch(qr/pattern/) + +I + +=item $check = validator(sub { return $bool }) + +I + +=item $check = hash { ... } + +I + +=item $check = array { ... } + +I + +=item $check = bag { ... } + +I + +=item $check = object { ... } + +I + +=item $check = meta { ... } + +I + +=item $check = number($num) + +I + +=item $check = string($str) + +I + +=item $check = bool($bool) + +I + +=item $check = check_isa($class_name) + +I + +=item $check = in_set(@things) + +I + +=item $check = not_in_set(@things) + +I + +=item $check = check_set(@things) + +I + +=item $check = item($thing) + +I + +=item $check = item($idx => $thing) + +I + +=item $check = field($name => $val) + +I + +=item $check = call($method => $expect) + +I + +=item $check = call_list($method => $expect) + +I + +=item $check = call_hash($method => $expect) + +I + +=item $check = prop($name => $expect) + +I + +=item $check = check($thing) + +I + +=item $check = T() + +I + +=item $check = F() + +I + +=item $check = D() + +I + +=item $check = DF() + +I + +=item $check = E() + +I + +=item $check = DNE() + +I + +=item $check = FDNE() + +I + +=item $check = U() + +I + +=item $check = L() + +I + +=item $check = exact_ref($ref) + +I + +=item end() + +I + +=item etc() + +I + +=item filter_items { grep { ... } @_ } + +I + +=item $check = event $type => ... + +I + +=item @checks = fail_events $type => ... + +I + +=back + +=head2 CLASSIC COMPARE + +See L. + +=over 4 + +=item cmp_ok($got, $op, $want, $name) + +I + +=back + +=head2 SUBTEST + +See L. + +=over 4 + +=item subtest $name => sub { ... }; + +I + +(Note: This is called C in the Tools module.) + +=back + +=head2 CLASS + +See L. + +=over 4 + +=item can_ok($thing, @methods) + +I + +=item isa_ok($thing, @classes) + +I + +=item DOES_ok($thing, @roles) + +I + +=back + +=head2 ENCODING + +See L. + +=over 4 + +=item set_encoding($encoding) + +I + +=back + +=head2 EXPORTS + +See L. + +=over 4 + +=item imported_ok('function', '$scalar', ...) + +I + +=item not_imported_ok('function', '$scalar', ...) + +I + +=back + +=head2 REF + +See L. + +=over 4 + +=item ref_ok($ref, $type) + +I + +=item ref_is($got, $want) + +I + +=item ref_is_not($got, $do_not_want) + +I + +=back + +See L. + +=over 4 + +=item is_refcount($ref, $count, $description) + +I + +=item is_oneref($ref, $description) + +I + +=item $count = refcount($ref) + +I + +=back + +=head2 MOCK + +See L. + +=over 4 + +=item $control = mock ... + +I + +=item $bool = mocked($thing) + +I + +=back + +=head2 EXCEPTION + +See L. + +=over 4 + +=item $exception = dies { ... } + +I + +=item $bool = lives { ... } + +I + +=item $bool = try_ok { ... } + +I + +=back + +=head2 WARNINGS + +See L. + +=over 4 + +=item $count = warns { ... } + +I + +=item $warning = warning { ... } + +I + +=item $warnings_ref = warnings { ... } + +I + +=item $bool = no_warnings { ... } + +I + +=back + +=head1 JUSTIFICATION + +L is a rich set of tools. But it made several assumptions about how +it would be used. The assumptions are fairly good for new users writing simple +scripts, but they can get in the way in many cases. + +=head2 PROBLEMS WITH V0 + +=over 4 + +=item Assumptions of strict/warnings + +Many people would put custom strict/warnings settings at the top of their +tests, only to have them wiped out when they use L. + +=item Assumptions of UTF8 + +Occasionally you do not want this assumption. The way it impacts all your +regular and test handles, as well as how your source is read, can be a problem +if you are not working with UTF8, or have other plans entirly. + +=item Huge default set of exports, which can grow + +Sometimes you want to keep your namespace clean. + +Sometimes you import a tool that does not conflict with anything in +L, then we go and add a new tool which conflicts with yours! We make +a point not to break/remove exports, but there is no such commitment about +adding new ones. + +Now the only default export is C which gives you a handle where all the +tools we expose are provided as methods. You can also use the L module (Not +bundled with Test-Simple) for use with an identical number of keystrokes, which +allow you to leverage the prototypes on the original tool subroutines. + +=back + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/src/main/perl/lib/Test2/V1/Base.pm b/src/main/perl/lib/Test2/V1/Base.pm new file mode 100644 index 000000000..ff05cfaa6 --- /dev/null +++ b/src/main/perl/lib/Test2/V1/Base.pm @@ -0,0 +1,108 @@ +package Test2::V1::Base; +use strict; +use warnings; + +our $VERSION = '1.302219'; + +use Test2::API qw/intercept context/; + +use Test2::Tools::Event qw/gen_event/; + +use Test2::Tools::Defer qw/def do_def/; + +use Test2::Tools::Basic qw{ + ok pass fail diag note todo skip + plan skip_all done_testing bail_out +}; + +use Test2::Tools::Compare qw{ + is like isnt unlike + match mismatch validator + hash array bag object meta meta_check number float rounded within string subset bool check_isa + number_lt number_le number_ge number_gt + in_set not_in_set check_set + item field call call_list call_hash prop check all_items all_keys all_vals all_values + etc end filter_items + T F D DF E DNE FDNE U L + event fail_events + exact_ref +}; + +use Test2::Tools::Warnings qw{ + warns warning warnings no_warnings +}; + +use Test2::Tools::ClassicCompare qw/cmp_ok/; + +use Test2::Util::Importer 'Test2::Tools::Subtest' => ( + subtest_buffered => { -as => 'subtest' }, +); + +use Test2::Tools::Class qw/can_ok isa_ok DOES_ok/; +use Test2::Tools::Encoding qw/set_encoding/; +use Test2::Tools::Exports qw/imported_ok not_imported_ok/; +use Test2::Tools::Ref qw/ref_ok ref_is ref_is_not/; +use Test2::Tools::Mock qw/mock mocked/; +use Test2::Tools::Exception qw/try_ok dies lives/; +use Test2::Tools::Refcount qw/is_refcount is_oneref refcount/; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::V1::Base - Base namespace used for L objects created via +L. + +=head1 DESCRIPTION + +This is the default set of functions/methods available in L. + +=head1 SYNOPSIS + +See L. This module is not typically used directly. + +=head1 INCLUDED FUNCTIONALITY + +See L for documentation about the tools included here, and +when they were added. + +Documentation is not duplicated here as that would mean maintaining 2 +locations for every change. + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/src/main/perl/lib/Test2/V1/Handle.pm b/src/main/perl/lib/Test2/V1/Handle.pm new file mode 100644 index 000000000..e6f03f111 --- /dev/null +++ b/src/main/perl/lib/Test2/V1/Handle.pm @@ -0,0 +1,74 @@ +package Test2::V1::Handle; +use strict; +use warnings; + +our $VERSION = '1.302219'; + +sub DEFAULT_HANDLE_BASE { 'Test2::V1::Base' } + +use parent 'Test2::Handle'; + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::V1::Handle - V1 subclass of L. + +=head1 DESCRIPTION + +The L subclass of the L object. This is what you +interact with when you use the C function in a test. + +=head1 SYNOPSIS + + use Test2::V1::Handle; + + my $t2 = Test2::V1::Handle->new(); + + $t2->ok(1, "Passing test"); + +=head1 SUBCLASS OVERRIDES + +The default base class used is L. + +=head1 SEE ALSO + +See L for more information. + +=head1 SOURCE + +The source code repository for Test2-Suite can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright Chad Granum Eexodist@cpan.orgE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/src/test/resources/unit/skip_control_flow.t b/src/test/resources/unit/skip_control_flow.t new file mode 100644 index 000000000..42fdb4a9d --- /dev/null +++ b/src/test/resources/unit/skip_control_flow.t @@ -0,0 +1,136 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +# Minimal TAP without Test::More (we need this to work even when skip()/TODO are broken) +my $t = 0; +sub ok_tap { + my ($cond, $name) = @_; + $t++; + print(($cond ? "ok" : "not ok"), " $t - $name\n"); +} + +# 1) Single frame - SKIP +{ + my $out = ''; + sub skip_once { last SKIP } + SKIP: { + $out .= 'A'; + skip_once(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last SKIP exits SKIP block (single frame)'); +} + +# 2) Two frames, scalar context - SKIP +{ + my $out = ''; + sub inner2 { last SKIP } + sub outer2 { my $x = inner2(); return $x; } + SKIP: { + $out .= 'A'; + my $r = outer2(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last SKIP exits SKIP block (2 frames, scalar context)'); +} + +# 3) Two frames, void context - SKIP +{ + my $out = ''; + sub innerv { last SKIP } + sub outerv { innerv(); } + SKIP: { + $out .= 'A'; + outerv(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last SKIP exits SKIP block (2 frames, void context)'); +} + +# 4) Single frame - TODO +{ + my $out = ''; + sub todo_once { last TODO } + TODO: { + $out .= 'A'; + todo_once(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last TODO exits TODO block (single frame)'); +} + +# 5) Two frames, scalar context - TODO +{ + my $out = ''; + sub inner_todo { last TODO } + sub outer_todo { my $x = inner_todo(); return $x; } + TODO: { + $out .= 'A'; + my $r = outer_todo(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last TODO exits TODO block (2 frames, scalar context)'); +} + +# 6) Two frames, void context - TODO +{ + my $out = ''; + sub innerv_todo { last TODO } + sub outerv_todo { innerv_todo(); } + TODO: { + $out .= 'A'; + outerv_todo(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last TODO exits TODO block (2 frames, void context)'); +} + +# 7) Single frame - CLEANUP +{ + my $out = ''; + sub cleanup_once { last CLEANUP } + CLEANUP: { + $out .= 'A'; + cleanup_once(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last CLEANUP exits CLEANUP block (single frame)'); +} + +# 8) Two frames, scalar context - CLEANUP +{ + my $out = ''; + sub inner_cleanup { last CLEANUP } + sub outer_cleanup { my $x = inner_cleanup(); return $x; } + CLEANUP: { + $out .= 'A'; + my $r = outer_cleanup(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last CLEANUP exits CLEANUP block (2 frames, scalar context)'); +} + +# 9) Two frames, void context - CLEANUP +{ + my $out = ''; + sub innerv_cleanup { last CLEANUP } + sub outerv_cleanup { innerv_cleanup(); } + CLEANUP: { + $out .= 'A'; + outerv_cleanup(); + $out .= 'B'; + } + $out .= 'C'; + ok_tap($out eq 'AC', 'last CLEANUP exits CLEANUP block (2 frames, void context)'); +} + +print "1..$t\n";