Linux cpanel2.daytoncreative.net 2.6.32-754.29.2.el6.x86_64 #1 SMP Tue May 12 17:39:04 UTC 2020 x86_64
Apache/2.4.43 (cPanel) OpenSSL/1.1.1g mod_bwlimited/1.4
Server IP : 70.62.220.67 & Your IP : 216.73.216.193
Domains :
Cant Read [ /etc/named.conf ]
User : michaelgreg
Terminal
Auto Root
Create File
Create Folder
Localroot Suggester
Backdoor Destroyer
Readme
/
var /
log /
perl-5.20.2 /
t /
op /
Delete
Unzip
Name
Size
Permission
Date
Action
64bitint.t
8.14
KB
-r--r--r--
2014-12-27 11:49
alarm.t
1.5
KB
-r--r--r--
2014-12-27 11:49
anonsub.t
1.7
KB
-r--r--r--
2014-12-27 11:49
append.t
1.58
KB
-r--r--r--
2014-12-27 11:49
args.t
2.12
KB
-r--r--r--
2014-12-27 11:49
array.t
12.32
KB
-r--r--r--
2014-12-27 11:49
array_base.t
720
B
-r--r--r--
2014-12-27 11:49
assignwarn.t
1.52
KB
-r--r--r--
2014-12-27 11:49
attrhand.t
1.01
KB
-r--r--r--
2014-12-27 11:49
attrproto.t
6.55
KB
-r--r--r--
2014-12-27 11:49
attrs.t
10.73
KB
-r--r--r--
2014-12-27 11:49
auto.t
2.36
KB
-r--r--r--
2014-12-27 11:49
avhv.t
4.04
KB
-r--r--r--
2014-12-27 11:49
bless.t
4.12
KB
-r--r--r--
2014-12-27 11:49
blocks.t
2.95
KB
-r--r--r--
2014-12-27 11:49
bop.t
12.82
KB
-r--r--r--
2014-12-27 11:49
caller.pl
3.75
KB
-r--r--r--
2014-12-27 11:49
caller.t
8.14
KB
-r--r--r--
2014-12-27 11:49
chars.t
1.73
KB
-r--r--r--
2014-12-27 11:49
chdir.t
6.68
KB
-r--r--r--
2014-12-27 11:49
chop.t
7.67
KB
-r--r--r--
2014-12-27 11:49
chr.t
2.48
KB
-r--r--r--
2014-12-27 11:49
closure.t
19.6
KB
-r--r--r--
2014-12-27 11:49
closure_test.pl
327
B
-r--r--r--
2014-12-27 11:49
concat2.t
1.41
KB
-r--r--r--
2014-12-27 11:49
cond.t
282
B
-r--r--r--
2014-12-27 11:49
context.t
404
B
-r--r--r--
2014-12-27 11:49
coreamp.t
29.17
KB
-r--r--r--
2014-12-27 11:49
coresubs.t
4.87
KB
-r--r--r--
2014-12-27 11:49
cproto.t
3.6
KB
-r--r--r--
2014-12-27 11:49
crypt.t
1.17
KB
-r--r--r--
2014-12-27 11:49
current_sub.t
1.71
KB
-r--r--r--
2014-12-27 11:49
dbm.t
1.54
KB
-r--r--r--
2014-12-27 11:49
defined.t
551
B
-r--r--r--
2014-12-27 11:49
defins.t
4.84
KB
-r--r--r--
2014-12-27 11:49
delete.t
2.93
KB
-r--r--r--
2014-12-27 11:49
die.t
1.99
KB
-r--r--r--
2014-12-27 11:49
die_except.t
1.57
KB
-r--r--r--
2014-12-27 11:49
die_exit.t
1.9
KB
-r--r--r--
2014-12-27 11:49
die_keeperr.t
1.57
KB
-r--r--r--
2014-12-27 11:49
die_unwind.t
1.69
KB
-r--r--r--
2014-12-27 11:49
do.t
8.35
KB
-r--r--r--
2014-12-27 11:49
dor.t
2.64
KB
-r--r--r--
2014-12-27 11:49
each.t
7.09
KB
-r--r--r--
2014-12-27 11:49
each_array.t
5.48
KB
-r--r--r--
2014-12-27 11:49
eval.t
13.92
KB
-r--r--r--
2014-12-27 11:49
evalbytes.t
989
B
-r--r--r--
2014-12-27 11:49
exec.t
4.36
KB
-r--r--r--
2014-12-27 11:49
exists_sub.t
2.09
KB
-r--r--r--
2014-12-27 11:49
exp.t
1.47
KB
-r--r--r--
2014-12-27 11:49
fh.t
790
B
-r--r--r--
2014-12-27 11:49
filehandle.t
564
B
-r--r--r--
2014-12-27 11:49
filetest.t
11.97
KB
-r--r--r--
2014-12-27 11:49
filetest_stack_ok.t
1.12
KB
-r--r--r--
2014-12-27 11:49
filetest_t.t
1.18
KB
-r--r--r--
2014-12-27 11:49
flip.t
868
B
-r--r--r--
2014-12-27 11:49
for.t
12.77
KB
-r--r--r--
2014-12-27 11:49
fork.t
8.8
KB
-r--r--r--
2014-12-27 11:49
fresh_perl_utf8.t
411
B
-r--r--r--
2014-12-27 11:49
getpid.t
1.61
KB
-r--r--r--
2014-12-27 11:49
getppid.t
3.13
KB
-r--r--r--
2014-12-27 11:49
glob.t
4.22
KB
-r--r--r--
2014-12-27 11:49
gmagic.t
5.97
KB
-r--r--r--
2014-12-27 11:49
goto.t
14.85
KB
-r--r--r--
2014-12-27 11:49
goto_xs.t
2.98
KB
-r--r--r--
2014-12-27 11:49
grent.t
4.46
KB
-r--r--r--
2014-12-27 11:49
grep.t
6.66
KB
-r--r--r--
2014-12-27 11:49
groups.t
11.15
KB
-r--r--r--
2014-12-27 11:49
gv.t
30.15
KB
-r--r--r--
2014-12-27 11:49
hash-rt85026.t
1.57
KB
-r--r--r--
2014-12-27 11:49
hash.t
6.02
KB
-r--r--r--
2014-12-27 11:49
hashassign.t
18.85
KB
-r--r--r--
2014-12-27 11:49
hashwarn.t
2.05
KB
-r--r--r--
2014-12-27 11:49
heredoc.t
2.29
KB
-r--r--r--
2014-12-27 11:49
inc.t
6.72
KB
-r--r--r--
2014-12-27 11:49
inccode-tie.t
338
B
-r--r--r--
2014-12-27 11:49
inccode.t
11.19
KB
-r--r--r--
2014-12-27 11:49
incfilter.t
7.33
KB
-r--r--r--
2014-12-27 11:49
index.t
6.81
KB
-r--r--r--
2014-12-27 11:49
index_thr.t
56
B
-r--r--r--
2014-12-27 11:49
int.t
1.72
KB
-r--r--r--
2014-12-27 11:49
join.t
3.2
KB
-r--r--r--
2014-12-27 11:49
kill0.t
3.18
KB
-r--r--r--
2014-12-27 11:49
kill0_child
596
B
-r--r--r--
2014-12-27 11:49
kvaslice.t
4.66
KB
-r--r--r--
2014-12-27 11:49
kvhslice.t
5.44
KB
-r--r--r--
2014-12-27 11:49
lc.t
11.8
KB
-r--r--r--
2014-12-27 11:49
leaky-magic.t
3.43
KB
-r--r--r--
2014-12-27 11:49
length.t
5.03
KB
-r--r--r--
2014-12-27 11:49
lex.t
2.33
KB
-r--r--r--
2014-12-27 11:49
lex_assign.t
7.17
KB
-r--r--r--
2014-12-27 11:49
lexsub.t
19.62
KB
-r--r--r--
2014-12-27 12:24
lfs.t
6.2
KB
-r--r--r--
2014-12-27 11:49
list.t
5.31
KB
-r--r--r--
2014-12-27 11:52
local.t
17.11
KB
-r--r--r--
2014-12-27 11:49
localref.t
2.73
KB
-r--r--r--
2014-12-27 11:49
lock.t
465
B
-r--r--r--
2014-12-27 11:49
loopctl.t
17.88
KB
-r--r--r--
2014-12-27 11:49
lop.t
1.2
KB
-r--r--r--
2014-12-27 11:49
magic-27839.t
622
B
-r--r--r--
2014-12-27 11:49
magic.t
21.81
KB
-r--r--r--
2014-12-27 11:49
method.t
18.91
KB
-r--r--r--
2014-12-27 11:49
mkdir.t
1.25
KB
-r--r--r--
2014-12-27 11:49
my.t
4.29
KB
-r--r--r--
2014-12-27 11:49
my_stash.t
769
B
-r--r--r--
2014-12-27 11:49
mydef.t
5.51
KB
-r--r--r--
2014-12-27 11:49
negate.t
4.3
KB
-r--r--r--
2014-12-27 11:49
not.t
3.15
KB
-r--r--r--
2014-12-27 11:49
numconvert.t
8.33
KB
-r--r--r--
2014-12-27 11:49
oct.t
3.58
KB
-r--r--r--
2014-12-27 11:49
or.t
1.79
KB
-r--r--r--
2014-12-27 11:49
ord.t
2.48
KB
-r--r--r--
2014-12-27 11:49
overload_integer.t
506
B
-r--r--r--
2014-12-27 11:49
override.t
4.33
KB
-r--r--r--
2014-12-27 11:49
pack.t
65.34
KB
-r--r--r--
2014-12-27 11:49
packagev.t
5.97
KB
-r--r--r--
2014-12-27 11:49
pos.t
3.59
KB
-r--r--r--
2014-12-27 11:49
postfixderef.t
11.97
KB
-r--r--r--
2014-12-27 11:49
pow.t
2.34
KB
-r--r--r--
2014-12-27 11:49
print.t
692
B
-r--r--r--
2014-12-27 11:49
protowarn.t
1.35
KB
-r--r--r--
2014-12-27 11:49
push.t
3.03
KB
-r--r--r--
2014-12-27 11:49
pwent.t
6.63
KB
-r--r--r--
2014-12-27 11:49
qr.t
2.32
KB
-r--r--r--
2014-12-27 11:49
quotemeta.t
5.61
KB
-r--r--r--
2014-12-27 11:49
rand.t
8.31
KB
-r--r--r--
2014-12-27 11:49
range.t
9.25
KB
-r--r--r--
2014-12-27 11:49
read.t
2.28
KB
-r--r--r--
2014-12-27 11:49
readdir.t
2.09
KB
-r--r--r--
2014-12-27 11:49
readline.t
7.19
KB
-r--r--r--
2014-12-27 11:49
recurse.t
2.73
KB
-r--r--r--
2014-12-27 11:49
ref.t
22.74
KB
-r--r--r--
2014-12-27 11:49
repeat.t
4.8
KB
-r--r--r--
2014-12-27 11:49
require_37033.t
1.18
KB
-r--r--r--
2014-12-27 11:49
require_errors.t
3.68
KB
-r--r--r--
2014-12-27 11:49
reset.t
5.41
KB
-r--r--r--
2014-12-27 11:49
reverse.t
3.01
KB
-r--r--r--
2014-12-27 11:49
rt119311.t
5.58
KB
-r--r--r--
2014-12-27 11:49
runlevel.t
5.28
KB
-r--r--r--
2014-12-27 11:49
select.t
1.03
KB
-r--r--r--
2014-12-27 11:49
setpgrpstack.t
378
B
-r--r--r--
2014-12-27 11:49
sigdispatch.t
4.33
KB
-r--r--r--
2014-12-27 11:49
signatures.t
41.02
KB
-r--r--r--
2014-12-27 11:49
sigsystem.t
1.36
KB
-r--r--r--
2014-12-27 11:49
sleep.t
468
B
-r--r--r--
2014-12-27 11:49
smartkve.t
18.26
KB
-r--r--r--
2014-12-27 11:49
smartmatch.t
10.34
KB
-r--r--r--
2014-12-27 11:49
sort.t
28.4
KB
-r--r--r--
2015-01-10 13:17
splice.t
3.38
KB
-r--r--r--
2014-12-27 11:49
split.t
13.1
KB
-r--r--r--
2014-12-27 11:49
split_unicode.t
2.4
KB
-r--r--r--
2014-12-27 11:49
sprintf.t
28.5
KB
-r--r--r--
2014-12-27 11:49
sprintf2.t
5.49
KB
-r--r--r--
2014-12-27 11:49
srand.t
1.87
KB
-r--r--r--
2014-12-27 11:49
sselect.t
2.67
KB
-r--r--r--
2014-12-27 11:49
stash.t
9.01
KB
-r--r--r--
2014-12-27 11:49
stat.t
17.51
KB
-r--r--r--
2014-12-27 11:49
state.t
9.72
KB
-r--r--r--
2014-12-27 12:15
study.t
2.99
KB
-r--r--r--
2014-12-27 11:49
studytied.t
1.29
KB
-r--r--r--
2014-12-27 11:49
sub.t
6.54
KB
-r--r--r--
2014-12-27 11:49
sub_lval.t
24.2
KB
-r--r--r--
2014-12-27 11:49
substr.t
20.53
KB
-r--r--r--
2014-12-27 11:49
substr_thr.t
56
B
-r--r--r--
2014-12-27 11:49
svleak.pl
6
B
-r--r--r--
2014-12-27 11:49
svleak.t
15.93
KB
-r--r--r--
2015-01-10 12:06
switch.t
28.06
KB
-r--r--r--
2014-12-27 11:49
symbolcache.t
1.06
KB
-r--r--r--
2014-12-27 11:49
sysio.t
5
KB
-r--r--r--
2014-12-27 11:49
taint.t
66.84
KB
-r--r--r--
2014-12-27 12:32
threads-dirh.t
3.47
KB
-r--r--r--
2014-12-27 11:49
threads.t
9.3
KB
-r--r--r--
2014-12-27 11:49
threads_create.pl
42
B
-r--r--r--
2014-12-27 11:49
tie.t
28.34
KB
-r--r--r--
2014-12-27 11:49
tie_fetch_count.t
11.49
KB
-r--r--r--
2014-12-27 11:49
tiearray.t
4.53
KB
-r--r--r--
2014-12-27 11:49
tiehandle.t
5.27
KB
-r--r--r--
2014-12-27 11:49
time.t
7.86
KB
-r--r--r--
2015-01-17 11:51
time_loop.t
378
B
-r--r--r--
2014-12-27 11:49
tr.t
12.99
KB
-r--r--r--
2014-12-27 11:49
undef.t
3.15
KB
-r--r--r--
2014-12-27 11:49
universal.t
8.32
KB
-r--r--r--
2014-12-27 11:49
unlink.t
1.02
KB
-r--r--r--
2014-12-27 11:49
unshift.t
3.17
KB
-r--r--r--
2014-12-27 11:49
upgrade.t
1.15
KB
-r--r--r--
2014-12-27 11:49
utf8cache.t
3.83
KB
-r--r--r--
2014-12-27 11:49
utf8decode.t
7.59
KB
-r--r--r--
2014-12-27 11:49
utf8magic.t
808
B
-r--r--r--
2014-12-27 11:49
utfhash.t
5.33
KB
-r--r--r--
2014-12-27 11:49
utftaint.t
4.46
KB
-r--r--r--
2014-12-27 11:49
vec.t
2.87
KB
-r--r--r--
2014-12-27 11:49
ver.t
8.39
KB
-r--r--r--
2014-12-27 11:49
waitpid.t
973
B
-r--r--r--
2014-12-27 11:49
wantarray.t
874
B
-r--r--r--
2014-12-27 11:49
warn.t
4.15
KB
-r--r--r--
2014-12-27 11:49
while.t
3.81
KB
-r--r--r--
2014-12-27 11:49
write.t
39.99
KB
-r--r--r--
2015-01-24 15:03
yadayada.t
1.67
KB
-r--r--r--
2015-01-15 22:12
Save
Rename
#!./perl BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } use strict; use warnings; no warnings 'experimental::smartmatch'; plan tests => 201; # The behaviour of the feature pragma should be tested by lib/feature.t # using the tests in t/lib/feature/*. This file tests the behaviour of # the switch ops themselves. # Before loading feature, test the switch ops with CORE:: CORE::given(3) { CORE::when(3) { pass "CORE::given and CORE::when"; continue } CORE::default { pass "continue (without feature) and CORE::default" } } use feature 'switch'; eval { continue }; like($@, qr/^Can't "continue" outside/, "continue outside"); eval { break }; like($@, qr/^Can't "break" outside/, "break outside"); # Scoping rules { my $x = "foo"; given(my $x = "bar") { is($x, "bar", "given scope starts"); } is($x, "foo", "given scope ends"); } sub be_true {1} given(my $x = "foo") { when(be_true(my $x = "bar")) { is($x, "bar", "given scope starts"); } is($x, "foo", "given scope ends"); } $_ = "outside"; given("inside") { check_outside1() } sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") } { no warnings 'experimental::lexical_topic'; my $_ = "outside"; given("inside") { check_outside2() } sub check_outside2 { is($_, "outside", "\$_ lexically scoped (lexical \$_)") } } # Basic string/numeric comparisons and control flow { my $ok; given(3) { when(2) { $ok = 'two'; } when(3) { $ok = 'three'; } when(4) { $ok = 'four'; } default { $ok = 'd'; } } is($ok, 'three', "numeric comparison"); } { my $ok; use integer; given(3.14159265) { when(2) { $ok = 'two'; } when(3) { $ok = 'three'; } when(4) { $ok = 'four'; } default { $ok = 'd'; } } is($ok, 'three', "integer comparison"); } { my ($ok1, $ok2); given(3) { when(3.1) { $ok1 = 'n'; } when(3.0) { $ok1 = 'y'; continue } when("3.0") { $ok2 = 'y'; } default { $ok2 = 'n'; } } is($ok1, 'y', "more numeric (pt. 1)"); is($ok2, 'y', "more numeric (pt. 2)"); } { my $ok; given("c") { when("b") { $ok = 'B'; } when("c") { $ok = 'C'; } when("d") { $ok = 'D'; } default { $ok = 'def'; } } is($ok, 'C', "string comparison"); } { my $ok; given("c") { when("b") { $ok = 'B'; } when("c") { $ok = 'C'; continue } when("c") { $ok = 'CC'; } default { $ok = 'D'; } } is($ok, 'CC', "simple continue"); } # Definedness { my $ok = 1; given (0) { when(undef) {$ok = 0} } is($ok, 1, "Given(0) when(undef)"); } { my $undef; my $ok = 1; given (0) { when($undef) {$ok = 0} } is($ok, 1, 'Given(0) when($undef)'); } { my $undef; my $ok = 0; given (0) { when($undef++) {$ok = 1} } is($ok, 1, "Given(0) when($undef++)"); } { no warnings "uninitialized"; my $ok = 1; given (undef) { when(0) {$ok = 0} } is($ok, 1, "Given(undef) when(0)"); } { no warnings "uninitialized"; my $undef; my $ok = 1; given ($undef) { when(0) {$ok = 0} } is($ok, 1, 'Given($undef) when(0)'); } ######## { my $ok = 1; given ("") { when(undef) {$ok = 0} } is($ok, 1, 'Given("") when(undef)'); } { my $undef; my $ok = 1; given ("") { when($undef) {$ok = 0} } is($ok, 1, 'Given("") when($undef)'); } { no warnings "uninitialized"; my $ok = 1; given (undef) { when("") {$ok = 0} } is($ok, 1, 'Given(undef) when("")'); } { no warnings "uninitialized"; my $undef; my $ok = 1; given ($undef) { when("") {$ok = 0} } is($ok, 1, 'Given($undef) when("")'); } ######## { my $ok = 0; given (undef) { when(undef) {$ok = 1} } is($ok, 1, "Given(undef) when(undef)"); } { my $undef; my $ok = 0; given (undef) { when($undef) {$ok = 1} } is($ok, 1, 'Given(undef) when($undef)'); } { my $undef; my $ok = 0; given ($undef) { when(undef) {$ok = 1} } is($ok, 1, 'Given($undef) when(undef)'); } { my $undef; my $ok = 0; given ($undef) { when($undef) {$ok = 1} } is($ok, 1, 'Given($undef) when($undef)'); } # Regular expressions { my ($ok1, $ok2); given("Hello, world!") { when(/lo/) { $ok1 = 'y'; continue} when(/no/) { $ok1 = 'n'; continue} when(/^(Hello,|Goodbye cruel) world[!.?]/) { $ok2 = 'Y'; continue} when(/^(Hello cruel|Goodbye,) world[!.?]/) { $ok2 = 'n'; continue} } is($ok1, 'y', "regex 1"); is($ok2, 'Y', "regex 2"); } # Comparisons { my $test = "explicit numeric comparison (<)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ < 10) { $ok = "ten" } when ($_ < 20) { $ok = "twenty" } when ($_ < 30) { $ok = "thirty" } when ($_ < 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { use integer; my $test = "explicit numeric comparison (integer <)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ < 10) { $ok = "ten" } when ($_ < 20) { $ok = "twenty" } when ($_ < 30) { $ok = "thirty" } when ($_ < 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit numeric comparison (<=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ <= 10) { $ok = "ten" } when ($_ <= 20) { $ok = "twenty" } when ($_ <= 30) { $ok = "thirty" } when ($_ <= 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { use integer; my $test = "explicit numeric comparison (integer <=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ <= 10) { $ok = "ten" } when ($_ <= 20) { $ok = "twenty" } when ($_ <= 30) { $ok = "thirty" } when ($_ <= 40) { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit numeric comparison (>)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ > 40) { $ok = "forty" } when ($_ > 30) { $ok = "thirty" } when ($_ > 20) { $ok = "twenty" } when ($_ > 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit numeric comparison (>=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ >= 40) { $ok = "forty" } when ($_ >= 30) { $ok = "thirty" } when ($_ >= 20) { $ok = "twenty" } when ($_ >= 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { use integer; my $test = "explicit numeric comparison (integer >)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ > 40) { $ok = "forty" } when ($_ > 30) { $ok = "thirty" } when ($_ > 20) { $ok = "twenty" } when ($_ > 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { use integer; my $test = "explicit numeric comparison (integer >=)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ >= 40) { $ok = "forty" } when ($_ >= 30) { $ok = "thirty" } when ($_ >= 20) { $ok = "twenty" } when ($_ >= 10) { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit string comparison (lt)"; my $twenty_five = "25"; my $ok; given($twenty_five) { when ($_ lt "10") { $ok = "ten" } when ($_ lt "20") { $ok = "twenty" } when ($_ lt "30") { $ok = "thirty" } when ($_ lt "40") { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit string comparison (le)"; my $twenty_five = "25"; my $ok; given($twenty_five) { when ($_ le "10") { $ok = "ten" } when ($_ le "20") { $ok = "twenty" } when ($_ le "30") { $ok = "thirty" } when ($_ le "40") { $ok = "forty" } default { $ok = "default" } } is($ok, "thirty", $test); } { my $test = "explicit string comparison (gt)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } { my $test = "explicit string comparison (ge)"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } # Make sure it still works with a lexical $_: { no warnings 'experimental::lexical_topic'; my $_; my $test = "explicit comparison with lexical \$_"; my $twenty_five = 25; my $ok; given($twenty_five) { when ($_ ge "40") { $ok = "forty" } when ($_ ge "30") { $ok = "thirty" } when ($_ ge "20") { $ok = "twenty" } when ($_ ge "10") { $ok = "ten" } default { $ok = "default" } } is($ok, "twenty", $test); } # Optimized-away comparisons { my $ok; given(23) { when (2 + 2 == 4) { $ok = 'y'; continue } when (2 + 2 == 5) { $ok = 'n' } } is($ok, 'y', "Optimized-away comparison"); } { my $ok; given(23) { when (scalar 24) { $ok = 'n'; continue } default { $ok = 'y' } } is($ok,'y','scalar()'); } # File tests # (How to be both thorough and portable? Pinch a few ideas # from t/op/filetest.t. We err on the side of portability for # the time being.) { my ($ok_d, $ok_f, $ok_r); given("op") { when(-d) {$ok_d = 1; continue} when(!-f) {$ok_f = 1; continue} when(-r) {$ok_r = 1; continue} } ok($ok_d, "Filetest -d"); ok($ok_f, "Filetest -f"); ok($ok_r, "Filetest -r"); } # Sub and method calls sub notfoo {"bar"} { my $ok = 0; given("foo") { when(notfoo()) {$ok = 1} } ok($ok, "Sub call acts as boolean") } { my $ok = 0; given("foo") { when(main->notfoo()) {$ok = 1} } ok($ok, "Class-method call acts as boolean") } { my $ok = 0; my $obj = bless []; given("foo") { when($obj->notfoo()) {$ok = 1} } ok($ok, "Object-method call acts as boolean") } # Other things that should not be smart matched { my $ok = 0; given(12) { when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { $ok = 1; } } ok($ok, "bool not smartmatches"); } { my $ok = 0; given(0) { when(eof(DATA)) { $ok = 1; } } ok($ok, "eof() not smartmatched"); } { my $ok = 0; my %foo = ("bar", 0); given(0) { when(exists $foo{bar}) { $ok = 1; } } ok($ok, "exists() not smartmatched"); } { my $ok = 0; given(0) { when(defined $ok) { $ok = 1; } } ok($ok, "defined() not smartmatched"); } { my $ok = 1; given("foo") { when((1 == 1) && "bar") { $ok = 0; } when((1 == 1) && $_ eq "foo") { $ok = 2; } } is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); } { my $n = 0; for my $l (qw(a b c d)) { given ($l) { when ($_ eq "b" .. $_ eq "c") { $n = 1 } default { $n = 0 } } ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context'); } } { my $n = 0; for my $l (qw(a b c d)) { given ($l) { when ($_ eq "b" ... $_ eq "c") { $n = 1 } default { $n = 0 } } ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context'); } } { my $ok = 0; given("foo") { when((1 == $ok) || "foo") { $ok = 1; } } ok($ok, '((1 == $ok) || "foo") smartmatched'); } { my $ok = 0; given("foo") { when((1 == $ok || undef) // "foo") { $ok = 1; } } ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); } # Make sure we aren't invoking the get-magic more than once { # A helper class to count the number of accesses. package FetchCounter; sub TIESCALAR { my ($class) = @_; bless {value => undef, count => 0}, $class; } sub STORE { my ($self, $val) = @_; $self->{count} = 0; $self->{value} = $val; } sub FETCH { my ($self) = @_; # Avoid pre/post increment here $self->{count} = 1 + $self->{count}; $self->{value}; } sub count { my ($self) = @_; $self->{count}; } } my $f = tie my $v, "FetchCounter"; { my $test_name = "Multiple FETCHes in given, due to aliasing"; my $ok; given($v = 23) { when(undef) {} when(sub{0}->()) {} when(21) {} when("22") {} when(23) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 4, $test_name); } { my $test_name = "Only one FETCH (numeric when)"; my $ok; $v = 23; is($f->count(), 0, "Sanity check: $test_name"); given(23) { when(undef) {} when(sub{0}->()) {} when(21) {} when("22") {} when($v) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } { my $test_name = "Only one FETCH (string when)"; my $ok; $v = "23"; is($f->count(), 0, "Sanity check: $test_name"); given("23") { when(undef) {} when(sub{0}->()) {} when("21") {} when("22") {} when($v) {$ok = 1} when(/24/) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } { my $test_name = "Only one FETCH (undef)"; my $ok; $v = undef; is($f->count(), 0, "Sanity check: $test_name"); no warnings "uninitialized"; given(my $undef) { when(sub{0}->()) {} when("21") {} when("22") {} when($v) {$ok = 1} when(undef) {$ok = 0} } is($ok, 1, "precheck: $test_name"); is($f->count(), 1, $test_name); } # Loop topicalizer { my $first = 1; for (1, "two") { when ("two") { is($first, 0, "Loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Loop: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; for $_ (1, "two") { when ("two") { is($first, 0, "Explicit \$_: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Explicit \$_: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; no warnings 'experimental::lexical_topic'; my $_; for (1, "two") { when ("two") { is($first, 0, "Implicitly lexical loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Implicitly lexical loop: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; no warnings 'experimental::lexical_topic'; my $_; for $_ (1, "two") { when ("two") { is($first, 0, "Implicitly lexical, explicit \$_: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Implicitly lexical, explicit \$_: first"); $first = 0; # Implicit break is okay } } } { my $first = 1; no warnings 'experimental::lexical_topic'; for my $_ (1, "two") { when ("two") { is($first, 0, "Lexical loop: second"); eval {break}; like($@, qr/^Can't "break" in a loop topicalizer/, q{Can't "break" in a loop topicalizer}); } when (1) { is($first, 1, "Lexical loop: first"); $first = 0; # Implicit break is okay } } } # Code references { my $called_foo = 0; sub foo {$called_foo = 1; "@_" eq "foo"} my $called_bar = 0; sub bar {$called_bar = 1; "@_" eq "bar"} my ($matched_foo, $matched_bar) = (0, 0); given("foo") { when(\&bar) {$matched_bar = 1} when(\&foo) {$matched_foo = 1} } is($called_foo, 1, "foo() was called"); is($called_bar, 1, "bar() was called"); is($matched_bar, 0, "bar didn't match"); is($matched_foo, 1, "foo did match"); } sub contains_x { my $x = shift; return ($x =~ /x/); } { my ($ok1, $ok2) = (0,0); given("foxy!") { when(contains_x($_)) { $ok1 = 1; continue } when(\&contains_x) { $ok2 = 1; continue } } is($ok1, 1, "Calling sub directly (true)"); is($ok2, 1, "Calling sub indirectly (true)"); given("foggy") { when(contains_x($_)) { $ok1 = 2; continue } when(\&contains_x) { $ok2 = 2; continue } } is($ok1, 1, "Calling sub directly (false)"); is($ok2, 1, "Calling sub indirectly (false)"); } SKIP: { skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14); # Test overloading { package OverloadTest; use overload '""' => sub{"string value of obj"}; use overload 'eq' => sub{"$_[0]" eq "$_[1]"}; use overload "~~" => sub { my ($self, $other, $reversed) = @_; if ($reversed) { $self->{left} = $other; $self->{right} = $self; $self->{reversed} = 1; } else { $self->{left} = $self; $self->{right} = $other; $self->{reversed} = 0; } $self->{called} = 1; return $self->{retval}; }; sub new { my ($pkg, $retval) = @_; bless { called => 0, retval => $retval, }, $pkg; } } { my $test = "Overloaded obj in given (true)"; my $obj = OverloadTest->new(1); my $matched; given($obj) { when ("other arg") {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok($matched, "$test: matched"); } { my $test = "Overloaded obj in given (false)"; my $obj = OverloadTest->new(0); my $matched; given($obj) { when ("other arg") {$matched = 1} } is($obj->{called}, 1, "$test: called"); ok(!$matched, "$test: not matched"); } { my $test = "Overloaded obj in when (true)"; my $obj = OverloadTest->new(1); my $matched; given("topic") { when ($obj) {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok($matched, "$test: matched"); is($obj->{left}, "topic", "$test: left"); is($obj->{right}, "string value of obj", "$test: right"); ok($obj->{reversed}, "$test: reversed"); } { my $test = "Overloaded obj in when (false)"; my $obj = OverloadTest->new(0); my $matched; given("topic") { when ($obj) {$matched = 1} default {$matched = 0} } is($obj->{called}, 1, "$test: called"); ok(!$matched, "$test: not matched"); is($obj->{left}, "topic", "$test: left"); is($obj->{right}, "string value of obj", "$test: right"); ok($obj->{reversed}, "$test: reversed"); } } # Postfix when { my $ok; given (undef) { $ok = 1 when undef; } is($ok, 1, "postfix undef"); } { my $ok; given (2) { $ok += 1 when 7; $ok += 2 when 9.1685; $ok += 4 when $_ > 4; $ok += 8 when $_ < 2.5; } is($ok, 8, "postfix numeric"); } { my $ok; given ("apple") { $ok = 1, continue when $_ eq "apple"; $ok += 2; $ok = 0 when "banana"; } is($ok, 3, "postfix string"); } { my $ok; given ("pear") { do { $ok = 1; continue } when /pea/; $ok += 2; $ok = 0 when /pie/; default { $ok += 4 } $ok = 0; } is($ok, 7, "postfix regex"); } # be_true is defined at the beginning of the file { my $x = "what"; given(my $x = "foo") { do { is($x, "foo", "scope inside ... when my \$x = ..."); continue; } when be_true(my $x = "bar"); is($x, "bar", "scope after ... when my \$x = ..."); } } { my $x = 0; given(my $x = 1) { my $x = 2, continue when be_true(); is($x, undef, "scope after my \$x = ... when ..."); } } # Tests for last and next in when clauses my $letter; $letter = ''; for ("a".."e") { given ($_) { $letter = $_; when ("b") { last } } $letter = "z"; } is($letter, "b", "last in when"); $letter = ''; LETTER1: for ("a".."e") { given ($_) { $letter = $_; when ("b") { last LETTER1 } } $letter = "z"; } is($letter, "b", "last LABEL in when"); $letter = ''; for ("a".."e") { given ($_) { when (/b|d/) { next } $letter .= $_; } $letter .= ','; } is($letter, "a,c,e,", "next in when"); $letter = ''; LETTER2: for ("a".."e") { given ($_) { when (/b|d/) { next LETTER2 } $letter .= $_; } $letter .= ','; } is($letter, "a,c,e,", "next LABEL in when"); # Test goto with given/when { my $flag = 0; goto GIVEN1; $flag = 1; GIVEN1: given ($flag) { when (0) { break; } $flag = 2; } is($flag, 0, "goto GIVEN1"); } { my $flag = 0; given ($flag) { when (0) { $flag = 1; } goto GIVEN2; $flag = 2; } GIVEN2: is($flag, 1, "goto inside given"); } { my $flag = 0; given ($flag) { when (0) { $flag = 1; goto GIVEN3; $flag = 2; } $flag = 3; } GIVEN3: is($flag, 1, "goto inside given and when"); } { my $flag = 0; for ($flag) { when (0) { $flag = 1; goto GIVEN4; $flag = 2; } $flag = 3; } GIVEN4: is($flag, 1, "goto inside for and when"); } { my $flag = 0; GIVEN5: given ($flag) { when (0) { $flag = 1; goto GIVEN5; $flag = 2; } when (1) { break; } $flag = 3; } is($flag, 1, "goto inside given and when to the given stmt"); } # test with unreified @_ in smart match [perl #71078] sub unreified_check { ok([@_] ~~ \@_) } # should always match unreified_check(1,2,"lala"); unreified_check(1,2,undef); unreified_check(undef); unreified_check(undef,""); # Test do { given } as a rvalue { # Simple scalar my $lexical = 5; my @things = (11 .. 26); # 16 elements my @exp = (5, 16, 9); no warnings 'void'; for (0, 1, 2) { my $scalar = do { given ($_) { when (0) { $lexical } when (2) { 'void'; 8, 9 } @things; } }; is($scalar, shift(@exp), "rvalue given - simple scalar [$_]"); } } { # Postfix scalar my $lexical = 5; my @exp = (5, 7, 9); for (0, 1, 2) { no warnings 'void'; my $scalar = do { given ($_) { $lexical when 0; 8, 9 when 2; 6, 7; } }; is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]"); } } { # Default scalar my @exp = (5, 9, 9); for (0, 1, 2) { my $scalar = do { given ($_) { no warnings 'void'; when (0) { 5 } default { 8, 9 } 6, 7; } }; is($scalar, shift(@exp), "rvalue given - default scalar [$_]"); } } { # Simple list my @things = (11 .. 13); my @exp = ('3 4 5', '11 12 13', '8 9'); for (0, 1, 2) { my @list = do { given ($_) { when (0) { 3 .. 5 } when (2) { my $fake = 'void'; 8, 9 } @things; } }; is("@list", shift(@exp), "rvalue given - simple list [$_]"); } } { # Postfix list my @things = (12); my @exp = ('3 4 5', '6 7', '12'); for (0, 1, 2) { my @list = do { given ($_) { 3 .. 5 when 0; @things when 2; 6, 7; } }; is("@list", shift(@exp), "rvalue given - postfix list [$_]"); } } { # Default list my @things = (11 .. 20); # 10 elements my @exp = ('m o o', '8 10', '8 10'); for (0, 1, 2) { my @list = do { given ($_) { when (0) { "moo" =~ /(.)/g } default { 8, scalar(@things) } 6, 7; } }; is("@list", shift(@exp), "rvalue given - default list [$_]"); } } { # Switch control my @exp = ('6 7', '', '6 7'); for (0, 1, 2, 3) { my @list = do { given ($_) { continue when $_ <= 1; break when 1; next when 2; 6, 7; } }; is("@list", shift(@exp), "rvalue given - default list [$_]"); } } { # Context propagation my $smart_hash = sub { do { given ($_[0]) { 'undef' when undef; when ([ 1 .. 3 ]) { 1 .. 3 } when (4) { my $fake; do { 4, 5 } } } }; }; my $scalar; $scalar = $smart_hash->(); is($scalar, 'undef', "rvalue given - scalar context propagation [undef]"); $scalar = $smart_hash->(4); is($scalar, 5, "rvalue given - scalar context propagation [4]"); $scalar = $smart_hash->(999); is($scalar, undef, "rvalue given - scalar context propagation [999]"); my @list; @list = $smart_hash->(); is("@list", 'undef', "rvalue given - list context propagation [undef]"); @list = $smart_hash->(2); is("@list", '1 2 3', "rvalue given - list context propagation [2]"); @list = $smart_hash->(4); is("@list", '4 5', "rvalue given - list context propagation [4]"); @list = $smart_hash->(999); is("@list", '', "rvalue given - list context propagation [999]"); } { # Array slices my @list = 10 .. 15; my @in_list; my @in_slice; for (5, 10, 15) { given ($_) { when (@list) { push @in_list, $_; continue; } when (@list[0..2]) { push @in_slice, $_; } } } is("@in_list", "10 15", "when(array)"); is("@in_slice", "10", "when(array slice)"); } { # Hash slices my %list = map { $_ => $_ } "a" .. "f"; my @in_list; my @in_slice; for ("a", "e", "i") { given ($_) { when (%list) { push @in_list, $_; continue; } when (@list{"a".."c"}) { push @in_slice, $_; } } } is("@in_list", "a e", "when(hash)"); is("@in_slice", "a", "when(hash slice)"); } { # RT#84526 - Handle magical TARG my $x = my $y = "aaa"; for ($x, $y) { given ($_) { is(pos, undef, "handle magical TARG"); pos = 1; } } } # Test that returned values are correctly propagated through several context # levels (see RT #93548). { my $tester = sub { my $id = shift; package fmurrr; our ($when_loc, $given_loc, $ext_loc); my $ext_lex = 7; our $ext_glob = 8; local $ext_loc = 9; given ($id) { my $given_lex = 4; our $given_glob = 5; local $given_loc = 6; when (0) { 0 } when (1) { my $when_lex = 1 } when (2) { our $when_glob = 2 } when (3) { local $when_loc = 3 } when (4) { $given_lex } when (5) { $given_glob } when (6) { $given_loc } when (7) { $ext_lex } when (8) { $ext_glob } when (9) { $ext_loc } 'fallback'; } }; my @descriptions = qw< constant when-lexical when-global when-local given-lexical given-global given-local extern-lexical extern-global extern-local >; for my $id (0 .. 9) { my $desc = $descriptions[$id]; my $res = $tester->($id); is $res, $id, "plain call - $desc"; $res = do { my $id_plus_1 = $id + 1; given ($id_plus_1) { do { when (/\d/) { --$id_plus_1; continue; 456; } }; default { $tester->($id_plus_1); } 'XXX'; } }; is $res, $id, "across continue and default - $desc"; } } # Check that values returned from given/when are destroyed at the right time. { { package Fmurrr; sub new { bless { flag => \($_[1]), id => $_[2], }, $_[0] } sub DESTROY { ${$_[0]->{flag}}++; } } my @descriptions = qw< when break continue default >; for my $id (0 .. 3) { my $desc = $descriptions[$id]; my $destroyed = 0; my $res_id; { my $res = do { given ($id) { my $x; when (0) { Fmurrr->new($destroyed, 0) } when (1) { my $y = Fmurrr->new($destroyed, 1); break } when (2) { $x = Fmurrr->new($destroyed, 2); continue } when (2) { $x } default { Fmurrr->new($destroyed, 3) } } }; $res_id = $res->{id}; } $res_id = $id if $id == 1; # break doesn't return anything is $res_id, $id, "given/when returns the right object - $desc"; is $destroyed, 1, "given/when does not leak - $desc"; }; } # break() must reset the stack { my @res = (1, do { given ("x") { 2, 3, do { when (/[a-z]/) { 4, 5, 6, break } } } }); is "@res", "1", "break resets the stack"; } # RT #94682: # must ensure $_ is initialised and cleared at start/end of given block { sub f1 { no warnings 'experimental::lexical_topic'; my $_; given(3) { return sub { $_ } # close over lexical $_ } } is(f1()->(), 3, 'closed over $_'); package RT94682; my $d = 0; sub DESTROY { $d++ }; sub f2 { no warnings 'experimental::lexical_topic'; my $_ = 5; given(bless [7]) { ::is($_->[0], 7, "is [7]"); } ::is($_, 5, "is 5"); ::is($d, 1, "DESTROY called once"); } f2(); } # Okay, that'll do for now. The intricacies of the smartmatch # semantics are tested in t/op/smartmatch.t. Taintedness of # returned values is checked in t/op/taint.t. __END__