01_archive-extract.t

source of perl for linux application,

### test __get_extract_dir 
SKIP: {   my $meth = '__get_extract_dir';

    ### get the right separator -- File::Spec does clean ups for
    ### paths, so we need to join ourselves.
    my $sep  = [ split '', File::Spec->catfile( 'a', 'b' ) ]->[1];
    
    ### bug #23999: Attempt to generate Makefile.PL gone awry
    ### showed that dirs in the style of './dir/' were reported
    ### to be unpacked in '.' rather than in 'dir'. here we test
    ### for this.
    for my $prefix ( '', '.' ) {
        skip "Prepending ./ to a valid path doesn't give you another valid path on VMS", 2
            if IS_VMS && length($prefix);

        my $dir = basename( $SrcDir );

        ### build a list like [dir, dir/file] and [./dir ./dir/file]
        ### where the dir and file actually exist, which is important
        ### for the method call
        my @files = map { length $prefix 
                                ? join $sep, $prefix, $_
                                : $_
                      } $dir, File::Spec->catfile( $dir, [keys %$tmpl]->[0] );
        
        my $res = $Class->$meth( \@files );
        $res = &Win32::GetShortPathName( $res ) if IS_WIN32;

        ok( $res,               "Found extraction dir '$res'" );
        is( $res, $SrcDir,      "   Is expected dir '$SrcDir'" );
    }        
}

