t/run/switches.t

   1 #!./perl -w
   2
   3 # Tests for the command-line switches:
   4 # -0, -c, -l, -s, -m, -M, -V, -v, -h, -i, -E and all unknown
   5 # Some switches have their own tests, see MANIFEST.
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     @INC = '../lib';
  10     require Config; import Config;
  11 }
  12
  13 BEGIN { require "./test.pl"; }
  14
  15 plan(tests => 115);
  16
  17 use Config;
  18 use Errno qw(EACCES EISDIR);
  19 BEGIN { eval 'use POSIX qw(setlocale LC_ALL)' }
  20
  21 # due to a bug in VMS's piping which makes it impossible for runperl()
  22 # to emulate echo -n (ie. stdin always winds up with a newline), these
  23 # tests almost totally fail.
  24 $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
  25
  26 my $r;
  27 my @tmpfiles = ();
  28 END { unlink_all @tmpfiles }
  29
  30 # Tests for -0
  31
  32 $r = runperl(
  33     switches    => [ '-0', ],
  34     stdin       => 'foo\0bar\0baz\0',
  35     prog        => 'print qq(<$_>) while <>',
  36 );
  37 is( $r, "<foo\0><bar\0><baz\0>", "-0" );
  38
  39 $r = runperl(
  40     switches    => [ '-l', '-0', '-p' ],
  41     stdin       => 'foo\0bar\0baz\0',
  42     prog        => '1',
  43 );
  44 is( $r, "foo\nbar\nbaz\n", "-0 after a -l" );
  45
  46 $r = runperl(
  47     switches    => [ '-0', '-l', '-p' ],
  48     stdin       => 'foo\0bar\0baz\0',
  49     prog        => '1',
  50 );
  51 is( $r, "foo\0bar\0baz\0", "-0 before a -l" );
  52
  53 $r = runperl(
  54     switches    => [ sprintf("-0%o", ord 'x') ],
  55     stdin       => 'fooxbarxbazx',
  56     prog        => 'print qq(<$_>) while <>',
  57 );
  58 is( $r, "<foox><barx><bazx>", "-0 with octal number" );
  59
  60 $r = runperl(
  61     switches    => [ '-00', '-p' ],
  62     stdin       => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
  63     prog        => 's/\n/-/g;$_.=q(/)',
  64 );
  65 is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' );
  66
  67 $r = runperl(
  68     switches    => [ '-0777', '-p' ],
  69     stdin       => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
  70     prog        => 's/\n/-/g;$_.=q(/)',
  71 );
  72 is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' );
  73
  74 $r = runperl(
  75     switches    => [ '-066' ],
  76     prog        => 'BEGIN { print qq{($/)} } print qq{[$/]}',
  77 );
  78 is( $r, "(\066)[\066]", '$/ set at compile-time' );
  79
  80 # Tests for -c
  81
  82 my $filename = tempfile();
  83 SKIP: {
  84     local $TODO = '';   # this one works on VMS
  85
  86     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
  87     print $f <<'SWTEST';
  88 BEGIN { print "block 1\n"; }
  89 CHECK { print "block 2\n"; }
  90 INIT  { print "block 3\n"; }
  91         print "block 4\n";
  92 END   { print "block 5\n"; }
  93 SWTEST
  94     close $f or die "Could not close: $!";
  95     $r = runperl(
  96         switches        => [ '-c' ],
  97         progfile        => $filename,
  98         stderr          => 1,
  99     );
 100     # Because of the stderr redirection, we can't tell reliably the order
 101     # in which the output is given
 102     ok(
 103         $r =~ /$filename syntax OK/
 104         && $r =~ /\bblock 1\b/
 105         && $r =~ /\bblock 2\b/
 106         && $r !~ /\bblock 3\b/
 107         && $r !~ /\bblock 4\b/
 108         && $r !~ /\bblock 5\b/,
 109         '-c'
 110     );
 111 }
 112
 113 SKIP: {
 114     skip "no POSIX on miniperl", 1, unless $INC{"POSIX.pm"};
 115     skip 'No locale testing without d_setlocale', 1 if(!$Config{d_setlocale});
 116
 117     my $tempdir = tempfile;
 118     mkdir $tempdir, 0700 or die "Can't mkdir '$tempdir': $!";
 119
 120     local $ENV{'LC_ALL'} = 'C'; # Keep the test simple: expect English
 121     local $ENV{LANGUAGE} = 'C';
 122     setlocale(LC_ALL, "C");
 123
 124     # Win32 won't let us open the directory, so we never get to die with
 125     # EISDIR, which happens after open.
 126     my $error  = do { local $! = $^O eq 'MSWin32' ? EACCES : EISDIR; "$!" };
 127     like(
 128         runperl( switches => [ '-c' ], args  => [ $tempdir ], stderr => 1),
 129         qr/Can't open perl script.*$tempdir.*\Q$error/s,
 130         "RT \#61362: Cannot syntax-check a directory"
 131     );
 132     rmdir $tempdir or die "Can't rmdir '$tempdir': $!";
 133 }
 134
 135 # Tests for -l
 136
 137 $r = runperl(
 138     switches    => [ sprintf("-l%o", ord 'x') ],
 139     prog        => 'print for qw/foo bar/'
 140 );
 141 is( $r, 'fooxbarx', '-l with octal number' );
 142
 143 # Tests for -s
 144
 145 $r = runperl(
 146     switches    => [ '-s' ],
 147     prog        => 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}',
 148     args        => [ '--', '-abc=2', '-def', ],
 149 );
 150 is( $r, '21-', '-s switch parsing' );
 151
 152 $filename = tempfile();
 153 SKIP: {
 154     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
 155     print $f <<'SWTEST';
 156 #!perl -s
 157 BEGIN { print $x,$y; exit }
 158 SWTEST
 159     close $f or die "Could not close: $!";
 160     $r = runperl(
 161         progfile    => $filename,
 162         args        => [ '-x=foo -y' ],
 163     );
 164     is( $r, 'foo1', '-s on the shebang line' );
 165 }
 166
 167 # Bug ID 20011106.084
 168 $filename = tempfile();
 169 SKIP: {
 170     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
 171     print $f <<'SWTEST';
 172 #!perl -sn
 173 BEGIN { print $x; exit }
 174 SWTEST
 175     close $f or die "Could not close: $!";
 176     $r = runperl(
 177         progfile    => $filename,
 178         args        => [ '-x=foo' ],
 179     );
 180     is( $r, 'foo', '-sn on the shebang line' );
 181 }
 182
 183 # Tests for -m and -M
 184
 185 my $package = tempfile();
 186 $filename = "$package.pm";
 187 SKIP: {
 188     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 );
 189     print $f <<"SWTESTPM";
 190 package $package;
 191 sub import { print map "<\$_>", \@_ }
 192 1;
 193 SWTESTPM
 194     close $f or die "Could not close: $!";
 195     $r = runperl(
 196         switches    => [ "-M$package" ],
 197         prog        => '1',
 198     );
 199     is( $r, "<$package>", '-M' );
 200     $r = runperl(
 201         switches    => [ "-M$package=foo" ],
 202         prog        => '1',
 203     );
 204     is( $r, "<$package><foo>", '-M with import parameter' );
 205     $r = runperl(
 206         switches    => [ "-m$package" ],
 207         prog        => '1',
 208     );
 209
 210     {
 211         local $TODO = '';  # this one works on VMS
 212         is( $r, '', '-m' );
 213     }
 214     $r = runperl(
 215         switches    => [ "-m$package=foo,bar" ],
 216         prog        => '1',
 217     );
 218     is( $r, "<$package><foo><bar>", '-m with import parameters' );
 219     push @tmpfiles, $filename;
 220
 221   {
 222     local $TODO = '';  # these work on VMS
 223
 224     is( runperl( switches => [ '-MTie::Hash' ], stderr => 1, prog => 1 ),
 225           '', "-MFoo::Bar allowed" );
 226
 227     like( runperl( switches => [ "-M:$package" ], stderr => 1,
 228                    prog => 'die q{oops}' ),
 229           qr/Invalid module name [\w:]+ with -M option\b/,
 230           "-M:Foo not allowed" );
 231
 232     like( runperl( switches => [ '-mA:B:C' ], stderr => 1,
 233                    prog => 'die q{oops}' ),
 234           qr/Invalid module name [\w:]+ with -m option\b/,
 235           "-mFoo:Bar not allowed" );
 236
 237     like( runperl( switches => [ '-m-A:B:C' ], stderr => 1,
 238                    prog => 'die q{oops}' ),
 239           qr/Invalid module name [\w:]+ with -m option\b/,
 240           "-m-Foo:Bar not allowed" );
 241
 242     like( runperl( switches => [ '-m-' ], stderr => 1,
 243                    prog => 'die q{oops}' ),
 244           qr/Module name required with -m option\b/,
 245           "-m- not allowed" );
 246
 247     like( runperl( switches => [ '-M-=' ], stderr => 1,
 248                    prog => 'die q{oops}' ),
 249           qr/Module name required with -M option\b/,
 250           "-M- not allowed" );
 251   }  # disable TODO on VMS
 252 }
 253 is runperl(stderr => 1, prog => '#!perl -m'),
 254    qq 'Too late for "-m" option at -e line 1.\n', '#!perl -m';
 255 is runperl(stderr => 1, prog => '#!perl -M'),
 256    qq 'Too late for "-M" option at -e line 1.\n', '#!perl -M';
 257
 258 # Tests for -V
 259
 260 {
 261     local $TODO = '';   # these ones should work on VMS
 262
 263     # basic perl -V should generate significant output.
 264     # we don't test actual format too much since it could change
 265     like( runperl( switches => ['-V'] ), qr/(\n.*){20}/,
 266           '-V generates 20+ lines' );
 267
 268     like( runperl( switches => ['-V'] ),
 269           qr/\ASummary of my perl5 .*configuration:/,
 270           '-V looks okay' );
 271
 272     # lookup a known config var
 273     chomp( $r=runperl( switches => ['-V:osname'] ) );
 274     is( $r, "osname='$^O';", 'perl -V:osname');
 275
 276     # lookup a nonexistent var
 277     chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) );
 278     is( $r, "this_var_makes_switches_test_fail='UNKNOWN';",
 279         'perl -V:unknown var');
 280
 281     # regexp lookup
 282     # platforms that don't like this quoting can either skip this test
 283     # or fix test.pl _quote_args
 284     $r = runperl( switches => ['"-V:i\D+size"'] );
 285     # should be unlike( $r, qr/^$|not found|UNKNOWN/ );
 286     like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' );
 287
 288     # make sure each line we got matches the re
 289     ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' );
 290 }
 291
 292 # Tests for -v
 293
 294 {
 295     local $TODO = '';   # these ones should work on VMS
 296     # there are definitely known build configs where this test will fail
 297     # DG/UX comes to mind. Maybe we should remove these special cases?
 298     my $v = sprintf "%vd", $^V;
 299     my $ver = $Config{PERL_VERSION};
 300     my $rel = $Config{PERL_SUBVERSION};
 301     like( runperl( switches => ['-v'] ),
 302           qr/This is perl 5, version \Q$ver\E, subversion \Q$rel\E \(v\Q$v\E(?:[-*\w]+| \([^)]+\))?\) built for \Q$Config{archname}\E.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s,
 303           '-v looks okay' );
 304
 305 }
 306
 307 # Tests for -h
 308
 309 {
 310     local $TODO = '';   # these ones should work on VMS
 311
 312     like( runperl( switches => ['-h'] ),
 313           qr/Usage: .+(?i:perl(?:$Config{_exe})?).+switches.+programfile.+arguments/,
 314           '-h looks okay' );
 315
 316 }
 317
 318 # Tests for switches which do not exist
 319
 320 foreach my $switch (split //, "ABbGgHJjKkLNOoPQqRrYyZz123456789_")
 321 {
 322     local $TODO = '';   # these ones should work on VMS
 323
 324     like( runperl( switches => ["-$switch"], stderr => 1,
 325                    prog => 'die q{oops}' ),
 326           qr/\QUnrecognized switch: -$switch  (-h will show valid options)./,
 327           "-$switch correctly unknown" );
 328
 329     # [perl #104288]
 330     like( runperl( stderr => 1, prog => "#!perl -$switch" ),
 331           qr/^Unrecognized switch: -$switch  \(-h will show valid (?x:
 332              )options\) at -e line 1\./,
 333           "-$switch unrecognised on #! line" );
 334 }
 335
 336 # Tests for unshebangable switches
 337 for (qw( e f x E S V )) {
 338     $r = runperl(
 339         stderr   => 1,
 340         prog     => "#!perl -$_",
 341     );
 342     is $r, "Can't emulate -$_ on #! line at -e line 1.\n","-$_ on #! line";
 343 }
 344
 345 # Tests for -i
 346
 347 {
 348     local $TODO = '';   # these ones should work on VMS
 349
 350     sub do_i_unlink { unlink_all("file", "file.bak") }
 351
 352     open(FILE, ">file") or die "$0: Failed to create 'file': $!";
 353     print FILE <<__EOF__;
 354 foo yada dada
 355 bada foo bing
 356 king kong foo
 357 __EOF__
 358     close FILE;
 359
 360     END { do_i_unlink() }
 361
 362     runperl( switches => ['-pi.bak'], prog => 's/foo/bar/', args => ['file'] );
 363
 364     open(FILE, "file") or die "$0: Failed to open 'file': $!";
 365     chomp(my @file = <FILE>);
 366     close FILE;
 367
 368     open(BAK, "file.bak") or die "$0: Failed to open 'file': $!";
 369     chomp(my @bak = <BAK>);
 370     close BAK;
 371
 372     is(join(":", @file),
 373        "bar yada dada:bada bar bing:king kong bar",
 374        "-i new file");
 375     is(join(":", @bak),
 376        "foo yada dada:bada foo bing:king kong foo",
 377        "-i backup file");
 378
 379     my $out1 = runperl(
 380         switches => ['-i.bak -p'],
 381         prog     => 'exit',
 382         stderr   => 1,
 383         stdin    => "1\n",
 384     );
 385     is(
 386         $out1,
 387         "-i used with no filenames on the command line, reading from STDIN.\n",
 388         "warning when no files given"
 389     );
 390     my $out2 = runperl(
 391         switches => ['-i.bak -p'],
 392         prog     => 'exit',
 393         stderr   => 1,
 394         stdin    => "1\n",
 395         args     => ['file'],
 396     );
 397     is($out2, "", "no warning when files given");
 398 }
 399
 400 # Tests for -E
 401
 402 $TODO = '';  # the -E tests work on VMS
 403
 404 $r = runperl(
 405     switches    => [ '-E', '"say q(Hello, world!)"']
 406 );
 407 is( $r, "Hello, world!\n", "-E say" );
 408
 409
 410 $r = runperl(
 411     switches    => [ '-E', '"no warnings q{experimental::smartmatch}; undef ~~ undef and say q(Hello, world!)"']
 412 );
 413 is( $r, "Hello, world!\n", "-E ~~" );
 414
 415 $r = runperl(
 416     switches    => [ '-E', '"no warnings q{experimental::smartmatch}; given(undef) {when(undef) { say q(Hello, world!)"}}']
 417 );
 418 is( $r, "Hello, world!\n", "-E given" );
 419
 420 $r = runperl(
 421     switches    => [ '-nE', q("} END { say q/affe/") ],
 422     stdin       => 'zomtek',
 423 );
 424 is( $r, "affe\n", '-E works outside of the block created by -n' );
 425
 426 $r = runperl(
 427     switches    => [ '-E', q("*{'bar'} = sub{}; print 'Hello, world!',qq|\n|;")]
 428 );
 429 is( $r, "Hello, world!\n", "-E does not enable strictures" );
 430
 431 # RT #30660
 432
 433 $filename = tempfile();
 434 SKIP: {
 435     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
 436     print $f <<'SWTEST';
 437 #!perl -w    -iok
 438 print "$^I\n";
 439 SWTEST
 440     close $f or die "Could not close: $!";
 441     $r = runperl(
 442         progfile    => $filename,
 443     );
 444     like( $r, qr/ok/, 'Spaces on the #! line (#30660)' );
 445 }