t/pmc/os.t

   1 #! perl
   2 # Copyright (C) 2001-2009, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8 use Test::More;
   9 use Parrot::Test tests => 16;
  10 use Parrot::Config;
  11 use Cwd;
  12 use File::Spec;
  13
  14 my $MSWin32 = $^O =~ m!MSWin32!;
  15 my $cygwin  = $^O =~ m!cygwin!;
  16 my $solaris = $^O =~ m!solaris!;
  17 my $MSVC = $PConfig{cc} =~ m/\bcl(?:\.exe)?/i;
  18
  19 =head1 NAME
  20
  21 t/pmc/os.t - Files and Dirs
  22
  23 =head1 SYNOPSIS
  24
  25     % prove t/pmc/os.t
  26
  27 =head1 DESCRIPTION
  28
  29 Tests the C<OS> PMC.
  30
  31 =cut
  32
  33 END {
  34     # Clean up environment on exit
  35     rmdir "xpto"  if -d "xpto";
  36     unlink "xpto" if -f "xpto";
  37 }
  38
  39 # test 'cwd'
  40 my $cwd = File::Spec->canonpath(getcwd);
  41 if (File::Spec->case_tolerant(substr($cwd,0,2))) {
  42     $cwd = lc($cwd);
  43     pir_output_is( <<'CODE', <<"OUT", 'Test cwd' );
  44 .sub main :main
  45         $P1 = new ['OS']
  46         $S1 = $P1."cwd"()
  47         $S2 = downcase $S1
  48         print $S2
  49         print "\n"
  50         end
  51 .end
  52 CODE
  53 $cwd
  54 OUT
  55 }
  56 else {
  57     pir_output_is( <<'CODE', <<"OUT", 'Test cwd' );
  58 .sub main :main
  59         $P1 = new ['OS']
  60         $S1 = $P1."cwd"()
  61         print $S1
  62         print "\n"
  63         end
  64 .end
  65 CODE
  66 $cwd
  67 OUT
  68 }
  69
  70 #  TEST chdir
  71 chdir "src";
  72 my $upcwd = File::Spec->canonpath(getcwd);
  73 chdir '..';
  74
  75 if (File::Spec->case_tolerant(substr($cwd,0,2))) {
  76     $cwd = lc($cwd);
  77     $upcwd = lc($upcwd);
  78
  79     pir_output_is( <<'CODE', <<"OUT", 'Test chdir' );
  80 .sub main :main
  81         $P1 = new ['OS']
  82
  83         $S1 = "src"
  84         $P1."chdir"($S1)
  85
  86         $S1 = $P1."cwd"()
  87         $S2 = downcase $S1
  88         say $S2
  89
  90         $S1 = ".."
  91         $P1."chdir"($S1)
  92
  93         $S1 = $P1."cwd"()
  94         $S2 = downcase $S1
  95         say $S2
  96
  97         end
  98 .end
  99 CODE
 100 $upcwd
 101 $cwd
 102 OUT
 103 }
 104 else {
 105     pir_output_is( <<'CODE', <<"OUT", 'Test chdir' );
 106 .sub main :main
 107         $P1 = new ['OS']
 108
 109         $S1 = "src"
 110         $P1."chdir"($S1)
 111
 112         $S1 = $P1."cwd"()
 113         say $S1
 114
 115         $S1 = ".."
 116         $P1."chdir"($S1)
 117
 118         $S1 = $P1."cwd"()
 119         say $S1
 120
 121         end
 122 .end
 123 CODE
 124 $upcwd
 125 $cwd
 126 OUT
 127 }
 128
 129 # Test mkdir
 130
 131 my $xpto = $upcwd;
 132 $xpto =~ s/src([\/\\]?)$/xpto$1/;
 133
 134 if (File::Spec->case_tolerant(substr($cwd,0,2))) {
 135
 136     pir_output_is( <<'CODE', <<"OUT", 'Test mkdir' );
 137 .sub main :main
 138         $P1 = new ['OS']
 139
 140         $S1 = "xpto"
 141         $I1 = 0o555
 142         $P1."mkdir"($S1,$I1)
 143         $P1."chdir"($S1)
 144
 145         $S1 = $P1."cwd"()
 146         $S2 = downcase $S1
 147         say $S2
 148
 149         $S1 = ".."
 150         $P1."chdir"($S1)
 151
 152         $S1 = $P1."cwd"()
 153         $S2 = downcase $S1
 154         say $S2
 155
 156         end
 157 .end
 158 CODE
 159 $xpto
 160 $cwd
 161 OUT
 162 }
 163 else {
 164     pir_output_is( <<'CODE', <<"OUT", 'Test mkdir' );
 165 .sub main :main
 166         $P1 = new ['OS']
 167
 168         $S1 = "xpto"
 169         $I1 = 0o555
 170         $P1."mkdir"($S1,$I1)
 171         $P1."chdir"($S1)
 172
 173         $S1 = $P1."cwd"()
 174         say $S1
 175
 176         $S1 = ".."
 177         $P1."chdir"($S1)
 178
 179         $S1 = $P1."cwd"()
 180         say $S1
 181
 182         end
 183 .end
 184 CODE
 185 $xpto
 186 $cwd
 187 OUT
 188 }
 189
 190 # Test remove on a directory
 191 mkdir "xpto" unless -d "xpto";
 192
 193 pir_output_is( <<'CODE', <<'OUT', 'Test rm call in a directory' );
 194 .sub main :main
 195         $P1 = new ['OS']
 196
 197         $S1 = "xpto"
 198         $P1."rm"($S1)
 199
 200         print "ok\n"
 201
 202         end
 203 .end
 204 CODE
 205 ok
 206 OUT
 207
 208 ok( !-d $xpto, "Test that rm removed the directory" );
 209 rmdir $xpto if -d $xpto;    # this way next test doesn't fail if this one does
 210
 211 # test stat
 212
 213 open my $X, '>', "xpto";
 214 print $X "xpto";
 215 close $X;
 216
 217 my $stat;
 218
 219 my $count = $MSWin32 ? 11 : 13;
 220 my @s = stat('xpto');
 221 if ( $cygwin ) {
 222     # Mask inode number (fudge it)
 223     $s[1] &= 0xffffffff;
 224 }
 225
 226 if ( $MSWin32 ) {
 227     $stat = sprintf("0x%08x\n" x 11, @s);
 228     pir_output_is( <<'CODE', $stat, 'Test OS.stat' );
 229 .sub main :main
 230         $P1 = new ['OS']
 231         $S1 = "xpto"
 232         $P2 = $P1."stat"($S1)
 233
 234         $S1 = repeat "0x%08x\n", 11
 235         $S2 = sprintf $S1, $P2
 236         print $S2
 237 done:
 238         end
 239 .end
 240 CODE
 241 } else {
 242   SKIP: {
 243     skip 'broken test TT #457', 1 if $solaris;
 244
 245     $stat = sprintf("0x%08x\n" x 13, @s);
 246     pir_output_is( <<'CODE', $stat, 'Test OS.stat' );
 247 .sub main :main
 248         $P1 = new ['OS']
 249         $S1 = "xpto"
 250         $P2 = $P1."stat"($S1)
 251
 252         $S1 = repeat "0x%08x\n", 13
 253         $S2 = sprintf $S1, $P2
 254         print $S2
 255 done:
 256         end
 257 .end
 258 CODE
 259 }
 260 }
 261
 262 # test readdir
 263 SKIP: {
 264     skip 'not implemented on windows yet', 1 if ( $MSWin32 && $MSVC );
 265
 266     opendir my $IN, 'docs';
 267     my @entries = readdir $IN;
 268     closedir $IN;
 269     my $entries = join( ' ', @entries ) . "\n";
 270     pir_output_is( <<'CODE', $entries, 'Test OS.readdir' );
 271 .sub main :main
 272     $P1 = new ['OS']
 273     $P2 = $P1.'readdir'('docs')
 274
 275     $S0 = join ' ', $P2
 276     print $S0
 277     print "\n"
 278 .end
 279 CODE
 280 }
 281
 282 # test rename
 283 SKIP: {
 284     open my $FILE, ">", "____some_test_file";
 285     close $FILE;
 286     pir_output_is( <<'CODE', <<"OUT", 'Test OS.rename' );
 287 .sub main :main
 288     $P1 = new ['OS']
 289     $P1.'rename'('____some_test_file', '___some_other_file')
 290     $I0 = stat '___some_other_file', 0
 291     print $I0
 292     print "\n"
 293     $P1.'rm'('___some_other_file')
 294 .end
 295 CODE
 296 1
 297 OUT
 298 }
 299
 300 # test lstat
 301
 302 my $lstat;
 303
 304 SKIP: {
 305     skip 'lstat not on Win32', 1 if $MSWin32;
 306     skip 'broken test TT #457', 1 if $solaris;
 307
 308     my @s = lstat('xpto');
 309     if ($cygwin) {
 310         # Mask inode number (fudge it)
 311         $s[1] &= 0xffffffff;
 312     }
 313     $lstat = sprintf( "0x%08x\n" x 13, @s );
 314     pir_output_is( <<'CODE', $lstat, "Test OS.lstat" );
 315 .sub main :main
 316         $P1 = new ['OS']
 317         $S1 = "xpto"
 318         $P2 = $P1."lstat"($S1)
 319
 320         $S1 = repeat "0x%08x\n", 13
 321         $S2 = sprintf $S1, $P2
 322         print $S2
 323
 324         end
 325 .end
 326 CODE
 327 }
 328
 329 # Test remove on a file
 330 pir_output_is( <<'CODE', <<"OUT", "Test rm call in a file" );
 331 .sub main :main
 332         $P1 = new ['OS']
 333
 334         $S1 = "xpto"
 335         $P1."rm"($S1)
 336
 337         print "ok\n"
 338
 339         end
 340 .end
 341 CODE
 342 ok
 343 OUT
 344
 345 ok( !-f $xpto, "Test that rm removed file" );
 346 rmdir $xpto if -f $xpto;    # this way next test doesn't fail if this one does
 347
 348 # Test symlink
 349 SKIP: {
 350     skip "Symlinks not available under Windows", 2 if $MSWin32;
 351
 352     pir_output_is( <<'CODE', <<"OUT", "Test symlink" );
 353 .sub main :main
 354         $P1 = new ['OS']
 355
 356         $S1 = "xpto"
 357         $S2 = "MANIFEST"
 358         $P1."symlink"($S2, $S1)
 359
 360         print "ok\n"
 361
 362         end
 363 .end
 364 CODE
 365 ok
 366 OUT
 367
 368     ok( -l "xpto", "symlink was really created" );
 369     unlink "xpto" if -f "xpto";
 370 }
 371
 372 # Test link to file. May require root permissions
 373 SKIP: {
 374     skip "Hardlinks to files not possible on Windows", 2 if $MSWin32 or $cygwin;
 375
 376     pir_output_is( <<'CODE', <<"OUT", "Test link" );
 377 .sub main :main
 378         $P1 = new ['OS']
 379
 380         $S1 = "xpto"
 381         $S2 = "myconfig"
 382         $P1."link"($S2, $S1)
 383
 384         print "ok\n"
 385
 386         end
 387 .end
 388 CODE
 389 ok
 390 OUT
 391
 392     my $nl = [ stat("myconfig") ]->[3];
 393     ok( $nl > 1, "hard link to file was really created" );
 394     unlink "xpto" if -f "xpto";
 395 }
 396
 397 SKIP: {
 398     skip "Hardlinks to files not possible on Windows", 1 if $MSWin32 or $cygwin;
 399
 400     my $prevnl = [ stat("tools") ]->[3];
 401     pir_output_like( <<"CODE", <<"OUT", "Test dirlink" );
 402 .sub main :main
 403     .local pmc os
 404     .local string xpto, tools
 405     os    = new ['OS']
 406     xpto  = "xpto"
 407     tools = "tools"
 408
 409     push_eh no_root_perms
 410     os."link"(tools, xpto)
 411     pop_eh
 412
 413     .local pmc statvals
 414     statvals = os.'stat'(tools)
 415
 416     # nlink
 417     .local int nlink
 418     nlink = statvals[3]
 419
 420     gt nlink, $prevnl, is_okay
 421     end
 422
 423   no_root_perms:
 424     .local pmc e
 425     .local string message
 426     .get_results( e )
 427     pop_eh
 428     message = e['message']
 429     say message
 430     end
 431
 432   is_okay:
 433     say "ok"
 434     end
 435 .end
 436 CODE
 437 /link.* failed for OS PMC:/
 438 OUT
 439 }
 440
 441 # Local Variables:
 442 #   mode: cperl
 443 #   cperl-indent-level: 4
 444 #   fill-column: 100
 445 # End:
 446 # vim: expandtab shiftwidth=4: