git.maemo.org Git - dh-make-perl/blob - dev/i386/libfile-chdir-perl/libfile-chdir-perl-0.06/t/array.t

   1 #!/usr/bin/perl -Tw
   2
   3 use strict;
   4 use lib qw(t/lib);
   5 use Test::More tests => 31;
   6
   7 BEGIN { use_ok('File::chdir') }
   8
   9 use Cwd;
  10
  11 sub _catdir {
  12     File::Spec->catdir(File::Spec->rootdir, @_);
  13 }
  14
  15 my @cwd = grep length, File::Spec->splitdir(Cwd::abs_path);
  16
  17 ok( tied @CWD,      '@CWD is fit to be tied' );
  18
  19 # First, let's try unlocalized push @CWD.
  20 {
  21     push @CWD, 't';
  22     is( getcwd, _catdir(@cwd,'t'),       'unlocalized push @CWD works' );
  23     ok( eq_array(\@CWD, [@cwd, 't']),    '  @CWD set' );
  24     is( $CWD,   _catdir(@cwd,'t'),       '  $CWD set' );
  25 }
  26
  27 is( getcwd, _catdir(@cwd,'t'),      'unlocalized @CWD unneffected by blocks' );
  28 ok( eq_array(\@CWD, [@cwd, 't']),   '  @CWD still set' );
  29
  30 # reset
  31 @CWD = @cwd;
  32
  33 # How about pop?
  34 {
  35     my $popped_dir = pop @CWD;
  36     my @new_cwd = @cwd[0..$#cwd-1];
  37
  38     is( getcwd, _catdir(@new_cwd),      'unlocalized pop @CWD works' );
  39     is( $popped_dir, $cwd[-1],          '  returns popped dir' );
  40     ok( eq_array(\@CWD, \@new_cwd),     '  @CWD set' );
  41     is( $CWD,   _catdir(@new_cwd),      '  $CWD set' );
  42 }
  43
  44 is( getcwd, _catdir(@cwd[0..$#cwd-1]),
  45                                   'unlocalized @CWD unneffected by blocks' );
  46 ok( eq_array(\@CWD, [@cwd[0..$#cwd-1]]),   '  @CWD still set' );
  47
  48 # reset
  49 @CWD = @cwd;
  50
  51
  52 # splice?
  53 {
  54     my @spliced_dirs = splice @CWD, -2;
  55     my @new_cwd = @cwd[0..$#cwd-2];
  56
  57     is( getcwd, _catdir(@new_cwd),      'unlocalized splice @CWD works' );
  58     is( @spliced_dirs, 2,               '  returns right # of dirs' );
  59     ok( eq_array(\@spliced_dirs, [@cwd[-2,-1]]), "  and they're correct" );
  60     ok( eq_array(\@CWD, \@new_cwd),     '  @CWD set' );
  61     is( $CWD,   _catdir(@new_cwd),      '  $CWD set' );
  62 }
  63
  64 is( getcwd, _catdir(@cwd[0..$#cwd-2]),
  65                                     'unlocalized @CWD unneffected by blocks' );
  66 ok( eq_array(\@CWD, [@cwd[0..$#cwd-2]]),   '  @CWD still set' );
  67
  68 # reset
  69 @CWD = @cwd;
  70
  71 # Now an unlocalized assignment
  72 {
  73     @CWD = (@cwd, 't');
  74     is( getcwd, _catdir(@cwd,'t'),       'unlocalized @CWD works' );
  75     ok( eq_array(\@CWD, [@cwd, 't']),   '  @CWD set' );
  76     is( $CWD,   _catdir(@cwd,'t'),       '  $CWD set' );
  77 }
  78
  79 is( getcwd, _catdir(@cwd,'t'),      'unlocalized @CWD unneffected by blocks' );
  80 ok( eq_array(\@CWD, [@cwd, 't']),   '  @CWD still set' );
  81
  82 # reset
  83 @CWD = @cwd;
  84
  85 eval { $#CWD = 1; };
  86 ok( !$@,    '$#CWD assignment is a no-op' );
  87
  88
  89 # localized assignment
  90 {
  91     # localizing tied arrays doesn't work, perl bug. :(
  92     # this is a work around.
  93     local $CWD;
  94     @CWD = (@cwd, 't');
  95     is( getcwd, _catdir(@cwd,'t'),       'localized @CWD works' );
  96     ok( eq_array(\@CWD, [@cwd, 't']),   '  @CWD set' );
  97     is( $CWD,   _catdir(@cwd,'t'),       '  $CWD set' );
  98 }
  99
 100 is( getcwd, _catdir(@cwd),    'localized @CWD resets cwd' );
 101 ok( eq_array(\@CWD, \@cwd),   '  @CWD reset' );