Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base: 3eefed5a96
...
compare: 85bbba61d0
Checking mergeability… Don't worry, you can still create the pull request.
  • 2 commits
  • 42 files changed
  • 0 commit comments
  • 1 contributor
Showing with 1,719 additions and 18 deletions.
  1. +5 −1 Makefile
  2. +10 −15 lib/Perl6/P5Actions.pm
  3. +3 −2 lib/Perl6/P5Grammar.pm
  4. +10 −0 lib/Perl6/P5World.pm
  5. +3 −0  lib/v5.pm
  6. +8 −0 t/v5/01-sanity.t
  7. +7 −0 t/v5/02-int.t
  8. +43 −0 t/v5/03-num.t
  9. +57 −0 t/v5/04-op.t
  10. +111 −0 t/v5/04-string.t
  11. +32 −0 t/v5/05-anon-sub-lex-block.t
  12. +22 −0 t/v5/05-anon-sub.t
  13. +81 −0 t/v5/05-array.t
  14. +18 −0 t/v5/05-bind.t
  15. +41 −0 t/v5/05-for.t
  16. +73 −0 t/v5/05-hash.t
  17. +58 −0 t/v5/05-if.t
  18. +19 −0 t/v5/05-lex-block-if.t
  19. +11 −0 t/v5/05-lex-block.t
  20. +23 −0 t/v5/05-while.t
  21. +82 −0 t/v5/06-bool.t
  22. +55 −0 t/v5/09-namespace.t
  23. +68 −0 t/v5/10-bind-sub-param.t
  24. +24 −0 t/v5/11-accessor.t
  25. +37 −0 t/v5/11-bind-method-param.t
  26. +47 −0 t/v5/11-bless.t
  27. +50 −0 t/v5/11-class-open.t
  28. +59 −0 t/v5/11-class.t
  29. +53 −0 t/v5/12-context.t
  30. +34 −0 t/v5/13-op-context.t
  31. +18 −0 t/v5/16-var-redeclare.t
  32. +41 −0 t/v5/17-hash-autovivify.t
  33. +21 −0 t/v5/18-array-autovivify.t
  34. +40 −0 t/v5/19-local.t
  35. +4 −0 t/v5/21-test.t
  36. +93 −0 t/v5/23-eval.t
  37. +6 −0 t/v5/24-strict.t
  38. +84 −0 t/v5/25-syntax-defined-or.t
  39. +101 −0 t/v5/26-syntax-namespace.t
  40. +73 −0 t/v5/30-tie-array.t
  41. +49 −0 t/v5/31-autoload.t
  42. +45 −0 t/v5/32-autoload-method.t
