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, -z, -i
   5 # Some switches have their own tests, see MANIFEST.
   6
   7 BEGIN {
   8     chdir 't' if -d 't';
   9     @INC = '../lib';
  10 }
  11
  12 require "./test.pl";
  13
  14 plan(tests => 26);
  15
  16 # due to a bug in VMS's piping which makes it impossible for runperl()
  17 # to emulate echo -n (ie. stdin always winds up with a newline), these
  18 # tests almost totally fail.
  19 $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS';
  20
  21 my $r;
  22 my @tmpfiles = ();
  23 END { unlink @tmpfiles }
  24
  25 # Tests for -0
  26
  27 $r = runperl(
  28     switches    => [ '-0', ],
  29     stdin       => 'foo\0bar\0baz\0',
  30     prog        => 'print qq(<$_>) while <>',
  31 );
  32 is( $r, "<foo\0><bar\0><baz\0>", "-0" );
  33
  34 $r = runperl(
  35     switches    => [ '-l', '-0', '-p' ],
  36     stdin       => 'foo\0bar\0baz\0',
  37     prog        => '1',
  38 );
  39 is( $r, "foo\nbar\nbaz\n", "-0 after a -l" );
  40
  41 $r = runperl(
  42     switches    => [ '-0', '-l', '-p' ],
  43     stdin       => 'foo\0bar\0baz\0',
  44     prog        => '1',
  45 );
  46 is( $r, "foo\0bar\0baz\0", "-0 before a -l" );
  47
  48 $r = runperl(
  49     switches    => [ sprintf("-0%o", ord 'x') ],
  50     stdin       => 'fooxbarxbazx',
  51     prog        => 'print qq(<$_>) while <>',
  52 );
  53 is( $r, "<foox><barx><bazx>", "-0 with octal number" );
  54
  55 $r = runperl(
  56     switches    => [ '-00', '-p' ],
  57     stdin       => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
  58     prog        => 's/\n/-/g;$_.=q(/)',
  59 );
  60 is( $r, 'abc-def--/ghi-jkl-mno--/pq-/', '-00 (paragraph mode)' );
  61
  62 $r = runperl(
  63     switches    => [ '-0777', '-p' ],
  64     stdin       => 'abc\ndef\n\nghi\njkl\nmno\n\npq\n',
  65     prog        => 's/\n/-/g;$_.=q(/)',
  66 );
  67 is( $r, 'abc-def--ghi-jkl-mno--pq-/', '-0777 (slurp mode)' );
  68
  69 $r = runperl(
  70     switches    => [ '-066' ],
  71     prog        => 'BEGIN { print qq{($/)} } print qq{[$/]}',
  72 );
  73 is( $r, "(\066)[\066]", '$/ set at compile-time' );
  74
  75 # Tests for -c
  76
  77 my $filename = 'swctest.tmp';
  78 SKIP: {
  79     local $TODO = '';   # this one works on VMS
  80
  81     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
  82     print $f <<'SWTEST';
  83 BEGIN { print "block 1\n"; }
  84 CHECK { print "block 2\n"; }
  85 INIT  { print "block 3\n"; }
  86         print "block 4\n";
  87 END   { print "block 5\n"; }
  88 SWTEST
  89     close $f or die "Could not close: $!";
  90     $r = runperl(
  91         switches        => [ '-c' ],
  92         progfile        => $filename,
  93         stderr          => 1,
  94     );
  95     # Because of the stderr redirection, we can't tell reliably the order
  96     # in which the output is given
  97     ok(
  98         $r =~ /$filename syntax OK/
  99         && $r =~ /\bblock 1\b/
 100         && $r =~ /\bblock 2\b/
 101         && $r !~ /\bblock 3\b/
 102         && $r !~ /\bblock 4\b/
 103         && $r !~ /\bblock 5\b/,
 104         '-c'
 105     );
 106     push @tmpfiles, $filename;
 107 }
 108
 109 # Tests for -l
 110
 111 $r = runperl(
 112     switches    => [ sprintf("-l%o", ord 'x') ],
 113     prog        => 'print for qw/foo bar/'
 114 );
 115 is( $r, 'fooxbarx', '-l with octal number' );
 116
 117 # Tests for -s
 118
 119 $r = runperl(
 120     switches    => [ '-s' ],
 121     prog        => 'for (qw/abc def ghi/) {print defined $$_ ? $$_ : q(-)}',
 122     args        => [ '--', '-abc=2', '-def', ],
 123 );
 124 is( $r, '21-', '-s switch parsing' );
 125
 126 # Bug ID 20011106.084
 127 $filename = 'swstest.tmp';
 128 SKIP: {
 129     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!" );
 130     print $f <<'SWTEST';
 131 #!perl -sn
 132 BEGIN { print $x; exit }
 133 SWTEST
 134     close $f or die "Could not close: $!";
 135     $r = runperl(
 136         progfile    => $filename,
 137         args        => [ '-x=foo' ],
 138     );
 139     is( $r, 'foo', '-s on the shebang line' );
 140     push @tmpfiles, $filename;
 141 }
 142
 143 # Tests for -m and -M
 144
 145 $filename = 'swtest.pm';
 146 SKIP: {
 147     open my $f, ">$filename" or skip( "Can't write temp file $filename: $!",4 );
 148     print $f <<'SWTESTPM';
 149 package swtest;
 150 sub import { print map "<$_>", @_ }
 151 1;
 152 SWTESTPM
 153     close $f or die "Could not close: $!";
 154     $r = runperl(
 155         switches    => [ '-Mswtest' ],
 156         prog        => '1',
 157     );
 158     is( $r, '<swtest>', '-M' );
 159     $r = runperl(
 160         switches    => [ '-Mswtest=foo' ],
 161         prog        => '1',
 162     );
 163     is( $r, '<swtest><foo>', '-M with import parameter' );
 164     $r = runperl(
 165         switches    => [ '-mswtest' ],
 166         prog        => '1',
 167     );
 168
 169     {
 170         local $TODO = '';  # this one works on VMS
 171         is( $r, '', '-m' );
 172     }
 173     $r = runperl(
 174         switches    => [ '-mswtest=foo,bar' ],
 175         prog        => '1',
 176     );
 177     is( $r, '<swtest><foo><bar>', '-m with import parameters' );
 178     push @tmpfiles, $filename;
 179 }
 180
 181 # Tests for -V
 182
 183 {
 184     local $TODO = '';   # these ones should work on VMS
 185
 186     # basic perl -V should generate significant output.
 187     # we don't test actual format too much since it could change
 188     like( runperl( switches => ['-V'] ), qr/(\n.*){20}/,
 189           '-V generates 20+ lines' );
 190
 191     like( runperl( switches => ['-V'] ),
 192           qr/\ASummary of my perl5 .*configuration:/,
 193           '-V looks okay' );
 194
 195     # lookup a known config var
 196     chomp( $r=runperl( switches => ['-V:osname'] ) );
 197     is( $r, "osname='$^O';", 'perl -V:osname');
 198
 199     # lookup a nonexistent var
 200     chomp( $r=runperl( switches => ['-V:this_var_makes_switches_test_fail'] ) );
 201     is( $r, "this_var_makes_switches_test_fail='UNKNOWN';",
 202         'perl -V:unknown var');
 203
 204     # regexp lookup
 205     # platforms that don't like this quoting can either skip this test
 206     # or fix test.pl _quote_args
 207     $r = runperl( switches => ['"-V:i\D+size"'] );
 208     # should be unlike( $r, qr/^$|not found|UNKNOWN/ );
 209     like( $r, qr/^(?!.*(not found|UNKNOWN))./, 'perl -V:re got a result' );
 210
 211     # make sure each line we got matches the re
 212     ok( !( grep !/^i\D+size=/, split /^/, $r ), '-V:re correct' );
 213 }
 214
 215 # Tests for -v
 216
 217 {
 218     local $TODO = '';   # these ones should work on VMS
 219
 220     my $v = sprintf "%vd", $^V;
 221     use Config;
 222     like( runperl( switches => ['-v'] ),
 223           qr/This is perl, v$v built for $Config{archname}.+Copyright.+Larry Wall.+Artistic License.+GNU General Public License/s,
 224           '-v looks okay' );
 225
 226 }
 227
 228 # Tests for -h
 229
 230 {
 231     local $TODO = '';   # these ones should work on VMS
 232
 233     like( runperl( switches => ['-h'] ),
 234           qr/Usage: .+(?i:perl(\.exe)?).+switches.+programfile.+arguments/,
 235           '-h looks okay' );
 236
 237 }
 238
 239 # Tests for -z (which does not exist)
 240
 241 {
 242     local $TODO = '';   # these ones should work on VMS
 243
 244     like( runperl( switches => ['-z'], stderr => 1 ),
 245           qr/\QUnrecognized switch: -z  (-h will show valid options)./,
 246           '-z correctly unknown' );
 247
 248 }
 249
 250 # Tests for -i
 251
 252 {
 253     local $TODO = '';   # these ones should work on VMS
 254
 255     sub do_i_unlink { 1 while unlink("file", "file.bak") }
 256
 257     open(FILE, ">file") or die "$0: Failed to create 'file': $!";
 258     print FILE <<__EOF__;
 259 foo yada dada
 260 bada foo bing
 261 king kong foo
 262 __EOF__
 263     close FILE;
 264
 265     END { do_i_unlink() }
 266
 267     runperl( switches => ['-pi.bak'], prog => 's/foo/bar/', args => ['file'] );
 268
 269     open(FILE, "file") or die "$0: Failed to open 'file': $!";
 270     chomp(my @file = <FILE>);
 271     close FILE;
 272
 273     open(BAK, "file.bak") or die "$0: Failed to open 'file': $!";
 274     chomp(my @bak = <BAK>);
 275     close BAK;
 276
 277     is(join(":", @file),
 278        "bar yada dada:bada bar bing:king kong bar",
 279        "-i new file");
 280     is(join(":", @bak),
 281        "foo yada dada:bada foo bing:king kong foo",
 282        "-i backup file");
 283 }