| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = ('../lib', 'lib'); |
| 6 | $INC{"feature.pm"} = 1; # so we don't attempt to load feature.pm |
| 7 | } |
| 8 | |
| 9 | print "1..83\n"; |
| 10 | |
| 11 | # Can't require test.pl, as we're testing the use/require mechanism here. |
| 12 | |
| 13 | my $test = 1; |
| 14 | |
| 15 | sub _ok { |
| 16 | my ($type, $got, $expected, $name) = @_; |
| 17 | |
| 18 | my $result; |
| 19 | if ($type eq 'is') { |
| 20 | $result = $got eq $expected; |
| 21 | } elsif ($type eq 'isnt') { |
| 22 | $result = $got ne $expected; |
| 23 | } elsif ($type eq 'like') { |
| 24 | $result = $got =~ $expected; |
| 25 | } elsif ($type eq 'ok') { |
| 26 | $result = not not $got; |
| 27 | } else { |
| 28 | die "Unexpected type '$type'$name"; |
| 29 | } |
| 30 | if ($result) { |
| 31 | if ($name) { |
| 32 | print "ok $test - $name\n"; |
| 33 | } else { |
| 34 | print "ok $test\n"; |
| 35 | } |
| 36 | } else { |
| 37 | if ($name) { |
| 38 | print "not ok $test - $name\n"; |
| 39 | } else { |
| 40 | print "not ok $test\n"; |
| 41 | } |
| 42 | my @caller = caller(1); |
| 43 | print "# Failed test at $caller[1] line $caller[2]\n"; |
| 44 | print "# Got '$got'\n"; |
| 45 | if ($type eq 'is') { |
| 46 | print "# Expected '$expected'\n"; |
| 47 | } elsif ($type eq 'isnt') { |
| 48 | print "# Expected not '$expected'\n"; |
| 49 | } elsif ($type eq 'like') { |
| 50 | print "# Expected $expected\n"; |
| 51 | } elsif ($type eq 'ok') { |
| 52 | print "# Expected a true value\n"; |
| 53 | } |
| 54 | } |
| 55 | $test = $test + 1; |
| 56 | $result; |
| 57 | } |
| 58 | |
| 59 | sub like ($$;$) { |
| 60 | _ok ('like', @_); |
| 61 | } |
| 62 | sub is ($$;$) { |
| 63 | _ok ('is', @_); |
| 64 | } |
| 65 | sub isnt ($$;$) { |
| 66 | _ok ('isnt', @_); |
| 67 | } |
| 68 | sub ok($;$) { |
| 69 | _ok ('ok', shift, undef, @_); |
| 70 | } |
| 71 | |
| 72 | eval "use 5"; # implicit semicolon |
| 73 | is ($@, ''); |
| 74 | |
| 75 | eval "use 5;"; |
| 76 | is ($@, ''); |
| 77 | |
| 78 | eval "{use 5}"; # [perl #70884] |
| 79 | is ($@, ''); |
| 80 | |
| 81 | eval "{use 5 }"; # [perl #70884] |
| 82 | is ($@, ''); |
| 83 | |
| 84 | # new style version numbers |
| 85 | |
| 86 | eval q{ use v5.5.630; }; |
| 87 | is ($@, ''); |
| 88 | |
| 89 | eval q{ use 10.0.2; }; |
| 90 | like ($@, qr/^Perl v10\.0\.2 required/); |
| 91 | |
| 92 | eval "use 5.000"; # implicit semicolon |
| 93 | is ($@, ''); |
| 94 | |
| 95 | eval "use 5.000;"; |
| 96 | is ($@, ''); |
| 97 | |
| 98 | eval "use 6.000;"; |
| 99 | like ($@, qr/Perl v6\.0\.0 required--this is only \Q$^V\E, stopped/); |
| 100 | |
| 101 | eval "no 6.000;"; |
| 102 | is ($@, ''); |
| 103 | |
| 104 | eval "no 5.000;"; |
| 105 | like ($@, qr/Perls since v5\.0\.0 too modern--this is \Q$^V\E, stopped/); |
| 106 | |
| 107 | eval "use 5.6;"; |
| 108 | like ($@, qr/Perl v5\.600\.0 required \(did you mean v5\.6\.0\?\)--this is only \Q$^V\E, stopped/); |
| 109 | |
| 110 | eval "use 5.8;"; |
| 111 | like ($@, qr/Perl v5\.800\.0 required \(did you mean v5\.8\.0\?\)--this is only \Q$^V\E, stopped/); |
| 112 | |
| 113 | eval "use 5.9;"; |
| 114 | like ($@, qr/Perl v5\.900\.0 required \(did you mean v5\.9\.0\?\)--this is only \Q$^V\E, stopped/); |
| 115 | |
| 116 | eval "use 5.10;"; |
| 117 | like ($@, qr/Perl v5\.100\.0 required \(did you mean v5\.10\.0\?\)--this is only \Q$^V\E, stopped/); |
| 118 | |
| 119 | eval "use 5.11;"; |
| 120 | like ($@, qr/Perl v5\.110\.0 required \(did you mean v5\.11\.0\?\)--this is only \Q$^V\E, stopped/); |
| 121 | |
| 122 | eval sprintf "use %.6f;", $]; |
| 123 | is ($@, ''); |
| 124 | |
| 125 | |
| 126 | eval sprintf "use %.6f;", $] - 0.000001; |
| 127 | is ($@, ''); |
| 128 | |
| 129 | eval sprintf("use %.6f;", $] + 1); |
| 130 | like ($@, qr/Perl v6.\d+.\d+ required--this is only \Q$^V\E, stopped/); |
| 131 | |
| 132 | eval sprintf "use %.6f;", $] + 0.00001; |
| 133 | like ($@, qr/Perl v5.\d+.\d+ required--this is only \Q$^V\E, stopped/); |
| 134 | |
| 135 | # check that "use 5.11.0" (and higher) loads strictures |
| 136 | eval 'use 5.11.0; ${"foo"} = "bar";'; |
| 137 | like ($@, qr/Can't use string \("foo"\) as a SCALAR ref while "strict refs" in use/); |
| 138 | # but that they can be disabled |
| 139 | eval 'use 5.11.0; no strict "refs"; ${"foo"} = "bar";'; |
| 140 | is ($@, ""); |
| 141 | # and they are properly scoped |
| 142 | eval '{use 5.11.0;} ${"foo"} = "bar";'; |
| 143 | is ($@, ""); |
| 144 | eval 'no strict; use 5.012; ${"foo"} = "bar"'; |
| 145 | is $@, "", 'explicit "no strict" overrides later ver decl'; |
| 146 | eval 'use strict; use 5.01; ${"foo"} = "bar"'; |
| 147 | like $@, qr/^Can't use string/, |
| 148 | 'explicit use strict overrides later use 5.01'; |
| 149 | eval 'use strict "subs"; use 5.012; ${"foo"} = "bar"'; |
| 150 | like $@, qr/^Can't use string/, |
| 151 | 'explicit use strict "subs" does not stop ver decl from enabling refs'; |
| 152 | eval 'use 5.012; use 5.01; ${"foo"} = "bar"'; |
| 153 | is $@, "", 'use 5.01 overrides implicit strict from prev ver decl'; |
| 154 | eval 'no strict "subs"; use 5.012; ${"foo"} = "bar"'; |
| 155 | ok $@, 'no strict subs allows ver decl to enable refs'; |
| 156 | eval 'no strict "subs"; use 5.012; $nonexistent_pack_var'; |
| 157 | ok $@, 'no strict subs allows ver decl to enable vars'; |
| 158 | eval 'no strict "refs"; use 5.012; fancy_bareword'; |
| 159 | ok $@, 'no strict refs allows ver decl to enable subs'; |
| 160 | eval 'no strict "refs"; use 5.012; $nonexistent_pack_var'; |
| 161 | ok $@, 'no strict refs allows ver decl to enable subs'; |
| 162 | eval 'no strict "vars"; use 5.012; ${"foo"} = "bar"'; |
| 163 | ok $@, 'no strict vars allows ver decl to enable refs'; |
| 164 | eval 'no strict "vars"; use 5.012; ursine_word'; |
| 165 | ok $@, 'no strict vars allows ver decl to enable subs'; |
| 166 | |
| 167 | |
| 168 | { use test_use } # check that subparse saves pending tokens |
| 169 | |
| 170 | local $test_use::VERSION = 1.0; |
| 171 | |
| 172 | eval "use test_use 0.9"; |
| 173 | is ($@, ''); |
| 174 | |
| 175 | eval "use test_use 1.0"; |
| 176 | is ($@, ''); |
| 177 | |
| 178 | eval "use test_use 1.01"; |
| 179 | isnt ($@, ''); |
| 180 | |
| 181 | eval "use test_use 0.9 qw(fred)"; |
| 182 | is ($@, ''); |
| 183 | |
| 184 | is("@test_use::got", "fred"); |
| 185 | |
| 186 | eval "use test_use 1.0 qw(joe)"; |
| 187 | is ($@, ''); |
| 188 | |
| 189 | is("@test_use::got", "joe"); |
| 190 | |
| 191 | eval "use test_use 1.01 qw(freda)"; |
| 192 | isnt($@, ''); |
| 193 | |
| 194 | is("@test_use::got", "joe"); |
| 195 | |
| 196 | { |
| 197 | local $test_use::VERSION = 35.36; |
| 198 | eval "use test_use v33.55"; |
| 199 | is ($@, ''); |
| 200 | |
| 201 | eval "use test_use v100.105"; |
| 202 | like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); |
| 203 | |
| 204 | eval "use test_use 33.55"; |
| 205 | is ($@, ''); |
| 206 | |
| 207 | eval "use test_use 100.105"; |
| 208 | like ($@, qr/test_use version 100.105 required--this is only version 35.36/); |
| 209 | |
| 210 | local $test_use::VERSION = '35.36'; |
| 211 | eval "use test_use v33.55"; |
| 212 | like ($@, ''); |
| 213 | |
| 214 | eval "use test_use v100.105"; |
| 215 | like ($@, qr/test_use version v100.105.0 required--this is only version v35\.360\.0/); |
| 216 | |
| 217 | eval "use test_use 33.55"; |
| 218 | is ($@, ''); |
| 219 | |
| 220 | eval "use test_use 100.105"; |
| 221 | like ($@, qr/test_use version 100.105 required--this is only version 35.36/); |
| 222 | |
| 223 | local $test_use::VERSION = v35.36; |
| 224 | eval "use test_use v33.55"; |
| 225 | is ($@, ''); |
| 226 | |
| 227 | eval "use test_use v100.105"; |
| 228 | like ($@, qr/test_use version v100.105.0 required--this is only version v35\.36\.0/); |
| 229 | |
| 230 | eval "use test_use 33.55"; |
| 231 | is ($@, ''); |
| 232 | |
| 233 | eval "use test_use 100.105"; |
| 234 | like ($@, qr/test_use version 100.105 required--this is only version v35.36/); |
| 235 | } |
| 236 | |
| 237 | |
| 238 | { |
| 239 | # Regression test for patch 14937: |
| 240 | # Check that a .pm file with no package or VERSION doesn't core. |
| 241 | # (git commit 2658f4d9934aba5f8b23afcc078dc12b3a40223) |
| 242 | eval "use test_use_14937 3"; |
| 243 | like ($@, qr/^test_use_14937 defines neither package nor VERSION--version check failed at/); |
| 244 | } |
| 245 | |
| 246 | my @ver = split /\./, sprintf "%vd", $^V; |
| 247 | |
| 248 | foreach my $index (-3..+3) { |
| 249 | foreach my $v (0, 1) { |
| 250 | my @parts = @ver; |
| 251 | if ($index) { |
| 252 | if ($index < 0) { |
| 253 | # Jiggle one of the parts down |
| 254 | --$parts[-$index - 1]; |
| 255 | if ($parts[-$index - 1] < 0) { |
| 256 | # perl's version number ends with '.0' |
| 257 | $parts[-$index - 1] = 0; |
| 258 | $parts[-$index - 2] -= 2; |
| 259 | } |
| 260 | } else { |
| 261 | # Jiggle one of the parts up |
| 262 | ++$parts[$index - 1]; |
| 263 | } |
| 264 | } |
| 265 | my $v_version = sprintf "v%d.%d.%d", @parts; |
| 266 | my $version; |
| 267 | if ($v) { |
| 268 | $version = $v_version; |
| 269 | } else { |
| 270 | $version = $parts[0] + $parts[1] / 1000 + $parts[2] / 1000000; |
| 271 | } |
| 272 | |
| 273 | eval "use $version"; |
| 274 | if ($index > 0) { |
| 275 | # The future |
| 276 | like ($@, |
| 277 | qr/Perl $v_version required--this is only \Q$^V\E, stopped/, |
| 278 | "use $version"); |
| 279 | } else { |
| 280 | # The present or past |
| 281 | is ($@, '', "use $version"); |
| 282 | } |
| 283 | |
| 284 | eval "no $version"; |
| 285 | if ($index <= 0) { |
| 286 | # The present or past |
| 287 | like ($@, |
| 288 | qr/Perls since $v_version too modern--this is \Q$^V\E, stopped/, |
| 289 | "no $version"); |
| 290 | } else { |
| 291 | # future |
| 292 | is ($@, '', "no $version"); |
| 293 | } |
| 294 | } |
| 295 | } |
| 296 | |