diff options
author | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
---|---|---|
committer | markm <markm@FreeBSD.org> | 2000-06-25 11:04:01 +0000 |
commit | 2618fad5bbb2d0182eb31ed805c41b543c513940 (patch) | |
tree | 52ba93338b13aefd02a0055304a9eccfa0e049f5 /contrib/perl5/t/lib/attrs.t | |
parent | 77644ee620b6a79cf8c538abaf7cd301a875528d (diff) | |
download | FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.zip FreeBSD-src-2618fad5bbb2d0182eb31ed805c41b543c513940.tar.gz |
Vendor import of Perl 5.006
Diffstat (limited to 'contrib/perl5/t/lib/attrs.t')
-rwxr-xr-x | contrib/perl5/t/lib/attrs.t | 138 |
1 files changed, 138 insertions, 0 deletions
diff --git a/contrib/perl5/t/lib/attrs.t b/contrib/perl5/t/lib/attrs.t new file mode 100755 index 0000000..eb8c8c4 --- /dev/null +++ b/contrib/perl5/t/lib/attrs.t @@ -0,0 +1,138 @@ +#!./perl + +# Regression tests for attrs.pm and the C<sub x : attrs> syntax. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + eval 'require attrs; 1' or do { + print "1..0\n"; + exit 0; + } +} + +sub NTESTS () ; + +my $test, $ntests; +BEGIN {$ntests=0} +$test=0; +my $failed = 0; + +print "1..".NTESTS."\n"; + +eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t2 { use attrs "locked"; $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t3 ($) : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub t4 : locked ;'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon1; +eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon2; +eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my $anon3; +eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; +(print "not "), $failed=1 if $@; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +my @attrs = attrs::get($anon3 ? $anon3 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); +(print "not "), $failed=1 unless "@attrs" eq "locked method"; +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e1 ($) : plugh ;'; +unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; +unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; +unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +eval 'sub e4 ($) : plugh + xyzzy ;'; +unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# $x\n"; + print "not "; + $failed = 1; +} +print "ok ",++$test,"\n"; +BEGIN {++$ntests} + +{ + my $w = "" ; + local $SIG{__WARN__} = sub {$w = @_[0]} ; + eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }'; + (print "not "), $failed=1 if $@; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} + (print "not "), $failed=1 + if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/; + print "ok ",++$test,"\n"; + BEGIN {++$ntests} +} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; |