t/perl/Parrot_IO.t

   1 #! perl
   2 # Copyright (C) 2001-2010, Parrot Foundation.
   3 # $Id$
   4
   5 use strict;
   6 use warnings;
   7 use lib qw( . lib ../lib ../../lib );
   8
   9 use Test::More 'tests' => 58;
  10
  11 use Parrot::Distribution;
  12 use File::Spec::Functions ':ALL';
  13 use File::Temp qw/tempdir/;
  14
  15 =head1 NAME
  16
  17 t/perl/Parrot_IO.t - Parrot::IO unit tests
  18
  19 =head1 SYNOPSIS
  20
  21     % prove t/perl/Parrot_IO.t
  22
  23 =head1 DESCRIPTION
  24
  25 These tests cover the basic functionality of C<Parrot::IO::File> and
  26 C<Parrot::IO::Directory>: directory contents, file
  27 C<read>/C<write>/C<append>, modification times, and relative paths.
  28
  29 There are also a few test for C<Parrot::IO::Path>, the abstract
  30 superclass for these two modules, which cover "tmp" paths, and name and
  31 suffix recognition.
  32
  33 When one or more of the C<Parrot::IO> modules is modified, run the tests
  34 to ensure nothing is broken.
  35
  36 =cut
  37
  38 # Path is really only an abstract superclass but there are a few things we
  39 # can do with it.
  40 BEGIN { use_ok('Parrot::IO::Path') }
  41
  42 my $file_temp_work_path = tempdir(
  43     'PARROT_IO_XXXX',
  44     TMPDIR => 1,
  45     CLEANUP => 1
  46 );
  47 # you can sort of count on the var below being the unique part of the temp dir
  48 my $file_temp_dir = (splitdir($file_temp_work_path))[-1];
  49
  50 my $suffix   = 'txt';
  51 my $name     = 'file';
  52 my $fullname = join '.', $name, $suffix;
  53 my $tmpfile  = tmp_file_path($fullname);
  54
  55 my $p = Parrot::IO::Path->new($tmpfile);
  56
  57 # Path parsing.
  58 ok( $p,                      'new' );
  59 ok( $p->has_suffix(),        'has_suffix none' );
  60 ok( $p->has_suffix($suffix), 'has_suffix correct' );
  61 ok( !$p->has_suffix('foo'),  'has_suffix incorrect' );
  62 is( $p->suffix(),              $suffix,   'suffix' );
  63 is( $p->name(),                $fullname, 'name' );
  64 is( $p->name_without_suffix(), $name,     'name_without_suffix' );
  65
  66 # Check we get the same instance each time.
  67 is( $p, Parrot::IO::Path->new($tmpfile), 'instance cached' );
  68 my $oldp = $p;
  69 $p->delete();
  70 ok( !defined $p, 'delete undefined instance' );
  71
  72 # This will not create the file on disk.
  73 $p = Parrot::IO::Path->new($tmpfile);
  74 isnt( $oldp, $p, 'delete from cache' );
  75
  76 is( $p->parent_path(), tmp_dir_path(), 'parent_path' );
  77
  78 my $r = Parrot::IO::Path->new( rootdir() );
  79 ok( !$r->parent_path(), 'root has no parent_path' );
  80
  81 teardown();
  82
  83 BEGIN { use_ok('Parrot::IO::Directory') }
  84 BEGIN { use_ok('Parrot::IO::File') }
  85
  86 $r = Parrot::IO::Directory->new(rootdir);
  87 ok( $r, 'new' );
  88 isa_ok( $r, 'Parrot::IO::Directory' );
  89 ok( !$r->parent(), 'root has no parent' );
  90
  91 my $d = Parrot::IO::Directory->tmp_directory(
  92     catfile($file_temp_dir, 't')
  93 );
  94 ok( $d, 'tmp_directory' );
  95
  96 # Create a file in a directory that does not exist.
  97 my $f3 = Parrot::IO::File->new( tmp_file_path( 't', 'one', 'two', 'file3.bar' ) );
  98 ok( $f3, 'file new' );
  99
 100 my $d1 = $d->directory_with_name('one');
 101 my $d2 = $d1->directory_with_name('two');
 102 ok( $d1 && $d2, 'directory_with_name' );
 103
 104 my $f = Parrot::IO::File->tmp_file(catfile($file_temp_dir, $fullname));
 105 ok( $f, 'tmp_file' );
 106
 107 # Check the instance got re-blessed.
 108 is( $p, $f, 'path became file' );
 109
 110 my $f1 = $d1->file_with_name('file1.txt');
 111 my $f2 = $d2->file_with_name('file2.foo');
 112 ok( $f1 && $f2, 'file_with_name' );
 113
 114 # Relative paths.
 115 is( $d->relative_path( $d->path ),   curdir(),                   'relative_path same dir' );
 116 is( $d1->relative_path( $f1->path ), 'file1.txt',                'relative_path same file' );
 117 is( $d->relative_path( $d1->path ),  'one',                      'relative_path down to dir' );
 118 is( $d->relative_path( $f1->path ),  catfile(qw(one file1.txt)), 'relative_path down to file' );
 119 is( $d1->relative_path( $d->path ),  '..',                       'relative_path up to dir' );
 120 is( $d->relative_path( $f->path ),   catfile(qw(.. file.txt)),   'relative_path up to file' );
 121 is( $d1->relative_path( $f->path ), catfile(qw(.. .. file.txt)), 'relative_path up twice to file' );
 122 ok( $d->relative_path_is_directory( catdir(qw(one two)) ),       'relative_path_is_directory' );
 123 ok( $d->relative_path_is_file( catfile(qw(one two file2.foo)) ), 'relative_path_is_file' );
 124 is( $d2, $d->directory_with_relative_path( catdir(qw(one/two)) ),       'file_with_relative_path' );
 125 is( $f2, $d->file_with_relative_path( catfile(qw(one two file2.foo)) ), 'file_with_relative_path' );
 126
 127 # Names and paths.
 128 my @a = $d1->file_and_directory_names;
 129 is( 'file1.txt two', join( ' ', @a ), 'file_and_directory_names' );
 130
 131 @a = $d1->file_and_directory_paths;
 132 is( @a, 2, 'file_and_directory_paths' );
 133 @a = $d1->directory_paths;
 134 is( @a, 1, 'directory_paths' );
 135 @a = $d1->file_paths;
 136 is( @a, 1, 'file_paths' );
 137
 138 # File instances
 139 @a = $d2->files;
 140 is( 'file2.foo file3.bar', join( ' ', map { $_->name } @a ), 'files' );
 141 @a = $d->files(1);
 142 is( 'file1.txt file2.foo file3.bar', join( ' ', map { $_->name } @a ), 'files recursive' );
 143 @a = $d->files( 1, 'two' );
 144 is( 'file1.txt', join( ' ', map { $_->name } @a ), 'files recursive ignore' );
 145
 146 # File suffix
 147 @a = $d1->file_suffixes();
 148 ok( 'txt' eq join( ' ', @a ), 'file_suffixes' );
 149 @a = $d->file_suffixes(1);
 150 is( 'bar foo txt', join( ' ', @a ), 'file_suffixes recursive' );
 151
 152 @a = $d->file_suffixes( 1, 'two' );
 153 is( 'txt', join( ' ', @a ), 'file_suffixes recursive ignore' );
 154
 155 @a = $d->files_with_suffix( 'txt', 1, 'two' );
 156 is( 'file1.txt', join( ' ', map { $_->name } @a ), 'files_with_suffix recursive ignore' );
 157
 158 # Status (stat info)
 159 my $time = time;
 160 ok( !$f3->modified_since($time), 'not modified_since' );
 161
 162 # So that the modified time will be greater than $time.
 163 sleep 1 while time() <= ( $time + 1 );
 164
 165 # Now the read/write stuff.
 166 $f3->write("hello");
 167 is( $f3->read, "hello", 'read/write' );
 168 $f3->append("\nworld");
 169 is( $f3->read, "hello\nworld", 'append and scalar read' );
 170 @a = $f3->read;
 171 is( $a[1], "world", 'array read' );
 172
 173 ok( $f3->modified_since($time), 'modified_since' );
 174
 175 SKIP: {
 176     my $nul = File::Spec->devnull;
 177
 178     skip( 'keywords not expanded in non-svn checkouts', 2 )
 179         unless Parrot::Distribution->new->is_svn_co();
 180
 181     $f = Parrot::IO::File->new( catfile( 'lib', 'Parrot', 'IO', 'File.pm' ) );
 182     ok( $f->has_svn_id(), 'has_svn_id' );
 183
 184     ok($f->svn_id() =~ /^(?:\$)Id:.*?File.pm \d+ \d{4}-\d\d-\d\d.*?[^\$]+ \$$/,
 185        'svn_id');
 186 }
 187
 188 $f3->delete();
 189 @a = $d2->files();
 190 is( @a, 1, 'file delete' );
 191 ok( !defined $f3, 'delete undefined file' );
 192
 193 $d2->delete();
 194 @a = $d1->directories();
 195 is( @a, 0, 'directory delete' );
 196 ok( !defined $d2, 'delete undefined directory' );
 197
 198 $d->delete_contents();
 199 @a = $d->file_and_directory_paths();
 200 is( @a, 0, 'delete_contents' );
 201
 202 teardown();
 203
 204 sub teardown {
 205     unlink( tmp_file_path(qw(t one two file2.foo)) );
 206     unlink( tmp_file_path(qw(t one two file3.bar)) );
 207     unlink( tmp_file_path(qw(t one file1.txt)) );
 208     rmdir( tmp_dir_path(qw(t one two)) );
 209     rmdir( tmp_dir_path(qw(t one)) );
 210     rmdir( tmp_dir_path('t') );
 211 }
 212
 213 # tmp_dir_path(@dirs)
 214 sub tmp_dir_path {
 215     return catdir( $file_temp_work_path, @_ );
 216 }
 217
 218 # tmp_file_path(@dirs, $file)
 219 sub tmp_file_path {
 220     my $file;
 221
 222     if ( @_ == 1 ) {
 223         $file = catfile( tmp_dir_path(), shift );
 224     }
 225     else {
 226         $file = pop(@_);
 227         $file = catfile( tmp_dir_path(@_), $file );
 228     }
 229
 230     return $file;
 231 }
 232
 233 # Local Variables:
 234 #   mode: cperl
 235 #   cperl-indent-level: 4
 236 #   fill-column: 100
 237 # End:
 238 # vim: expandtab shiftwidth=4: