t/pmc/os.t

   1 #! perl
   2 # Copyright (C) 2001-2006, The Perl 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 => 15;
  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 $MSVC = grep { $PConfig{cc} eq $_ } (qw(cl cl.exe));
  17
  18 =head1 NAME
  19
  20 t/pmc/os.t - Files and Dirs
  21
  22 =head1 SYNOPSIS
  23
  24     % prove t/pmc/os.t
  25
  26 =head1 DESCRIPTION
  27
  28 Tests the C<OS> PMC.
  29
  30 =cut
  31
  32 END {
  33
  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 pir_output_is( <<'CODE', <<"OUT", 'Test cwd' );
  42 .sub main :main
  43         $P1 = new 'OS'
  44         $S1 = $P1."cwd"()
  45         print $S1
  46         print "\n"
  47         end
  48 .end
  49 CODE
  50 $cwd
  51 OUT
  52
  53 #  TEST chdir
  54 chdir "src";
  55 my $upcwd = File::Spec->canonpath(getcwd);
  56 chdir '..';
  57
  58 pir_output_is( <<'CODE', <<"OUT", 'Test chdir' );
  59 .sub main :main
  60         $P1 = new 'OS'
  61
  62         $S1 = "src"
  63         $P1."chdir"($S1)
  64
  65         $S1 = $P1."cwd"()
  66         print $S1
  67         print "\n"
  68
  69         $S1 = ".."
  70         $P1."chdir"($S1)
  71
  72         $S1 = $P1."cwd"()
  73         print $S1
  74         print "\n"
  75
  76         end
  77 .end
  78 CODE
  79 $upcwd
  80 $cwd
  81 OUT
  82
  83 # Test mkdir
  84
  85 my $xpto = $upcwd;
  86 $xpto =~ s/src([\/\\]?)$/xpto$1/;
  87
  88 pir_output_is( <<'CODE', <<"OUT", 'Test mkdir' );
  89 .sub main :main
  90         $P1 = new 'OS'
  91
  92         $S1 = "xpto"
  93         $I1 = 0o555
  94         $P1."mkdir"($S1,$I1)
  95         $P1."chdir"($S1)
  96
  97         $S1 = $P1."cwd"()
  98         print $S1
  99         print "\n"
 100
 101         $S1 = ".."
 102         $P1."chdir"($S1)
 103
 104         $S1 = $P1."cwd"()
 105         print $S1
 106         print "\n"
 107
 108         end
 109 .end
 110 CODE
 111 $xpto
 112 $cwd
 113 OUT
 114
 115 # Test remove on a directory
 116 mkdir "xpto" unless -d "xpto";
 117
 118 pir_output_is( <<'CODE', <<'OUT', 'Test rm call in a directory' );
 119 .sub main :main
 120         $P1 = new 'OS'
 121
 122         $S1 = "xpto"
 123         $P1."rm"($S1)
 124
 125         print "ok\n"
 126
 127         end
 128 .end
 129 CODE
 130 ok
 131 OUT
 132
 133 ok( !-d $xpto, "Test that rm removed the directory" );
 134 rmdir $xpto if -d $xpto;    # this way next test doesn't fail if this one does
 135
 136 # test stat
 137
 138 open my $X, '>', "xpto";
 139 print $X "xpto";
 140 close $X;
 141
 142 my $stat;
 143
 144 if ( $cygwin || $MSWin32 ) {
 145
 146     # Skip inode number
 147     my @s = stat('xpto');
 148     $stat = join( "\n", $s[0], @s[ 2 .. 10 ] ) . "\n";
 149     pir_output_is( <<'CODE', $stat, 'Test OS.stat' );
 150 .sub main :main
 151         $P1 = new 'OS'
 152         $S1 = "xpto"
 153         $P2 = $P1."stat"($S1)
 154
 155         $I1 = 0
 156 loop:
 157         $S1 = $P2[$I1]
 158         print $S1
 159         print "\n"
 160         $I1 += 1
 161         if $I1 == 1 goto inc
 162         if $I1 == 11 goto done
 163         goto loop
 164 inc:
 165         $I1 += 1
 166         goto loop
 167
 168 done:
 169         end
 170 .end
 171 CODE
 172 }
 173 else {
 174     $stat = join( "\n", stat("xpto") ) . "\n";
 175     pir_output_is( <<'CODE', $stat, 'Test OS.stat' );
 176 .sub main :main
 177         $P1 = new 'OS'
 178         $S1 = "xpto"
 179         $P2 = $P1."stat"($S1)
 180
 181         $I1 = 0
 182 loop:
 183         $S1 = $P2[$I1]
 184         print $S1
 185         print "\n"
 186         $I1 += 1
 187         if $I1 == 13 goto done
 188         goto loop
 189 done:
 190         end
 191 .end
 192 CODE
 193
 194 }
 195
 196 # test readdir
 197 SKIP: {
 198     skip 'not implemented on windows yet', 1 if ( $MSWin32 && $MSVC );
 199
 200     opendir my $IN, '.';
 201     my @entries = readdir $IN;
 202     closedir $IN;
 203     my $entries = join( ' ', @entries ) . "\n";
 204     pir_output_is( <<'CODE', $entries, 'Test OS.readdir' );
 205 .sub main :main
 206     $P1 = new 'OS'
 207     $P2 = $P1.readdir('.')
 208
 209     $S0 = join ' ', $P2
 210     print $S0
 211     print "\n"
 212 .end
 213 CODE
 214 }
 215
 216 # test rename
 217 SKIP: {
 218     open my $FILE, ">", "____some_test_file";
 219     close $FILE;
 220     pir_output_is( <<'CODE', <<"OUT", 'Test OS.rename' );
 221 .sub main :main
 222     $P1 = new 'OS'
 223     $P1.rename('____some_test_file', '___some_other_file')
 224     $I0 = stat '___some_other_file', 0
 225     print $I0
 226     print "\n"
 227     $P1.rm('___some_other_file')
 228 .end
 229 CODE
 230 1
 231 OUT
 232 }
 233
 234 # test lstat
 235
 236 my $lstat;
 237
 238 SKIP: {
 239     skip 'lstat not available on Win 32 yet', 1 if $MSWin32;
 240
 241     if ($cygwin) {
 242
 243         # Skip inode number
 244         my @s = stat('xpto');
 245         $stat = join( "\n", $s[0], @s[ 2 .. 12 ] ) . "\n";
 246         pir_output_is( <<'CODE', $stat, "Test OS.lstat" );
 247 .sub main :main
 248         $P1 = new 'OS'
 249         $S1 = "xpto"
 250         $P2 = $P1."lstat"($S1)
 251
 252         $I1 = 0
 253 loop:
 254         $S1 = $P2[$I1]
 255         print $S1
 256         print "\n"
 257         $I1 += 1
 258         if $I1 == 1 goto inc
 259         if $I1 == 13 goto done
 260         goto loop
 261 inc:
 262         $I1 += 1
 263         goto loop
 264
 265 done:
 266         end
 267 .end
 268 CODE
 269     }
 270     else {
 271         $lstat = join( "\n", lstat("xpto") ) . "\n";
 272         pir_output_is( <<'CODE', $lstat, "Test OS.lstat" );
 273 .sub main :main
 274         $P1 = new 'OS'
 275         $S1 = "xpto"
 276         $P2 = $P1."lstat"($S1)
 277
 278         $I1 = 0
 279 loop:
 280         $S1 = $P2[$I1]
 281         print $S1
 282         print "\n"
 283         $I1 += 1
 284         if $I1 == 13 goto done
 285         goto loop
 286 done:
 287         end
 288 .end
 289 CODE
 290     }
 291 }
 292
 293 # Test remove on a file
 294 pir_output_is( <<'CODE', <<"OUT", "Test rm call in a file" );
 295 .sub main :main
 296         $P1 = new 'OS'
 297
 298         $S1 = "xpto"
 299         $P1."rm"($S1)
 300
 301         print "ok\n"
 302
 303         end
 304 .end
 305 CODE
 306 ok
 307 OUT
 308
 309 ok( !-f $xpto, "Test that rm removed file" );
 310 rmdir $xpto if -f $xpto;    # this way next test doesn't fail if this one does
 311
 312 # Test symlink
 313 SKIP: {
 314     skip "Symlinks not available under Windows", 2 if $MSWin32;
 315
 316     pir_output_is( <<'CODE', <<"OUT", "Test symlink" );
 317 .sub main :main
 318         $P1 = new 'OS'
 319
 320         $S1 = "xpto"
 321         $S2 = "MANIFEST"
 322         $P1."symlink"($S2, $S1)
 323
 324         print "ok\n"
 325
 326         end
 327 .end
 328 CODE
 329 ok
 330 OUT
 331
 332     ok( -l "xpto", "symlink was really created" );
 333     unlink "xpto" if -f "xpto";
 334 }
 335
 336 # Test link
 337 SKIP: {
 338     skip "Parrot link not implemented for Windows, yet", 2 if $MSWin32;
 339
 340     pir_output_is( <<'CODE', <<"OUT", "Test link" );
 341 .sub main :main
 342         $P1 = new 'OS'
 343
 344         $S1 = "xpto"
 345         $S2 = "MANIFEST"
 346         $P1."link"($S2, $S1)
 347
 348         print "ok\n"
 349
 350         end
 351 .end
 352 CODE
 353 ok
 354 OUT
 355
 356     my $nl = [ stat("MANIFEST") ]->[3];
 357     ok( $nl > 1, "hard link was really created" );
 358     unlink "xpto" if -f "xpto";
 359 }
 360
 361 # Local Variables:
 362 #   mode: cperl
 363 #   cperl-indent-level: 4
 364 #   fill-column: 100
 365 # End:
 366 # vim: expandtab shiftwidth=4: