fix up the namedproto test
[perl.git] / t / comp / namedproto.t
1 #!./perl
2 #
3 # Tests for named prototypes
4
5
6 my @warnings;
7 my $test;
8
9 BEGIN {
10     chdir 't' if -d 't';
11     @INC = ('../lib','.');
12     $SIG{'__WARN__'} = sub { push @warnings, @_ };
13     $| = 1;
14 }
15
16 sub is_miniperl { !defined &DynaLoader::boot_DynaLoader }
17
18 sub failed {
19     my ($got, $expected, $name) = @_;
20     print "not ok $test - $name\n";
21     my @caller = caller(1);
22     print "# Failed test at $caller[1] line $caller[2]\n";
23     if (defined $got) {
24         print "# Got '$got'\n";
25     } else {
26         print "# Got undef\n";
27     }
28     print "# Expected $expected\n";
29     return;
30 }
31
32 sub like {
33     my ($got, $pattern, $name) = @_;
34     $test = $test + 1;
35     if ($::TODO) {
36         $name .= " # TODO: $::TODO";
37     }
38     if (defined $got && $got =~ $pattern) {
39         print "ok $test - $name\n";
40         # Principle of least surprise - maintain the expected interface, even
41         # though we aren't using it here (yet).
42         return 1;
43     }
44     failed($got, $pattern, $name);
45 }
46
47 sub is {
48     my ($got, $expect, $name) = @_;
49     $test = $test + 1;
50     if ($::TODO) {
51         $name .= " # TODO: $::TODO";
52     }
53     if (defined $got && $got eq $expect) {
54         print "ok $test - $name\n";
55         return 1;
56     }
57     failed($got, "'$expect'", $name);
58 }
59
60 sub skip {
61     my ($desc) = @_;
62     $test = $test + 1;
63     print "ok $test # SKIP $desc\n";
64 }
65
66 sub no_warnings {
67     my ($desc) = @_;
68
69     if (is_miniperl) {
70         skip("warnings may not be available in miniperl");
71     }
72     else {
73         is(scalar(@warnings), 0, "No warnings with $desc");
74         print "# $warnings[0]" if $#warnings >= 0;
75     }
76     @warnings = ();
77 }
78
79 BEGIN {
80     print "1..18\n";
81     $test = 0;
82     if (!is_miniperl) {
83         require Scalar::Util;
84         require warnings;
85         warnings->import;
86     }
87 }
88
89 # Not yet implemented: Greedy
90 # Arrays (@array = ()) silences the used only once warning)
91 sub greedyarray(@array){return $#array; @array = ();}
92 BEGIN {
93     local $TODO = "Named arrays not yet implemented";
94     no_warnings("named arrays");
95     my @array = qw(1 2 3);
96     is(greedyarray(@array),2);
97     is(greedyarray(1,2,3),2);
98 }
99
100 # Hashes (%hash = ()) silences the used only once warning)
101 sub greedyhash(%hash){my @keys = sort keys %hash; return "@keys"; %hash = ();}
102 BEGIN {
103     local $TODO = "Named hashes not yet implemented";
104     no_warnings("named hashes");
105     my %hash = (c => 1, d => 2);
106     is(greedyhash(%hash),"c d");
107     is(greedyhash("c",1,"d",2),"c d");
108 }
109
110 # Checking params
111 sub onep($one){ return "$one"; }
112 is(onep("A"), "A", "Checking one param");
113
114 sub twop($one,$two){ return "$one $two"; }
115 is(twop("A","B"), "A B", "Checking two param");
116
117 sub recc($a,$c){ return recc("$a $a",$c-1) if $c; return $a; }
118 is(recc("A", 2), "A A A A", "Checking recursive");
119 no_warnings("checking params");
120
121 # Make sure whitespace doesn't matter
122 sub whitespace (  $a  ,  $b   ) { return $b; }
123 BEGIN {
124     no_warnings("extra whitespace in the definition");
125 }
126 is(whitespace(4,5),5,"Prototype ignores whitespace");
127
128
129 # Testing readonly
130 my $a = 5;
131 sub testro($a){ $a = 5; }
132 eval { testro($a); };
133 like($@,"read-only","Args should be passed read-only");
134
135 # Checking old prototype behavior
136 sub oldproto(*){ my $name = shift; return $name;}
137 is(oldproto STDOUT,"STDOUT", "Traditional prototype behavior still works");
138
139 sub manualproto($name){ return $name; }
140 BEGIN { if (!is_miniperl) { Scalar::Util::set_prototype(\&manualproto,"*") } }
141 if (is_miniperl) {
142     skip("Scalar::Util may not be available in miniperl");
143 }
144 else {
145     eval "is(manualproto STDOUT, 'STDOUT', 'Forcing it with set_prototype works'); 1" || die $@;
146 }
147
148 sub manualrecproto($name){
149     BEGIN { if (!is_miniperl) { Scalar::Util::set_prototype(\&manualrecproto,"*") } }
150     return $name;
151 }
152 BEGIN {
153     local $TODO = "Not sure how to use set_prototype for a recursive";
154     no_warnings("set_prototype on recursive function");
155 }
156
157 sub ignoredproto(*);
158 sub ignoredproto($name){ return $name;}
159 BEGIN {
160     if (is_miniperl) {
161         skip("warnings may not be available in miniperl");
162         skip("warnings may not be available in miniperl");
163     }
164     else {
165         is(scalar(@warnings), 1, "Should have exactly one warning");
166         like($warnings[0], "vs none", "ignoredproto should complain of a mismatch");
167     }
168     @warnings = ();
169 }
170
171 # Test UTF-8
172
173 1;