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