ext/Archive-Tar/t/90_symlink.t

   1 BEGIN {
   2     if( $ENV{PERL_CORE} ) {
   3         chdir '../lib/Archive/Tar' if -d '../lib/Archive/Tar';
   4     }
   5     use lib '../../..';
   6 }
   7
   8 BEGIN { chdir 't' if -d 't' }
   9
  10 use lib '../lib';
  11
  12 use strict;
  13 use File::Spec;
  14 use File::Path;
  15 use Test::More;
  16
  17 ### developer tests mostly, so enable them with an extra argument
  18 plan skip_all => "Skipping tests on this platform" unless @ARGV;
  19 plan 'no_plan';
  20
  21 my $Class   = 'Archive::Tar';
  22 my $Dir     = File::Spec->catdir( qw[src linktest] );
  23 my %Map     = (
  24     File::Spec->catfile( $Dir, "linktest_with_dir.tar" ) => [
  25         [ 0, qr/SECURE EXTRACT MODE/ ],
  26         [ 1, qr/^$/ ]
  27     ],
  28     File::Spec->catfile( $Dir, "linktest_missing_dir.tar" ) => [
  29         [ 0, qr/SECURE EXTRACT MODE/ ],
  30         [ 0, qr/File exists/ ],
  31     ],
  32 );
  33
  34 use_ok( $Class );
  35
  36 {   while( my($file, $aref) = each %Map ) {
  37
  38         for my $mode ( 0, 1 ) {
  39             my $expect = $aref->[$mode]->[0];
  40             my $regex  = $aref->[$mode]->[1];
  41
  42             my $tar  = $Class->new( $file );
  43             ok( $tar,                   "Object created from $file" );
  44
  45             ### damn warnings
  46             local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
  47             local $Archive::Tar::INSECURE_EXTRACT_MODE = $mode;
  48
  49             ok( 1,                  "   Extracting with insecure mode: $mode" );
  50
  51             my $warning;
  52             local $SIG{__WARN__} = sub { $warning .= "@_"; warn @_; };
  53
  54             my $rv = eval { $tar->extract } || 0;
  55             ok( !$@,                "       No fatal error" );
  56             is( !!$rv, !!$expect,   "       RV as expected" );
  57             like( $warning, $regex, "       Error matches $regex" );
  58
  59             rmtree( 'linktest' );
  60         }
  61     }
  62 }