for my $switch (0,1) {

    local $Archive::Extract::PREFER_BIN = $switch;
    diag("Running extract with PREFER_BIN = $Archive::Extract::PREFER_BIN")
        if $Debug;

    for my $archive (keys %$tmpl) {

        diag("Extracting $archive") if $Debug;

        ### check first if we can do the proper

        my $ae = Archive::Extract->new(
                        archive => File::Spec->catfile($SrcDir,$archive) );

        isa_ok( $ae, $Class );

        my $method = $tmpl->{$archive}->{method};
        ok( $ae->$method(),         "Archive type recognized properly" );

    ### 10 tests from here on down ###
    SKIP: {
        my $file        = $tmpl->{$archive}->{outfile};
        my $dir         = $tmpl->{$archive}->{outdir};  # can be undef
        my $rel_path    = File::Spec->catfile( grep { defined } $dir, $file );
        my $abs_path    = File::Spec->catfile( $OutDir, $rel_path );
        my $abs_dir     = File::Spec->catdir( 
                            grep { defined } $OutDir, $dir );
        my $nix_path    = File::Spec::Unix->catfile(
                            grep { defined } $dir, $file );

        ### check if we can run this test ###
        my $pgm_fail; my $mod_fail;
        for my $pgm ( @{$tmpl->{$archive}->{programs}} ) {
            ### no binary extract method
            $pgm_fail++, next unless $pgm;

            ### we dont have the program
            $pgm_fail++ unless $Archive::Extract::PROGRAMS->{$pgm} &&
                               $Archive::Extract::PROGRAMS->{$pgm};

        }

        for my $mod ( @{$tmpl->{$archive}->{modules}} ) {
            ### no module extract method
            $mod_fail++, next unless $mod;

            ### we dont have the module
            $mod_fail++ unless check_install( module => $mod );
        }

        ### where to extract to -- try both dir and file for gz files
        ### XXX test me!
        #my @outs = $ae->is_gz ? ($abs_path, $OutDir) : ($OutDir);
        my @outs = $ae->is_gz || $ae->is_bz2 || $ae->is_Z 
                        ? ($abs_path) 
                        : ($OutDir);

        skip "No binaries or modules to extract ".$archive, 
            (10 * scalar @outs) if $mod_fail && $pgm_fail;

        ### we dont warnings spewed about missing modules, that might
        ### be a problem...
        local $IPC::Cmd::WARN = 0;
        local $IPC::Cmd::WARN = 0;
        
        for my $use_buffer ( IPC::Cmd->can_capture_buffer , 0 ) {

            ### test buffers ###
            my $turn_off = !$use_buffer && !$pgm_fail &&
                            $Archive::Extract::PREFER_BIN;

            ### whitebox test ###
            ### stupid warnings ###
            local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
            local $IPC::Cmd::USE_IPC_RUN    = 0 if $turn_off;
            local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;
            local $IPC::Cmd::USE_IPC_OPEN3  = 0 if $turn_off;


            ### try extracting ###
            for my $to ( @outs ) {

                diag("Extracting to: $to")                  if $Debug;
                diag("Buffers enabled: ".!$turn_off)        if $Debug;
  
                my $rv = $ae->extract( to => $to );
    
                ok( $rv, "extract() for '$archive' reports success");
    
                diag("Extractor was: " . $ae->_extractor)   if $Debug;
    
                SKIP: {
                    my $re  = qr/^No buffer captured/;
                    my $err = $ae->error || '';
              
                    ### skip buffer tests if we dont have buffers or
                    ### explicitly turned them off
                    skip "No buffers available", 7,
                        if ( $turn_off || !IPC::Cmd->can_capture_buffer)
                            && $err =~ $re;

                    ### if we /should/ have buffers, there should be
                    ### no errors complaining we dont have them...
                    unlike( $err, $re,
                                    "No errors capturing buffers" );
    
                    ### might be 1 or 2, depending wether we extracted 
                    ### a dir too
                    my $file_cnt = grep { defined } $file, $dir;
                    is( scalar @{ $ae->files || []}, $file_cnt,
                                    "Found correct number of output files" );
                    is( $ae->files->[-1], $nix_path,
                                    "Found correct output file '$nix_path'" );
    
                    ok( -e $abs_path,
                                    "Output file '$abs_path' exists" );
                    ok( $ae->extract_path,
                                    "Extract dir found" );
                    ok( -d $ae->extract_path,
                                    "Extract dir exists" );
                    is( $ae->extract_path, $abs_dir,
                                    "Extract dir is expected '$abs_dir'" );
                }

                SKIP: {
                    skip "Unlink tests are unreliable on Win32", 3 if IS_WIN32;

                    1 while unlink $abs_path;
                    ok( !(-e $abs_path), "Output file successfully removed" );
        
                    SKIP: {
                        skip "No extract path captured, can't remove paths", 2
                            unless $ae->extract_path;
        
                        ### if something went wrong with determining the out
                        ### path, don't go deleting stuff.. might be Really Bad
                        my $out_re = quotemeta( $OutDir );
                        
                        ### VMS directory layout is different. Craig Berry
                        ### explains:
                        ### the test is trying to determine if C</disk1/foo/bar>
                        ### is part of C</disk1/foo/bar/baz>.  Except in VMS
                        ### syntax, that would mean trying to determine whether
                        ### C<disk1:[foo.bar]> is part of C<disk1:[foo.bar.baz]>
                        ### Because we have both a directory delimiter
                        ### (dot) and a directory spec terminator (right 
                        ### bracket), we have to trim the right bracket from 
                        ### the first one to make it successfully match the
                        ### second one.  Since we're asserting the same truth --
                        ### that one path spec is the leading part of the other
                        ### -- it seems to me ok to have this in the test only.
                        ### 
                        ### so we strip the ']' of the back of the regex
                        $out_re =~ s/\\\]// if IS_VMS; 
                        
                        if( $ae->extract_path !~ /^$out_re/ ) {   
                            ok( 0, "Extractpath WRONG (".$ae->extract_path.")"); 
                            skip(  "Unsafe operation -- skip cleanup!!!" ), 1;
                        }                    
        
                        eval { rmtree( $ae->extract_path ) }; 
                        ok( !$@,        "   rmtree gave no error" );
                        ok( !(-d $ae->extract_path ),
                                        "   Extract dir succesfully removed" );
                    }
                }
            }
        }
    } }
}