View
6 Makefile
@@ -4,11 +4,15 @@ RM_F = perl -MExtUtils::Command -e rm_f
all: blib/perl5.pbc
-blib/perl5.pbc: lib/v5.pm blib/Perl6/P5Actions.pbc blib/Perl6/P5Grammar.pbc
+blib/perl5.pbc: lib/v5.pm blib/Perl6/P5World.pbc blib/Perl6/P5Actions.pbc blib/Perl6/P5Grammar.pbc
$(NQP) --vmlibs=perl6_group,perl6_ops --target=pir --stagestats --output=blib/perl5.pir lib/v5.pm
$(PARROT) -o blib/perl5.pbc blib/perl5.pir
+blib/Perl6/P5World.pbc: lib/Perl6/P5World.pm
+ $(NQP) --vmlibs=perl6_group,perl6_ops --target=pir --stagestats --output=blib/Perl6/P5World.pir lib/Perl6/P5World.pm
+ $(PARROT) -o blib/Perl6/P5World.pbc blib/Perl6/P5World.pir
+
blib/Perl6/P5Actions.pbc: lib/Perl6/P5Actions.pm
$(NQP) --vmlibs=perl6_group,perl6_ops --target=pir --stagestats --output=blib/Perl6/P5Actions.pir lib/Perl6/P5Actions.pm
$(PARROT) -o blib/Perl6/P5Actions.pbc blib/Perl6/P5Actions.pir
View
25 lib/Perl6/P5Actions.pm
@@ -6,11 +6,6 @@ use Perl6::Ops;
use QRegex;
use QAST;
-sub p5disect_longname( $longname ) {
- $longname<colonpair> := nqp::list();
- $*W.disect_longname( $longname )
-}
-
my role STDActions {
method quibble($/) {
make $<nibble>.ast;
@@ -208,7 +203,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
}
method deflongname($/) {
- make p5disect_longname($/).name(
+ make $*W.p5dissect_longname($/).name(
:dba("$*IN_DECL declaration"),
:decl<routine>,
);
@@ -972,7 +967,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
method package_declarator:sym<require>($/) {
my $past := QAST::Stmts.new(:node($/));
my $name_past := $<module_name>
- ?? p5disect_longname($<module_name><longname>).name_past()
+ ?? $*W.p5dissect_longname($<module_name><longname>).name_past()
!! $<EXPR>[0].ast;
$past.push(QAST::Op.new(
@@ -1308,7 +1303,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
else {
my $indirect;
if $<desigilname> && $<desigilname><longname> {
- my $longname := p5disect_longname($<desigilname><longname>);
+ my $longname := $*W.p5dissect_longname($<desigilname><longname>);
if $longname.contains_indirect_lookup() {
if $*IN_DECL {
$*W.throw($/, ['X', 'Syntax', 'Variable', 'IndirectDeclaration']);
@@ -2296,7 +2291,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
my $name;
if $<longname> {
- my $longname := $*W.disect_longname($<longname>);
+ my $longname := $*W.dissect_longname($<longname>);
$name := $longname.name(:dba('method name'),
:decl<routine>, :with_adverbs);
}
@@ -2692,7 +2687,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
# Get, or find, enumeration base type and create type object with
# correct base type.
- my $longname := $<longname> ?? p5disect_longname($<longname>) !! 0;
+ my $longname := $<longname> ?? $*W.p5dissect_longname($<longname>) !! 0;
my $name := $<longname> ?? $longname.name() !! $<variable><desigilname>;
my $type_obj;
@@ -2839,7 +2834,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
QAST::Op.new( :op('p6bool'), QAST::IVal.new( :value(1) ) ));
# Create the meta-object.
- my $longname := $<longname> ?? p5disect_longname($<longname>[0]) !! 0;
+ my $longname := $<longname> ?? $*W.p5dissect_longname($<longname>[0]) !! 0;
my $subset := $<longname> ??
$*W.create_subset(%*HOW<subset>, $refinee, $refinement, :name($longname.name())) !!
$*W.create_subset(%*HOW<subset>, $refinee, $refinement);
@@ -3330,7 +3325,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
# If we have a type name then we need to dispatch with that type; otherwise
# we need to dispatch with it as a named argument.
- my @name := p5disect_longname($<longname>).components();
+ my @name := $*W.p5dissect_longname($<longname>).components();
if $*W.is_name(@name) {
my $trait := $*W.find_symbol(@name);
make -> $declarand {
@@ -3435,7 +3430,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
# runs after CHECK time.
my $past := $<methodop>.ast;
if $<methodop><longname> {
- my @parts := p5disect_longname($<methodop><longname>).components();
+ my @parts := $*W.p5dissect_longname($<methodop><longname>).components();
my $name := @parts.pop;
if @parts {
my $methpkg := $*W.find_symbol(@parts);
@@ -3478,7 +3473,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
if $<longname> {
# May just be .foo, but could also be .Foo::bar. Also handle the
# macro-ish cases.
- my @parts := p5disect_longname($<longname>).components();
+ my @parts := $*W.p5dissect_longname($<longname>).components();
my $name := @parts.pop;
if +@parts {
$past.unshift($*W.symbol_lookup(@parts, $/));
@@ -4945,7 +4940,7 @@ class Perl6::P5Actions is HLL::Actions does STDActions {
# GenericHOW, though whether/how it's used depends on context.
if $<longname> {
if nqp::substr(~$<longname>, 0, 2) ne '::' {
- my $longname := p5disect_longname($<longname>);
+ my $longname := $*W.p5dissect_longname($<longname>);
my $type := $*W.find_symbol($longname.type_name_parts('type name'));
if $<arglist> {
$type := $*W.parameterize_type($type, $<arglist>, $/);
View
5 lib/Perl6/P5Grammar.pm
@@ -2,6 +2,7 @@ use QRegex;
use NQPP6QRegex;
use NQPP5QRegex;
use Perl6::P5Actions;
+use Perl6::P5World;
use Perl6::Pod; # XXX do we need that?
role startstop5[$start,$stop] {
@@ -1652,7 +1653,7 @@ grammar Perl6::P5Grammar is HLL::Grammar does STD5 {
{ unless $*SCOPE { $*SCOPE := 'our'; } }
[
- [ <longname> { $longname := p5disect_longname($<longname>[0]); } ]?
+ [ <longname> { $longname := $*W.p5dissect_longname($<longname>[0]); } ]?
<.newlex>
[ :dba('generic role')
@@ -3566,7 +3567,7 @@ grammar Perl6::P5Grammar is HLL::Grammar does STD5 {
token term:sym<name> {
<longname>
:my $*longname;
- { say("token term:sym<name> longname:" ~ ~$<longname>); $*longname := p5disect_longname($<longname>) }
+ { say("token term:sym<name> longname:" ~ ~$<longname>); $*longname := $*W.p5dissect_longname($<longname>) }
[
|| <?{ nqp::substr($<longname>.Str, 0, 2) eq '::' || $*W.is_name($*longname.components()) }>
<.unsp>?
View
10 lib/Perl6/P5World.pm
@@ -0,0 +1,10 @@
+
+# This will be mixed in within v5.pm.
+role Perl6::P5World {
+ method p5dissect_longname( $longname ) {
+ $longname<colonpair> := nqp::list();
+ self.dissect_longname( $longname )
+ }
+}
+
+# vim: ft=perl6
View
3  lib/v5.pm
@@ -1,5 +1,6 @@
use Perl6::Grammar;
use Perl6::P5Grammar;
+use Perl6::P5World;
# we use the MOP because that's the only way nqp supports multiple inheritance
grammar Foo {
@@ -10,5 +11,7 @@ $grammar.HOW.add_parent($grammar,Perl6::P5Grammar);
$grammar.HOW.add_parent($grammar,Perl6::Grammar);
$grammar.HOW.compose($grammar);
+$*W.HOW.mixin( $*W, Perl6::P5World );
+
%*LANG<MAIN> := $grammar;
%*LANG<MAIN-actions> := Perl6::P5Actions;
View
8 t/v5/01-sanity.t
@@ -0,0 +1,8 @@
+use perl5;
+use feature 'say';
+
+package Main;
+say '1..2';
+say 'ok 1';
+print 'o'; say 'k 2';
+
View
7 t/v5/02-int.t
@@ -0,0 +1,7 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+say '1..1';
+say 'ok ', 1;
View
43 t/v5/03-num.t
@@ -0,0 +1,43 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+say '1..8';
+my $v = 1 + 0.3;
+if (( $v < 1.29 ) || ( $v > 1.31 )) {
+ print 'not '
+}
+say 'ok ', 1;
+
+if (( $v . '' ) ne '1.3') {
+ print 'not '
+}
+say 'ok ', 2, ' # ', $v;
+
+if (( $v + '3.4' ) ne '4.7') {
+ print 'not '
+}
+say 'ok ', 3, ' # ', ($v + '3.4');
+
+if (( $v / 2 ) != 0.65) {
+ print 'not '
+}
+say 'ok 4 # ', ($v / 2);
+
+if (( $v * 2 ) != 2.6) {
+ print 'not '
+}
+say 'ok 5 # ', ($v * 2);
+
+print 'not ' if !defined 3.14;
+say 'ok 6 - defined num';
+
+$v = 3.14;
+print 'not ' if !defined $v;
+say 'ok 7 - defined var';
+
+my $y;
+print 'not ' if defined $y;
+say 'ok 8 - undefined var';
+
View
57 t/v5/04-op.t
@@ -0,0 +1,57 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+
+ say '1..11';
+
+ my $x = 1;
+ if ($x != "1") {
+ print 'not '
+ };
+ say 'ok 1 - != ', $x;
+
+ $x = 2;
+ if (!($x eq "2")) {
+ print 'not '
+ };
+ say 'ok 2 - ne ', $x;
+
+ $x = 0 ? "not ok" : "ok";
+ say $x, ' 3 - ternary';
+
+ $x = 1 ? "ok" : "not ok";
+ say $x, ' 4 - ternary';
+
+ print "ok 5 - print with embedded newlines\nok 6 - more newlines\n";
+
+ $x = 2;
+ if (!(($x + 2) == ($x + 1 + 1))) {
+ print 'not '
+ };
+ say 'ok 7 - add ';
+
+ $x = 2;
+ if (!(($x . 2) eq "22")) {
+ print 'not '
+ };
+ say 'ok 8 - concat';
+
+ my $undef;
+ if ($undef) {
+ print 'not '
+ };
+ say 'ok 9 - undef to bool';
+
+ if (!(($undef . 2) eq "2")) {
+ print 'not '
+ };
+ say 'ok 10 - undef to str';
+
+ $x = 2;
+ if (!(($x + 2) eq 4)) {
+ print 'not '
+ };
+ say 'ok 11 - plus with string';
+
View
111 t/v5/04-string.t
@@ -0,0 +1,111 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..20';
+
+my $x = "abcd";
+if (substr($x,1,1) ne "b") {
+ print 'not '
+};
+say 'ok 1 - substr ', substr($x,1,1);
+
+if (index($x,"c") ne 2) {
+ print 'not '
+};
+say 'ok 2 - index ', index($x,"c");
+
+if (substr($x,3,1) ne "d") {
+ print 'not '
+}
+say 'ok 3 - substr ', substr($x,3,1);
+
+print 'not ' if !defined "abc";
+say 'ok 4 - defined str';
+
+my $s = "o";
+$s .= "k 5 - concat";
+say $s;
+
+$s = "The black cat climbed the green tree";
+my $color = substr $s, 4, 5; # black
+my $middle = substr $s, 4, -11; # black cat climbed the
+my $end = substr $s, 14; # climbed the green tree
+my $tail = substr $s, -4; # tree
+my $z = substr $s, -4, 2; # tr
+
+say "# $s";
+
+print 'not ' if $color ne 'black';
+say "ok 6 # $color";
+
+print 'not ' if $middle ne 'black cat climbed the';
+say "ok 7 # $middle";
+
+print 'not ' if $end ne 'climbed the green tree';
+say "ok 8 # $end";
+
+print 'not ' if $tail ne 'tree';
+say "ok 9 # $tail";
+
+print 'not ' if $z ne 'tr';
+say 'ok 10';
+
+
+# interpolation
+
+my $v = 123;
+my $r = "-$v-";
+print 'not ' if $r ne '-123-'; say 'ok 11 - scalar interpolation';
+
+my @v = (234, 567);
+$r = "-$v[1]-";
+print 'not ' if $r ne '-567-'; say 'ok 12 - array element interpolation';
+
+$r = "-${v[1]}-";
+print 'not ' if $r ne '-567-'; say 'ok 13 - array element interpolation';
+
+$r = "-@v-";
+print 'not ' if $r ne '-234 567-'; say 'ok 14 - array interpolation';
+
+my %v = (xyz => 234, abc => 567);
+$r = "-$v{xyz}-";
+print 'not ' if $r ne '-234-'; say 'ok 15 - hash element interpolation';
+
+$r = "-${v{xyz}}-";
+print 'not ' if $r ne '-234-'; say 'ok 16 - hash element interpolation';
+
+$v = { xyz => 123, abc => 567 };
+$r = "-$v->{xyz}-";
+print 'not ' if $r ne '-123-'; say "ok 17 - hash deref interpolation - $r";
+
+# {
+# no strict 'refs';
+# # Can't use bareword ("v") as a HASH ref while "strict refs" in use
+# # Global symbol "%v" requires explicit package name
+# $r = "-${v->{xyz}}-";
+# print 'not ' if $r ne '-234-'; say 'ok 18 - hash deref interpolation';
+# }
+
+$v = [ 123, 567, 890 ];
+$r = "-$v->[2]-";
+print 'not ' if $r ne '-890-'; say "ok 18 - array deref interpolation - $r";
+
+# {
+# no strict 'refs';
+# # Can't use bareword ("v") as a HASH ref while "strict refs" in use
+# # Global symbol "@v" requires explicit package name
+# $r = "-${v->[2]}-";
+# print 'not ' if $r ne '-890-'; say 'ok 18 - array deref interpolation';
+# }
+
+$r = "-$$v[2]-";
+print 'not ' if $r ne '-890-'; say "ok 19 - array deref interpolation - $r";
+
+{
+ my $x = "123";
+ my $y = \$x;
+ $r = "[$$y]";
+ print 'not ' if $r ne '[123]'; say "ok 20 - scalar deref interpolation - $r";
+}
+
View
32 t/v5/05-anon-sub-lex-block.t
@@ -0,0 +1,32 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+ say '1..3';
+ my $a = sub () {
+ do { 5 }
+ };
+ if ($a->() != 5) {
+ print 'not '
+ }
+ say 'ok 1 - do inside function';
+
+ $a = sub () {
+ return do { 5 };
+ 4;
+ };
+ if ($a->() != 5) {
+ print 'not '
+ }
+ say 'ok 2 - do inside function';
+
+ $a = sub () {
+ do { return 5 };
+ 4;
+ };
+ if ($a->() != 5) {
+ print 'not '
+ }
+ say 'ok 3 - do inside function';
+
View
22 t/v5/05-anon-sub.t
@@ -0,0 +1,22 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+ say '1..4';
+ my $a = sub { 3 };
+ say 'ok 1 - create function';
+ if ($a->() != 3) {
+ print 'not '
+ }
+ say 'ok 2 - apply';
+ $a = ( sub { 4 } )->();
+ if ($a != 4) {
+ print 'not '
+ }
+ say 'ok 3 - apply in line';
+ $a = ( sub () { sub { 5 } } )->();
+ if ($a->() != 5) {
+ print 'not '
+ }
+ say 'ok 4 - return function';
View
81 t/v5/05-array.t
@@ -0,0 +1,81 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..17';
+my @a;
+say 'ok 1 - create array';
+$a[1] = 3;
+say 'ok 2 - set element';
+if ($a[1] != 3) {
+ print 'not '
+}
+say 'ok 3 - fetch element # ', $a[1];
+
+my @x = ( 3, 4 );
+@a = ( 1, @x, 2 );
+if ($a[1] != 3) {
+ print 'not '
+}
+say 'ok 4 - interpolate array # ', @a;
+
+my $x = [ 5, 6 ];
+my $v = $x->[1];
+if ($v != 6) {
+ print 'not '
+}
+say 'ok 5 - array in a scalar var # ', $v;
+$x->[1] = 7;
+if ($x->[1] != 7) {
+ print 'not '
+}
+say 'ok 6 - array in a scalar var # ', $x->[1];
+
+{
+ my $v;
+ $v->[2] = 8;
+ if ($v->[2] != 8) {
+ print 'not '
+ }
+ say 'ok 7 - array in a scalar var # ', $v->[2];
+}
+
+print 'not ' if defined $x->[4];
+say "ok 8 - undefined item";
+
+print 'not ' if !defined $x->[1];
+say "ok 9 - defined item";
+
+$x->[4] = 5;
+print 'not ' if !defined $x->[4];
+say "ok 10 - defined item";
+
+unshift(@$x, 6);
+print 'not ' if $x->[0] != 6;
+say "ok 11 - unshift";
+print 'not ' if $x->[5] != 5;
+say "ok 12 - unshift";
+
+my @x13 = ( 3, 4 );
+my $s13 = join('#', @x13);
+print 'not '
+ unless $s13 eq '3#4';
+say "ok 13 - join # '$s13'";
+
+my @x14 = @x13;
+$x14[1] = 5;
+print 'not '
+ unless $x13[1] == 4;
+say "ok 14 - array copy";
+print 'not '
+ unless $x14[1] == 5;
+say "ok 15 - array copy";
+
+push @x14, 7;
+print 'not '
+ unless $x14[2] == 7;
+say "ok 16 - array push";
+
+print 'not '
+ unless ref( \@x14 ) eq 'ARRAY';
+say "ok 17 - ref is ARRAY";
View
18 t/v5/05-bind.t
@@ -0,0 +1,18 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..2';
+
+my $x = 1;
+if ($x != 1) {
+ print 'not '
+};
+say 'ok ', $x;
+
+$x = 2;
+if ($x != 2) {
+ print 'not '
+};
+say 'ok ', $x;
+
View
41 t/v5/05-for.t
@@ -0,0 +1,41 @@
+use feature 'say';
+
+say '1..13';
+my @a = ( 1, 2 );
+for my $v (@a) {
+ say 'ok ' . $v . ' - loop';
+}
+
+my $x = 123;
+@a = ( 3, 6 );
+for my $v (@a) {
+ my $x = do { 3 };
+ if ($x != 3) {
+ print 'not '
+ }
+ say 'ok ' . $v . ' - for block';
+ my @b = ( $v + 1, $v + 2 );
+ for my $v (@b) {
+ my $x = do { 3 };
+ if ($x != 3) {
+ print 'not '
+ }
+ say 'ok ' . $v . ' - inner for block';
+ }
+}
+
+if ($x != 123) {
+ print 'not '
+}
+say 'ok 9 - for block # ', $x;
+
+$a[0] = 10;
+$a[1] = 11;
+for (@a) {
+ say "ok $_ - default variable";
+}
+
+$a[0] = 12;
+$a[1] = 13;
+say "ok $_ - default variable in statement modifier"
+ for @a;
View
73 t/v5/05-hash.t
@@ -0,0 +1,73 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..15';
+my %a;
+say 'ok 1 - create hash';
+$a{abc} = 3;
+say 'ok 2 - set element';
+if ($a{abc} != 3) {
+ print 'not '
+}
+say 'ok 3 - fetch element # ', $a{abc};
+
+$a{123} = 456;
+say '# values: ', values %a;
+say '# keys: ', keys %a;
+
+my %a1 = (a => 2);
+if ($a1{a} ne 2) {
+ print 'not '
+}
+say "ok 4 - assign list to hash # {%a1}";
+
+my %b1 = %a1;
+if ($b1{a} ne 2) {
+ print 'not '
+}
+say "ok 5 - assign hash to hash # {%b1}";
+$b1{a} = 5;
+print 'not '
+ unless $a1{a} == 2;
+say "ok 6 - hash copy";
+print 'not '
+ unless $b1{a} == 5;
+say "ok 7 - hash copy";
+$b1{a} = 2;
+
+
+my $c1 = { %b1, b => 3 };
+if ($c1->{a} ne 2 || $c1->{b} ne 3) {
+ print 'not '
+}
+say "ok 8 - interpolate hash in hash composer "; # {$c1};
+
+print 'not ' if defined $c1->{c};
+say "ok 9 - undefined item";
+
+print 'not ' if !defined $c1->{b};
+say "ok 10 - defined item";
+
+$c1->{c} = 4;
+print 'not ' if !defined $c1->{c};
+say "ok 11 - defined item";
+
+
+# autoquote
+
+my %v;
+sub x1 () { 1230 } $v{x1()} = 120; # '1230' => 120
+sub x2 () { 1231 } $v{x2} = 121; # 'x2' => 121
+sub x3 () { 1232 } $v{main::x3} = 122; # '1232' => 122
+
+{
+ no strict 'subs';
+ $v{main::x4} = 123; # 'main::x4' => 123
+}
+
+print 'not ' if $v{'1230'} != 120; say "ok 12 - no autoquote for function call with parenthesis";
+print 'not ' if $v{'x2'} != 121; say "ok 13 - autoquote for bareword without colons";
+print 'not ' if $v{'1232'} != 122; say "ok 14 - no autoquote for function call without parenthesis";
+print 'not ' if $v{'main::x4'} != 123; say "ok 15 - autoquote for bareword with colons";
+
View
58 t/v5/05-if.t
@@ -0,0 +1,58 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..9';
+
+if (0) {
+ print 'not '
+}
+say 'ok 1';
+
+if (1) {
+ say 'ok 2'
+}
+
+if (0) {
+ say 'not ok 3'
+}
+else {
+ say 'ok 3';
+}
+
+if (1) {
+ say 'ok 4'
+}
+else {
+ say 'not ok 4';
+}
+
+if (0) {
+ say 'not ok 5'
+}
+elsif (0) {
+ say 'not ok 5 # elsif'
+}
+else {
+ say 'ok 5';
+}
+
+unless (0) {
+ say 'ok 6'
+}
+
+unless (1) {
+ print 'not '
+}
+say 'ok 7';
+
+say 'not ok 8'
+ unless 1;
+say 'ok 8'
+ unless 0;
+
+say 'not ok 9'
+ if 0;
+say 'ok 9'
+ if 1;
+
View
19 t/v5/05-lex-block-if.t
@@ -0,0 +1,19 @@
+use perl5;
+use strict;
+use feature 'say';
+
+ say '1..2';
+ my $a = 123;
+
+ if (1) {
+ my $a = do { 3 };
+ if ($a != 3) {
+ print 'not '
+ }
+ say 'ok 1 - if block';
+ }
+
+ if ($a != 123) {
+ print 'not '
+ }
+ say 'ok 2 - if block # ', $a;
View
11 t/v5/05-lex-block.t
@@ -0,0 +1,11 @@
+use perl5;
+use strict;
+use feature 'say';
+
+ say '1..2';
+ my $a = do { 3 };
+ say 'ok 1 - do block';
+ if ($a != 3) {
+ print 'not '
+ }
+ say 'ok 2 - do value';
View
23 t/v5/05-while.t
@@ -0,0 +1,23 @@
+use perl5;
+use strict;
+use feature 'say';
+
+ say '1..5';
+ my $a = 4;
+ my $b = 0;
+ while ($a) {
+ $b = $b + 2;
+ $a = $a - 1;
+ }
+ if ($b == 8) {
+ say "ok 1";
+ }
+
+ my @x = ( 2, 3 );
+ while (@x) {
+ say "ok ", (shift @x);
+ }
+
+ @x = ( 4, 5 );
+ say "ok ", (shift @x)
+ while @x;
View
82 t/v5/06-bool.t
@@ -0,0 +1,82 @@
+use perl5;
+use feature 'say';
+use strict;
+
+package Main;
+
+sub new {
+ bless {}, 'Main';
+}
+
+ say '1..32';
+
+ say +( 0 ? "not " : "" ), "ok 1 - integer";
+ say +( 1 ? "" : "not " ), "ok 2";
+
+ say +( 0.0 ? "not " : "" ), "ok 3 - float";
+ say +( 0.001 ? "" : "not " ), "ok 4";
+
+ say +( "0" ? "not " : "" ), "ok 5 - string";
+ say +( "" ? "not " : "" ), "ok 6";
+ say +( "0.0" ? "" : "not " ), "ok 7";
+ say +( "1" ? "" : "not " ), "ok 8";
+ say +( "aaa" ? "" : "not " ), "ok 9";
+
+ say +( [] ? "" : "not " ), "ok 10 - array";
+ say +( ["x"] ? "" : "not " ), "ok 11";
+ do {
+ my @a;
+ say +( @a ? "not " : "" ), "ok 12";
+ @a = ["aaa"];
+ say +( @a ? "" : "not " ), "ok 13";
+ };
+
+ {
+ my $b;
+ say +( $b ? "not " : "" ), "ok 14 - scalar";
+ $b = [];
+ say +( $b ? "" : "not " ), "ok 15";
+ $b = ["aaa"];
+ say +( $b ? "" : "not " ), "ok 16";
+ }
+
+ {
+ my $b;
+ # "Can't use an undefined value as an ARRAY reference"
+ # say +( (@{$b}) ? "not " : "" ), "ok 19 - scalar";
+
+ $b = [];
+ say +( (@{$b}) ? "not " : "" ), "ok 17";
+ $b = ["aaa"];
+ say +( (@{$b}) ? "" : "not " ), "ok 18";
+ }
+
+ say +( Main->new() ? "" : "not " ), "ok 19 - object";
+
+ say +( undef() ? "not " : "" ), "ok 20 - undef";
+
+ {
+ my @a = []; # element #0 is an array
+ print ( @a ? "" : "not " );
+ say "ok 21";
+ }
+
+ say +(( 10 || 20 ) == 10 ? "" : "not "), "ok 22";
+ say +(( 10 && 20 ) == 20 ? "" : "not "), "ok 23";
+ say +(( 0 || 20 ) == 20 ? "" : "not "), "ok 24";
+ say +(( 0 && 20 ) == 0 ? "" : "not "), "ok 25";
+ say +(( "" || "x" ) eq "x" ? "" : "not "), "ok 26";
+ say +(( "" && "x" ) eq "" ? "" : "not "), "ok 27";
+
+ say "ok 28" or die "not ok 28";
+
+ my $h = {};
+ say +( $h ? "" : "not " ), "ok 29 - hash in scalar";
+ $h->{x} = 0;
+ say +( $h ? "" : "not " ), "ok 30";
+
+ my %h;
+ say +( %h ? "not " : "" ), "ok 31 - hash";
+ $h{x} = 0;
+ say +( %h ? "" : "not " ), "ok 32";
+
View
55 t/v5/09-namespace.t
@@ -0,0 +1,55 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+
+say '1..6';
+
+sub subr { $_[0] + $_[1] };
+
+package Mod2;
+sub subr { $_[0] + $_[1] + 1 }
+
+package Main;
+
+my $x = 0;
+$x = subr( 1, 2 );
+if ($x != 3) {
+ print 'not '
+};
+say 'ok 1 - ', $x;
+
+sub subr3 { $_[0][0] + $_[0][1] }
+
+$x = 0;
+$x = subr3( [3, 4] );
+if ($x != 7) {
+ print 'not '
+}
+say 'ok 2 - ', $x;
+
+# we are in the Main namespace
+
+$x = 0;
+$x = Main::subr( 1, 2 );
+if ($x != 3) {
+ print 'not '
+}
+say 'ok 3 - ', $x;
+
+if (Mod2::subr( 1, 2 ) != 4) {
+ print 'not '
+}
+say 'ok 4 - ', Mod2::subr( 1, 2 );
+
+*subr4 = sub { 123 };
+
+print "not " unless subr4() == 123;
+say "ok 5";
+
+*Mod2::subr4 = sub { 456 };
+
+print "not " unless Mod2::subr4() == 456;
+say "ok 6";
+
View
68 t/v5/10-bind-sub-param.t
@@ -0,0 +1,68 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+
+say '1..5';
+
+sub subr {
+ my $v1 = shift;
+ my $v2 = shift;
+ $v1 + $v2
+}
+
+my $x = 0;
+$x = subr( 1, 2 );
+if ($x != 3) {
+ print 'not '
+};
+say 'ok 1 - ', $x;
+
+sub subr3 {
+ my @x = @{$_[0]};
+ $x[0] + $x[1]
+};
+
+$x = 0;
+$x = subr3( [3, 4] );
+if ($x != 7) {
+ print 'not '
+};
+say 'ok 2 - ', $x;
+
+# "Main" namespace
+
+$x = 0;
+$x = Main::subr( 1, 2 );
+if ($x != 3) {
+ print 'not '
+};
+say 'ok 3 - ', $x;
+
+
+sub subr4 {
+ $_[0] = 3;
+}
+
+$x = 4;
+subr4($x);
+if ($x != 3) {
+ print 'not '
+};
+say 'ok 4 - ', $x, ' $_[0] is read-write # TODO';
+
+
+sub subr5 {
+ my $v = shift;
+ $v = 3;
+}
+
+$x = 4;
+subr5($x);
+if ($x != 4) {
+ print 'not '
+};
+say 'ok 5 - ', $x;
+
+
View
24 t/v5/11-accessor.t
@@ -0,0 +1,24 @@
+use strict;
+use feature 'say';
+
+package Other;
+ sub new1 {
+ my $class = shift;
+ my %params = @_;
+ my $self = \%params;
+ bless $self, $class;
+ }
+ sub subr { say 'ok ', $_[0]->{a} };
+
+
+package Main;
+
+ say '1..3';
+ say 'ok 1 - load ok';
+
+ my $other = Other->new1( 'a' => 2 );
+ $other->subr();
+
+ $other->{a} = 3;
+ say 'ok ', $other->{a};
+
View
37 t/v5/11-bind-method-param.t
@@ -0,0 +1,37 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Main;
+
+say '1..2';
+
+sub subr {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ $a + $b;
+}
+
+my $x = 0;
+$x = Main->subr( 1, 2 );
+if ( $x != 3 ) {
+ print 'not ';
+}
+say 'ok 1 - ', $x;
+
+sub subr2 {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ my $c = shift;
+ $a + $b + $c;
+}
+
+$x = 0;
+$x = Main->subr2( 1, 2, 4 );
+if ( $x != 7 ) {
+ print 'not ';
+}
+say 'ok 2 - ', $x;
+
View
47 t/v5/11-bless.t
@@ -0,0 +1,47 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Other;
+
+sub new {
+ my $class = shift;
+ bless { @_ }, $class
+}
+
+sub subr {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ $a + $b
+}
+
+sub subr2 {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ my $c = shift;
+ $a + $b + $c
+}
+
+
+say '1..2';
+
+my $other = Other->new();
+
+my $x = 0;
+$x = $other->subr( 1, 2 );
+if ($x != 3) {
+ print 'not '
+};
+say 'ok 1 - ', $x;
+
+
+
+$x = 0;
+$x = Other->subr2( 1, 2, 4 );
+if ($x != 7) {
+ print 'not '
+};
+say 'ok 2 - ', $x;
+
View
50 t/v5/11-class-open.t
@@ -0,0 +1,50 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package Other;
+
+sub new {
+ my $class = shift;
+ bless { @_ }, $class
+}
+
+sub subr {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ $a + $b
+}
+
+package Other;
+
+sub subr2 {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ my $c = shift;
+ $a + $b + $c
+}
+
+package Main;
+
+ say '1..2';
+
+ my $other = Other->new();
+
+ my $x = 0;
+ $x = $other->subr( 1, 2 );
+ if ($x != 3) {
+ print 'not '
+ }
+ say 'ok 1 - ', $x;
+
+
+
+ $x = 0;
+ $x = Other->subr2( 1, 2, 4 );
+ if ($x != 7) {
+ print 'not '
+ }
+ say 'ok 2 - ', $x;
+
View
59 t/v5/11-class.t
@@ -0,0 +1,59 @@
+use feature 'say';
+
+package Other;
+
+sub new {
+ my $class = shift;
+ bless { @_ }, $class
+}
+
+sub subr {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ $a + $b
+}
+
+sub subr2 {
+ my $self = shift;
+ my $a = shift;
+ my $b = shift;
+ my $c = shift;
+ $a + $b + $c
+}
+
+sub my_accessor { $_[0]->{my_accessor} + 1 }
+
+package Main;
+
+ say '1..5';
+
+ my $other = Other->new();
+
+ my $x = 0;
+ $x = $other->subr( 1, 2 );
+ if ($x != 3) {
+ print 'not '
+ }
+ say 'ok 1 - ', $x;
+
+
+
+ $x = 0;
+ $x = Other->subr2( 1, 2, 4 );
+ if ($x != 7) {
+ print 'not '
+ }
+ say 'ok 2 - ', $x;
+
+
+ my $obj = Other->new( my_accessor => '123' );
+ print 'not ' if $obj->{my_accessor} ne '123';
+ say 'ok 3 - ', $obj->{my_accessor};
+
+ print 'not ' if $obj->my_accessor ne '124';
+ say 'ok 4 - ', $obj->my_accessor;
+
+ print 'not ' if ref($obj) ne 'Other';
+ say 'ok 5 - ref # ', ref($obj);
+
View
53 t/v5/12-context.t
@@ -0,0 +1,53 @@
+use strict;
+use feature 'say';
+
+sub x { return 4,5 }
+
+sub k { my @x = (8, 9); @x }
+
+sub o { my @x = (8, 9); my @y = (11,12); @x, @y }
+
+print "1..4\n";
+
+my $x = x();
+my ($y) = x();
+my @x = x();
+my $expect = "5 / 4 / [4 5]";
+my $got = "$x / $y / [@x]";
+print "not " if $expect ne $got;
+print "ok 1 - $expect : $got\n";
+
+$x = 6, 7;
+@x = 6, 7;
+$expect = "6 [6]";
+$got = "$x [@x]";
+print "not " if $expect ne $got;
+print "ok 2 - $expect : $got\n";
+
+
+$x = k();
+@x = k();
+$expect = "2 [8 9]";
+$got = "$x [@x]";
+print "not " if $expect ne $got;
+print "ok 3 - $expect : $got\n";
+
+$x = o();
+@x = o();
+$expect = "2 [8 9 11 12]";
+$got = "$x [@x]";
+print "not " if $expect ne $got;
+print "ok 4 - $expect : $got\n";
+
+# TODO - bug: var declaration inside a list
+#
+# sub n { my @x = 8, 9; @x }
+#
+# $x = n();
+# @x = n();
+# $expect = "1 [8]";
+# $got = "$x [@x]";
+# print "not " if $expect ne $got;
+# print "ok 5 - $expect : $got\n";
+#
+
View
34 t/v5/13-op-context.t
@@ -0,0 +1,34 @@
+use strict;
+use feature 'say';
+
+print "1..12\n";
+
+sub foo {
+ my $num = shift;
+ my $expected = shift;
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne $expected;
+ say "ok $num # expected: $expected got: $result";
+}
+
+my $x;
+my @x;
+
+foo( 1, "SCALAR" ) or 1;
+0 or foo( 2, "VOID" );
+
+$x = foo( 3, "SCALAR" ) || 1;
+$x = 0 || foo( 4, "SCALAR" );
+
+@x = foo( 5, "SCALAR" ) || 1;
+@x = 0 || foo( 6, "LIST" );
+
+foo( 7, "SCALAR" ) and 1;
+1 and foo( 8, "VOID" );
+
+$x = 1 && foo( 9, "SCALAR" );
+$x = foo( 10, "SCALAR" ) && 1;
+
+@x = 1 && foo( 11, "LIST" );
+@x = foo( 12, "SCALAR" ) && 1;
+
View
18 t/v5/16-var-redeclare.t
@@ -0,0 +1,18 @@
+use perl5;
+use strict;
+use feature 'say';
+
+ say '1..2';
+
+ my $x = 0;
+ if ($x != 0) {
+ print 'not '
+ }
+ say 'ok 1 - ', $x;
+
+ my $x = 1;
+ if ($x != 1) {
+ print 'not '
+ }
+ say 'ok 2 - ', $x;
+
View
41 t/v5/17-hash-autovivify.t
@@ -0,0 +1,41 @@
+use perl5;
+use strict;
+use feature 'say';
+
+say '1..8';
+my %a;
+say 'ok 1 - create hash';
+$a{abc}{def} = 3;
+say 'ok 2 - set element';
+if ($a{abc}{def} != 3) {
+ print 'not '
+}
+say 'ok 3 - fetch element # ', $a{abc}{def};
+
+my $b;
+say 'ok 4 - create scalar';
+$b->{abc}{def} = 3;
+say 'ok 5 - set element';
+if ($b->{abc}{def} != 3) {
+ print 'not '
+}
+say 'ok 6 - fetch element # ', $b->{abc}{def};
+
+
+sub dont_modify { $_[0] }
+
+dont_modify( $b->{x} );
+if (exists $b->{x}) {
+ print 'not ';
+}
+say "ok 7 - don't vivify";
+
+
+sub modify { $_[0] = 1 }
+
+modify( $b->{x} );
+if (! $b->{x}) {
+ print 'not ';
+}
+say 'ok 8 - vivify through $_[0] aliasing # TODO';
+
View
21 t/v5/18-array-autovivify.t
@@ -0,0 +1,21 @@
+use feature 'say';
+use strict;
+
+say '1..6';
+my @a;
+say 'ok 1 - create array';
+$a[7][4] = 3;
+say 'ok 2 - set element';
+if ($a[7][4] != 3) {
+ print 'not '
+}
+say 'ok 3 - fetch element # ', $a[7][4];
+
+my $b;
+say 'ok 4 - create scalar';
+$b->[7][4] = 3;
+say 'ok 5 - set element';
+if ($b->[7][4] != 3) {
+ print 'not '
+}
+say 'ok 6 - fetch element # ', $b->[7][4];
View
40 t/v5/19-local.t
@@ -0,0 +1,40 @@
+use perl5;
+use strict;
+use feature 'say';
+
+package X; # XXX javascript bug - we don't autovivify packages yet
+
+package main;
+
+say '1..7';
+
+$X::v = 10;
+
+my $vv = \$X::v;
+
+if (1) {
+ print "not " if $X::v != 10;
+ say "ok 1";
+
+ local $X::v;
+ print "not " if defined $X::v;
+ say "ok 2";
+
+ print "not " if $$vv != 10;
+ say "ok 3 # $$vv";
+
+ $X::v = 15;
+ print "not " if $X::v != 15;
+ say "ok 4";
+
+ print "not " if $$vv != 10;
+ say "ok 5 # $$vv";
+
+}
+
+print "not " if $X::v != 10;
+say "ok 6";
+
+print "not " if $$vv != 10;
+say "ok 7";
+
View
4 t/v5/21-test.t
@@ -0,0 +1,4 @@
+use Perlito5::Test;
+
+Perlito5::Test::plan 1;
+Perlito5::Test::ok( 1==1, "Perlito::Test works");
View
93 t/v5/23-eval.t
@@ -0,0 +1,93 @@
+use strict;
+use feature 'say';
+
+print "1..10\n";
+
+eval 'print "ok 1 # say from eval\\n"';
+
+eval '{;print "not "';
+print "ok 2 # we live after evaling incorrect code\n";
+
+# contributed by sbertrang++
+
+sub foo {
+ my $x = eval { return "bar" };
+ print "# err $@\n" if $@;
+ return "baz-$x";
+}
+my $bar = foo();
+print "not " if $bar ne "baz-bar";
+print "ok 3 # return from eval block $bar\n";
+
+sub foo2 {
+ my $x = eval qq{ return "bar" };
+ return "baz-$x";
+}
+my $bar2 = foo2();
+print "not " if $bar2 ne "baz-bar";
+print "ok 4 # return from eval string $bar2\n";
+
+
+
+# this code from Abigail++
+
+
+eval {
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'SCALAR';
+ say "ok 5 # Eval block: $result";
+ 1;
+} or do {warn "Oops"};
+
+
+eval <<'--' or do {warn "Oops"};
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'SCALAR';
+ say "ok 6 # Eval string: $result";
+ 1;
+--
+
+
+sub foo3 {
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'SCALAR';
+ say "ok 7 # Sub: $result";
+ 1;
+}
+
+foo3 or do {warn "Oops"};
+
+
+sub {
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'SCALAR';
+ say "ok 8 # Anon: $result";
+ 1;
+} -> () or do {warn "Oops"};
+
+
+
+# Now, note that if the eval is in list context, wantarray pick that up:
+
+
+sub foo4 {1;}
+
+foo4 (eval {
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'LIST';
+ say "ok 9 # Eval: $result";
+ 1;
+});
+
+
+
+# And if the eval is in void context, wantarray picks that up as well:
+
+eval {
+ my $result = wantarray ? "LIST" : defined wantarray ? "SCALAR" : "VOID";
+ print "not " if $result ne 'VOID';
+ say "ok 10 # Eval: $result";
+ 1;
+};
+
+
View
6 t/v5/24-strict.t
@@ -0,0 +1,6 @@
+print "1..4\n";
+eval('use strict;my $x = "ok 1";print $x,"\n"');
+eval('my $x = "ok 2";print $x,"\n"');
+eval('$x = "ok 3";print $x,"\n"');
+eval('use strict;$x = "not ok 4";print $x,"\n"');
+print "ok 4\n";
View
84 t/v5/25-syntax-defined-or.t
@@ -0,0 +1,84 @@
+
+print "1..4\n";
+
+sub shift_test {
+ @_ = (5, 6);
+
+ print "not " unless (shift // 2) == 5;
+ print "ok 1 # shift and defined-or\n";
+
+ #
+ # # syntax error
+ #
+ # print "not " unless (shift //) == 5;
+ # print "ok 1 # shift and match\n";
+
+ #
+ # # Warning: Use of "shift" without parentheses is ambiguous
+ #
+ # print "not " unless (shift / 2) == 3;
+ # print "ok 2 # shift and division\n";
+}
+
+shift_test;
+
+
+
+sub testing {
+ 123;
+}
+
+sub more_test {
+
+ #
+ # # Number found where operator expected near "// 2"
+ # # (Missing operator before 2?)
+ # # syntax near "// 2"
+ #
+ # print "not " unless (testing // 2) == 5;
+ # print "ok 1 # sub and defined-or\n";
+
+ my $v = eval <<TEST;
+ print "not " unless (testing //);
+ print "ok 2 # sub and match\n";
+ 1;
+TEST
+ print "not " unless $v;
+ print "ok 2 - sub and match # TODO Regex parser bug\n";
+
+ #
+ # # Search pattern not terminated
+ #
+ # print "not " unless (testing / 2) == 3;
+ # print "ok 2 # sub and division\n";
+}
+
+more_test;
+
+
+
+sub testing2 () {
+ 120;
+}
+
+sub more_test2 {
+
+ # Number found where operator expected near "// 2"
+ # (Missing operator before 2?)
+ # syntax near "// 2"
+
+ print "not " unless (testing2 // 2) == 120;
+ print "ok 3 # unary and defined-or\n";
+
+ #
+ # # syntax error
+ #
+ # print "not " unless (testing2 //);
+ # print "ok 1 # unary and match\n";
+
+ print "not " unless (testing2 / 2) == 60;
+ print "ok 4 # unary and division\n";
+}
+
+more_test2;
+
View
101 t/v5/26-syntax-namespace.t
@@ -0,0 +1,101 @@
+use feature 'say';
+
+print "1..9\n";
+
+# TODO:
+#
+# $ perl -e ' { package X; sub print { CORE::print(">$_[1]<\n") } } my $x = bless {}, "X"; print $x "xxx" '
+# Not a GLOB reference at -e line 1.
+#
+# $ perl -e ' { package X; sub printx { CORE::print(">$_[1]<\n") } } my $x = bless {}, "X"; printx $x "xxx" '
+# >xxx<
+#
+# $ perl -MO=Deparse -e ' print X:: "xxx" '
+# print X 'xxx';
+#
+# $ perl perlito5.pl -MO=Deparse -e ' ::X::x::y '
+# join("", ::{'main::X::'} x main::y);
+#
+# sub t { 123 . ($_[0] || 'undef') }
+# # Can't locate object method "t" via package "X" (perhaps you forgot to load "X"?)
+# $v = t X:: "y";
+# print ">$v<\n";
+
+
+my $v;
+my $r;
+my $x;
+
+{
+ use strict;
+ $r = 3;
+ sub A { $r = 4 }
+ ::A;
+ print "not " if $r != 4;
+ say "ok 1 - double-colon before # ::A $r "; # 4
+
+ $r = 3;
+ main::A;
+ print "not " if $r != 4;
+ say "ok 2 - double-colon before means 'main::A' # ::A $r "; # 4
+}
+
+{
+ use strict;
+ eval ' $x = B:: ';
+ $r = ">$x<";
+ print "not " if $r ne ">B<";
+ say "ok 3 - double-colon after - B:: $x"; # B
+}
+
+{
+ no strict;
+ $x = C;
+ $r = ">$x<";
+ print "not " if $r ne ">C<";
+ say "ok 4 - no double-colon before or after # C $x "; # C
+}
+
+{
+ use strict;
+ $r = eval "
+ $x = D;
+ $v = '>' . $x . '<';
+ 1; "
+ || 0;
+ print 'not ' if $r;
+ say 'ok 5 - Bareword "D" not allowed while "strict subs" in use';
+}
+
+{
+ no strict;
+
+ $x = ::E;
+ $r = ">$x<";
+ print "not " if $r ne ">::E<";
+ say "ok 6 - double-colon before - ::E $x # TODO Parser bug"; # E
+}
+
+{
+ use strict;
+
+ eval q[ $F'x = 9 ];
+ eval q[ $r = ">$F'x<" ];
+ print "not " if $r ne ">9<";
+ say "ok 7 - tick instead of double-colon - \$F'x $r # TODO Parser bug";
+
+ eval q[ $r = ">$F::x<" ];
+ print "not " if $r ne ">9<";
+ say "ok 8 - double-colon instead of tick - \$F::x $r # TODO Parser bug";
+}
+
+{
+ no strict;
+
+ eval q[ $x = ::G'a ];
+ $r = ">$x<";
+ print "not " if $r ne ">::G::a<";
+ say "ok 9 - tick in constant - ::G'a $x # TODO Parser bug";
+}
+
+
View
73 t/v5/30-tie-array.t
@@ -0,0 +1,73 @@
+use perl5;
+use strict;
+use feature 'say';
+
+{
+ package TheArray;
+
+ sub TIEARRAY {
+ my $class = shift;
+ say "# TIEARRAY $class";
+ bless { @_ }, $class
+ }
+
+ sub FETCH {
+ my $self = shift;
+ my $i = shift;
+ say "# FETCH $i";
+ if ($i == 0) {
+ return $self->{'zero'};
+ }
+ }
+
+ sub STORE {
+ my $self = shift;
+ my $i = shift;
+ my $v = shift;
+ say "# STORE $i, $v";
+ if ($i == 0) {
+ $self->{'zero'} = $v;
+ return;
+ }
+ if ($i == 1) {
+ say $v;
+ return;
+ }
+ }
+
+ sub SHIFT {
+ return "shift ok";
+ }
+
+ sub UNTIE {
+ say "# UNTIE";
+ }
+}
+
+sub shift { say "not ok 100 # PKG::shift()" }
+sub CORE::shift { say "not ok 101 # CORE::shift()" }
+sub CORE::GLOBAL::shift { say "not ok 102 # CORE::GLOBAL::shift()" }
+
+say '1..3';
+
+my @list;
+
+tie @list, 'TheArray';
+
+$list[0] = 'first';
+
+if ($list[0] ne 'first') {
+ print 'not '
+};
+say 'ok 1 # ', $list[0];
+
+$list[1] = 'ok 2 # whatever';
+
+my $v = shift @list;
+print "not " unless $v eq 'shift ok';
+say "ok 3 # shift $v";
+
+untie @list;
+
+shift @list;
+
View
49 t/v5/31-autoload.t
@@ -0,0 +1,49 @@
+use feature 'say';
+use strict;
+
+say "1..5";
+
+{
+
+ package A;
+
+ our $AUTOLOAD;
+
+ sub AUTOLOAD {
+ say "# A::AUTOLOAD @_";
+ print "not " if $_[0] != 123;
+ say "ok 1";
+ say "# $AUTOLOAD";
+ print "not " if $AUTOLOAD ne "A::a";
+ say "ok 2";
+ return wantarray ? ( 4, 5 ) : 456;
+ }
+
+ my $v = a(123);
+ print "not " if $v != 456;
+ say "ok 3";
+
+}
+
+{
+
+ package C;
+
+ our $AUTOLOAD;
+
+ sub AUTOLOAD {
+ return wantarray ? ( 6, 7 ) : 456;
+ }
+
+ my @x = a(123);
+ print "not " if $x[0] != 6 || $x[1] != 7;
+ say "ok 4";
+
+ {
+ no strict;
+ my $v = XYZ;
+ print "not " if $v == 456;
+ say "ok 5 # bareword doesn't call AUTOLOAD";
+ }
+}
+
View
45 t/v5/32-autoload-method.t
@@ -0,0 +1,45 @@
+use feature 'say';
+use strict;
+
+say "1..5";
+
+{
+
+ package A;
+
+ our $AUTOLOAD;
+
+ sub AUTOLOAD {
+ say "# A::AUTOLOAD @_";
+ print "not " if $_[0] ne 'A';
+ say "ok 1";
+ print "not " if $_[1] != 123;
+ say "ok 2";
+ say "# $AUTOLOAD";
+ print "not " if $AUTOLOAD ne "A::a";
+ say "ok 3";
+ return wantarray ? ( 4, 5 ) : 456;
+ }
+
+ my $v = A->a(123);
+ print "not " if $v != 456;
+ say "ok 4";
+
+}
+
+{
+
+ package C;
+
+ our $AUTOLOAD;
+
+ sub AUTOLOAD {
+ return wantarray ? ( 6, 7 ) : 456;
+ }
+
+ my @x = C->a(123);
+ print "not " if $x[0] != 6 || $x[1] != 7;
+ say "ok 5";
+
+}
+

No commit comments for this range

Something went wrong with that request. Please try again.