| Subject: | OpenVMS support for Archive::Zip |
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 ) {