Skip Menu |
 

This queue is for tickets about the Archive-Zip CPAN distribution.

Report information
The Basics
Id: 63631
Status: new
Priority: 0/
Queue: Archive-Zip

People
Owner: Nobody in particular
Requestors: zinser [...] zinser.no-ip.info
Cc:
AdminCc:

Bug Information
Severity: Normal
Broken in: 1.30
Fixed in: (no value)



Subject: OpenVMS support for Archive::Zip
Download (untitled) / with headers
text/plain 538b
Hello, this is esentially a re-submission of 36430 . I started to look at Archive::Zip for OpenVMS and got the first fixits done when I found the patch against 1.23 in the bug tracking system. I applied the patch vs. 1.30 and it makes most of the tests pass on OpenVMS. The attached patch has been created against 1.30. It has been tested that the changes do not affect the success of the tests on Linux (openSUSE). If would be created if you would consider this for inclusion in the next version of Archive::Zip Greetings, Martin
Subject: Archive_Zip_1.30.patch
*** lib/Archive/Zip.pm.orig 2010-12-05 17:07:10.624060639 -0600 --- lib/Archive/Zip.pm 2010-12-05 16:34:41.000000000 -0600 *************** *** 524,533 **** my $forceDir = shift; my $volReturn = shift; my ( $volume, $directories, $file ) = ! File::Spec->splitpath( File::Spec->canonpath($name), $forceDir ); $$volReturn = $volume if ( ref($volReturn) ); ! my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec->splitdir($directories); if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component push ( @dirs, defined($file) ? $file : '' ); #return wantarray ? @dirs : join ( '/', @dirs ); return join ( '/', @dirs ); --- 524,536 ---- my $forceDir = shift; my $volReturn = shift; my ( $volume, $directories, $file ) = ! File::Spec::Unix->splitpath( File::Spec::Unix->canonpath($name), $forceDir ); $$volReturn = $volume if ( ref($volReturn) ); ! my @dirs = map { $_ =~ s{/}{_}g; $_ } File::Spec::Unix->splitdir($directories); if ( @dirs > 0 ) { pop (@dirs) unless $dirs[-1] } # remove empty component + if($^O eq 'VMS'){ + if ( @dirs > 0 ) { shift (@dirs) unless $dirs[0] } # remove empty component + } push ( @dirs, defined($file) ? $file : '' ); #return wantarray ? @dirs : join ( '/', @dirs ); return join ( '/', @dirs ); *** lib/Archive/Zip/Archive.pm.orig 2010-12-05 17:07:30.650998085 -0600 --- lib/Archive/Zip/Archive.pm 2010-12-05 16:35:26.000000000 -0600 *************** *** 440,446 **** $fh = undef; if ( $status != AZ_OK ) { ! unlink($tempName); _printError("Can't write to $tempName"); return $status; } --- 440,446 ---- $fh = undef; if ( $status != AZ_OK ) { ! 1 while unlink($tempName); _printError("Can't write to $tempName"); return $status; } *************** *** 450,456 **** # rename the zip if ( -f $zipName && !rename( $zipName, $backupName ) ) { $err = $!; ! unlink($tempName); return _error( "Can't rename $zipName as $backupName", $err ); } --- 450,456 ---- # rename the zip if ( -f $zipName && !rename( $zipName, $backupName ) ) { $err = $!; ! 1 while unlink($tempName); return _error( "Can't rename $zipName as $backupName", $err ); } *************** *** 458,471 **** unless ( File::Copy::move( $tempName, $zipName ) ) { $err = $!; rename( $backupName, $zipName ); ! unlink($tempName); return _error( "Can't move $tempName to $zipName", $err ); } # unlink the backup ! if ( -f $backupName && !unlink($backupName) ) { ! $err = $!; ! return _error( "Can't unlink $backupName", $err ); } return AZ_OK; --- 458,473 ---- unless ( File::Copy::move( $tempName, $zipName ) ) { $err = $!; rename( $backupName, $zipName ); ! 1 while unlink($tempName); return _error( "Can't move $tempName to $zipName", $err ); } # unlink the backup ! if ( -f $backupName ) { ! 1 while unlink($backupName); ! if(-e $backupName){ ! return _error( "Can't unlink $backupName", $! ); ! } } return AZ_OK; *** t/02_main.t.orig 2010-12-05 17:07:41.974000227 -0600 --- t/02_main.t 2010-12-05 16:35:47.000000000 -0600 *************** *** 488,494 **** my $fh; if ($catWorks) { ! unlink( OUTPUTZIP ); $fh = FileHandle->new( CATPIPE . OUTPUTZIP ); binmode($fh); } --- 488,494 ---- my $fh; if ($catWorks) { ! 1 while unlink( OUTPUTZIP ); $fh = FileHandle->new( CATPIPE . OUTPUTZIP ); binmode($fh); } *** t/03_ex.t.org 2010-12-05 17:07:52.177312450 -0600 --- t/03_ex.t 2010-12-05 16:36:08.000000000 -0600 *************** *** 8,13 **** --- 8,14 ---- use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); use File::Spec; use IO::File; + use Config; use Test::More tests => 17; BEGIN { *************** *** 19,35 **** sub runPerlCommand { my $libs = join ( ' -I', @INC ); ! my $cmd = "\"$^X\" \"-I$libs\" -w \"". join('" "', @_). '"'; my $output = `$cmd`; return wantarray ? ( $?, $output ) : $?; } ! use constant FILENAME => File::Spec->catpath( '', TESTDIR, 'testing.txt' ); use constant ZFILENAME => TESTDIR . "/testing.txt"; # name in zip my $zip = Archive::Zip->new(); isa_ok( $zip, 'Archive::Zip' ); ! $zip->addString( TESTSTRING, FILENAME ); $zip->writeToFileNamed(INPUTZIP); my ( $status, $output ); --- 20,40 ---- sub runPerlCommand { my $libs = join ( ' -I', @INC ); ! my $this_perl = $^X; ! if ($^O ne 'VMS'){ ! $this_perl .= $Config{_exe} unless $this_perl =~ m/$Config{_exe}$/i; ! } ! my $cmd = "$this_perl \"-I$libs\" -w \"". join('" "', @_). '"'; my $output = `$cmd`; return wantarray ? ( $?, $output ) : $?; } ! use constant FILENAME => File::Spec->catfile( TESTDIR, 'testing.txt' ); use constant ZFILENAME => TESTDIR . "/testing.txt"; # name in zip my $zip = Archive::Zip->new(); isa_ok( $zip, 'Archive::Zip' ); ! +$zip->addString( TESTSTRING, ZFILENAME ); $zip->writeToFileNamed(INPUTZIP); my ( $status, $output ); *************** *** 64,72 **** # removed because requires IO::Scalar # ok( runPerlCommand('examples/readScalar.pl'), 0 ); ! unlink(OUTPUTZIP); is( runPerlCommand( 'examples/selfex.pl', OUTPUTZIP, FILENAME ), 0 ); ! unlink(FILENAME); is( runPerlCommand(OUTPUTZIP), 0 ); my $fn = File::Spec->catpath( '', File::Spec->catdir( 'extracted', TESTDIR ), --- 69,77 ---- # removed because requires IO::Scalar # ok( runPerlCommand('examples/readScalar.pl'), 0 ); ! 1 while unlink(OUTPUTZIP); is( runPerlCommand( 'examples/selfex.pl', OUTPUTZIP, FILENAME ), 0 ); ! 1 while unlink(FILENAME); is( runPerlCommand(OUTPUTZIP), 0 ); my $fn = File::Spec->catpath( '', File::Spec->catdir( 'extracted', TESTDIR ), *************** *** 79,87 **** # zipcheck.pl # ziprecent.pl ! unlink(OUTPUTZIP); is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl create" ); is( -f OUTPUTZIP, 1, "zip created" ); is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl update" ); is( -f OUTPUTZIP, 1, "zip updated" ); ! unlink(OUTPUTZIP); --- 84,92 ---- # zipcheck.pl # ziprecent.pl ! 1 while unlink(OUTPUTZIP); is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl create" ); is( -f OUTPUTZIP, 1, "zip created" ); is( runPerlCommand( 'examples/updateTree.pl', OUTPUTZIP, TESTDIR ), 0, "updateTree.pl update" ); is( -f OUTPUTZIP, 1, "zip updated" ); ! 1 while unlink(OUTPUTZIP); *** t/06_update.t.orig 2010-12-05 17:08:03.949131433 -0600 --- t/06_update.t 2010-12-05 16:36:22.000000000 -0600 *************** *** 23,33 **** my $zip = Archive::Zip->new(); my $testDir = File::Spec->catpath( $testFileVolume, $testFileDirs, '' ); my $numberOfMembers = 0; my @memberNames; ! sub countMembers { unless ($_ eq '.') ! { push(@memberNames, $_); $numberOfMembers++; } }; File::Find::find( \&countMembers, $testDir ); is( $numberOfMembers > 1, 1, 'not enough members to test'); --- 23,40 ---- my $zip = Archive::Zip->new(); my $testDir = File::Spec->catpath( $testFileVolume, $testFileDirs, '' ); + if($^O eq 'VMS'){ + $testDir = 't'; + } my $numberOfMembers = 0; my @memberNames; ! sub countMembers { ! unless ( ($_ eq '.') || ($_ eq '[]') ) { ! push(@memberNames, $_); ! $numberOfMembers++; ! } ! }; File::Find::find( \&countMembers, $testDir ); is( $numberOfMembers > 1, 1, 'not enough members to test'); *************** *** 42,47 **** --- 49,57 ---- # add a file to the directory $testFileName = File::Spec->catpath( $testFileVolume, $testFileDirs, 'xxxxxx' ); + if($^O eq 'VMS'){ + $testFileName = File::Spec->catfile( $testDir, 'xxxxxx' ); + } my $fh = IO::File->new( $testFileName, 'w'); $fh->print('xxxx'); undef($fh); *************** *** 52,58 **** is( scalar($zip->members()), $numberOfMembers + 1, 'wrong number of members after update' ); # Delete the file. ! unlink($testFileName); is( -f $testFileName, undef, "deleting $testFileName failed"); # updating without the mirror option should keep the members --- 62,68 ---- is( scalar($zip->members()), $numberOfMembers + 1, 'wrong number of members after update' ); # Delete the file. ! 1 while unlink($testFileName); is( -f $testFileName, undef, "deleting $testFileName failed"); # updating without the mirror option should keep the members *** t/07_filenames_of_0.t.orig 2010-12-05 17:08:12.380511252 -0600 --- t/07_filenames_of_0.t 2010-12-05 16:36:35.000000000 -0600 *************** *** 32,43 **** my $archive = Archive::Zip->new; $archive->addTree( ! File::Spec->catfile('testdir', 'folder'), 'folder', ); # TEST ! ok(scalar(grep { $_ eq "folder/0" } $archive->memberNames()), "Checking that a file called '0' was added properly" ); --- 32,47 ---- my $archive = Archive::Zip->new; $archive->addTree( ! File::Spec::Unix->catfile('testdir', 'folder'), 'folder', ); # TEST ! my $dot = q{}; ! if($^O eq 'VMS'){ ! $dot = q{.}; ! } ! ok(scalar(grep { $_ eq "folder/0$dot" } $archive->memberNames()), "Checking that a file called '0' was added properly" ); *** t/common.pl.orig 2010-12-05 17:08:20.559309651 -0600 --- t/common.pl 2010-12-05 16:36:46.000000000 -0600 *************** *** 148,153 **** --- 148,156 ---- #--------- check to see if cat works sub testCat { + if($^O eq 'VMS'){ + return 0; + } my $fh = IO::File->new( CATPIPE . OUTPUTZIP ); binmode($fh); my $testString = pack( 'C256', 0 .. 255 ); *************** *** 158,164 **** my @stat = stat(OUTPUTZIP); $stat[7] == length($testString) or return 0; fileCRC(OUTPUTZIP) == $testCrc or return 0; ! unlink(OUTPUTZIP); return 1; } --- 161,167 ---- my @stat = stat(OUTPUTZIP); $stat[7] == length($testString) or return 0; fileCRC(OUTPUTZIP) == $testCrc or return 0; ! 1 while unlink(OUTPUTZIP); return 1; } *************** *** 172,178 **** #--------- check to see if zip works (and make INPUTZIP) BEGIN { ! unlink(INPUTZIP); # Do we have zip installed? if ( HAVEZIP ) { --- 175,181 ---- #--------- check to see if zip works (and make INPUTZIP) BEGIN { ! 1 while unlink(INPUTZIP); # Do we have zip installed? if ( HAVEZIP ) {


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.