diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ArchiveZip.java b/src/main/java/org/perlonjava/runtime/perlmodule/ArchiveZip.java index 24af74258..1dd13a527 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ArchiveZip.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ArchiveZip.java @@ -1,6 +1,7 @@ package org.perlonjava.runtime.perlmodule; import org.perlonjava.runtime.operators.ReferenceOperators; +import org.perlonjava.runtime.regex.RuntimeRegex; import org.perlonjava.runtime.runtimetypes.*; import java.io.*; @@ -562,22 +563,32 @@ public static RuntimeList membersMatching(RuntimeArray args, int ctx) { } RuntimeHash self = args.get(0).hashDeref(); - String regex = args.get(1).toString(); + RuntimeScalar regex = args.get(1); + if (regex.type == RuntimeScalarType.HASHREFERENCE) { + RuntimeScalar hashRegex = regex.hashDeref().get("regex"); + if (hashRegex == null) { + return new RuntimeList(); + } + regex = hashRegex; + } RuntimeArray members = getMembers(self); RuntimeList result = new RuntimeList(); try { - java.util.regex.Pattern pattern = java.util.regex.Pattern.compile(regex); for (int i = 0; i < members.size(); i++) { RuntimeHash member = members.get(i).hashDeref(); RuntimeScalar memberName = member.get("_name"); - if (memberName != null && pattern.matcher(memberName.toString()).find()) { + if (memberName != null && RuntimeRegex.matchRegex( + regex, memberName, RuntimeContextType.SCALAR).scalar().getBoolean()) { result.add(members.get(i)); } } } catch (Exception e) { // Invalid regex, return empty list } + if (ctx == RuntimeContextType.SCALAR) { + return new RuntimeScalar(result.size()).getList(); + } return result; } @@ -1008,6 +1019,10 @@ public static RuntimeList contents(RuntimeArray args, int ctx) { } RuntimeScalar contents = member.get("_contents"); + if (ctx == RuntimeContextType.SCALAR) { + return (contents != null ? contents : scalarUndef).getList(); + } + // Return (content, status) in list context RuntimeList result = new RuntimeList(); result.add(contents != null ? contents : scalarUndef); diff --git a/src/main/perl/lib/Archive/Tar.pm b/src/main/perl/lib/Archive/Tar.pm index 2df0931e8..38e93712c 100644 --- a/src/main/perl/lib/Archive/Tar.pm +++ b/src/main/perl/lib/Archive/Tar.pm @@ -291,17 +291,17 @@ sub _get_handle { ### different reader/writer modules, different error vars... sigh if( MODE_READ->($mode) ) { - $fh = IO::Uncompress::Bunzip2->new( $file, MultiStream => 1 ) or do { + $fh = Compress::Bzip2::bzopen( $file, 'rb' ) or do { $self->_error( qq[Could not read '$file': ] . - $IO::Uncompress::Bunzip2::Bunzip2Error + $Compress::Bzip2::bzerrno ); return; }; } else { - $fh = IO::Compress::Bzip2->new( $file ) or do { + $fh = Compress::Bzip2::bzopen( $file, 'wb' ) or do { $self->_error( qq[Could not write to '$file': ] . - $IO::Compress::Bzip2::Bzip2Error + $Compress::Bzip2::bzerrno ); return; }; diff --git a/src/main/perl/lib/Archive/Tar/Constant.pm b/src/main/perl/lib/Archive/Tar/Constant.pm index 4612092ba..75b416557 100644 --- a/src/main/perl/lib/Archive/Tar/Constant.pm +++ b/src/main/perl/lib/Archive/Tar/Constant.pm @@ -75,8 +75,7 @@ use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and ### allow BZIP to be turned off using ENV: DEBUG only use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and - eval { require IO::Uncompress::Bunzip2; - require IO::Compress::Bzip2; }; + eval { require Compress::Bzip2; }; $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 }; diff --git a/src/main/perl/lib/Archive/Zip/MemberRead.pm b/src/main/perl/lib/Archive/Zip/MemberRead.pm new file mode 100644 index 000000000..5245bd23f --- /dev/null +++ b/src/main/perl/lib/Archive/Zip/MemberRead.pm @@ -0,0 +1,153 @@ +package Archive::Zip::MemberRead; + +use strict; +use warnings; + +use Archive::Zip qw(:ERROR_CODES); + +our $VERSION = '1.68'; + +my $nl = $^O eq 'MSWin32' ? "\r\n" : "\n"; +my $DEFAULT_BUFFER_SIZE = 32768; + +sub Archive::Zip::Member::readFileHandle { + return Archive::Zip::MemberRead->new(shift); +} + +sub new { + my ($class, $zip, $file) = @_; + my $member; + + if ($zip && $file) { + $member = ref($file) ? $file : $zip->memberNamed($file); + } + elsif ($zip && ref($zip)) { + $member = $zip; + } + else { + die 'Archive::Zip::MemberRead::new needs a zip and filename, zip and member, or member'; + } + + my $self = bless {}, $class; + $self->set_member($member); + return $self; +} + +sub set_member { + my ($self, $member) = @_; + $self->{member} = $member; + $self->{contents} = defined $member ? $member->contents : ''; + $self->rewind; +} + +sub setLineEnd { + shift; + $nl = shift; +} + +sub rewind { + my $self = shift; + $self->{offset} = 0; + $self->{line_no} = 0; + $self->{at_end} = 0; + delete $self->{buffer}; +} + +sub input_record_separator { + my $self = shift; + if (@_) { + $self->{sep} = shift; + $self->{sep_re} = _sep_as_re($self->{sep}); + } + return exists $self->{sep} ? $self->{sep} : $/; +} + +sub _sep_re { + my $self = shift; + return exists $self->{sep} ? $self->{sep_re} : _sep_as_re($/); +} + +sub _sep_as_re { + my $sep = shift; + if (defined $sep) { + if ($sep eq '') { + return "(?:$nl){2,}"; + } + else { + $sep =~ s/\n/$nl/og; + return quotemeta $sep; + } + } + return undef; +} + +sub input_line_number { + my $self = shift; + return $self->{line_no}; +} + +sub close { + my $self = shift; + $self->rewind; +} + +sub buffer_size { + my ($self, $size) = @_; + if (!$size) { + return $self->{chunkSize} || $DEFAULT_BUFFER_SIZE; + } + $self->{chunkSize} = $size; +} + +sub getline { + my ($self, $argref) = @_; + + my $size = $self->buffer_size; + my $sep = $self->_sep_re; + + my $preserve_line_ending; + if (ref $argref eq 'HASH') { + $preserve_line_ending = $argref->{preserve_line_ending}; + $sep =~ s/\\([^A-Za-z_0-9])+/$1/g if defined $sep; + } + + while (1) { + if (defined($sep) && defined($self->{buffer}) && $self->{buffer} =~ s/^(.*?)$sep//s) { + my $line = $1; + $self->{line_no}++; + return $preserve_line_ending ? $line . $sep : $line; + } + elsif ($self->{at_end}) { + $self->{line_no}++ if $self->{buffer}; + return delete $self->{buffer}; + } + + my $chunk; + my $read = $self->read($chunk, $size); + die 'ERROR: Error reading chunk from archive' unless defined $read; + $self->{at_end} = !$read; + $self->{buffer} .= $chunk if $read; + } +} + +sub read { + my $self = $_[0]; + my $size = $_[2]; + + return undef unless defined $self->{contents}; + $size = 0 unless defined $size; + + my $offset = $self->{offset} || 0; + my $available = length($self->{contents}) - $offset; + if ($available <= 0 || $size <= 0) { + $_[1] = ''; + return 0; + } + + my $bytes = $available < $size ? $available : $size; + $_[1] = substr($self->{contents}, $offset, $bytes); + $self->{offset} = $offset + $bytes; + return length($_[1]); +} + +1; diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index ccbba991f..bb64acb1a 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -230,6 +230,34 @@ match: patches: - "Net-Server-2.018/Proto.pm.patch" YAML + 'CPAN-FindDependencies.yml' => <<'YAML', +--- +comment: | + PerlOnJava distroprefs for CPAN::FindDependencies. + + CPAN::FindDependencies::MakeMaker uses fork/exec to run Makefile.PL + under a timeout while capturing output. PerlOnJava has no fork(), so + the helper either emits a TAP skip before tests run or execs Makefile.PL + in place and loses the parent process. Patch the helper to use a timed + subprocess when running under jperl. +match: + distribution: "^DCANTRELL/CPAN-FindDependencies-3\\.13" +patches: + - "CPAN-FindDependencies-3.13/MakeMaker.pm.patch" +YAML + ); + my %bundled_dd = ( + 'CPAN-FindDependencies.dd' => <<'DD', +$VAR1 = { + 'comment' => 'PerlOnJava distroprefs for CPAN::FindDependencies. Patch MakeMaker helper to avoid fork() under jperl.', + 'match' => { + 'distribution' => '^DCANTRELL/CPAN-FindDependencies-3\\.13' + }, + 'patches' => [ + 'CPAN-FindDependencies-3.13/MakeMaker.pm.patch' + ] +}; +DD ); # Create prefs directory if needed @@ -256,6 +284,20 @@ YAML close $fh; } } + for my $file (keys %bundled_dd) { + my $dest = File::Spec->catfile($prefs_dir, $file); + if (-f $dest) { + open my $rfh, '<', $dest or next; + my $existing = do { local $/; <$rfh> }; + close $rfh; + next unless $existing =~ /PerlOnJava/; + next if $existing eq $bundled_dd{$file}; + } + if (open my $fh, '>', $dest) { + print $fh $bundled_dd{$file}; + close $fh; + } + } } _bootstrap_prefs(); @@ -287,6 +329,39 @@ sub _bootstrap_patches { # Load just in time once explicitly invoked. PATCH + my $cpan_finddeps_makemaker_patch = <<'PATCH'; +--- lib/CPAN/FindDependencies/MakeMaker.pm.orig ++++ lib/CPAN/FindDependencies/MakeMaker.pm +@@ -61,6 +61,28 @@ sub getreqs_from_mm { + return "Makefile.PL didn't finish in a reasonable time\n"; + } + } else { ++ if ($Config{perlpath} =~ /(?:^|[\/\\])jperl(?:\.bat)?$/) { ++ my @cmd = ($Config{perlpath}, 'Makefile.PL'); ++ unshift(@cmd, 'timeout', '10') unless $^O eq 'MSWin32'; ++ my $status; ++ eval { capture { $status = system(@cmd); } }; ++ if ($@) { ++ chdir($cwd); ++ return $@; ++ } ++ ++ my $exit = defined($status) ? ($status >> 8) : -1; ++ if ($exit == 124) { ++ chdir($cwd); ++ return "Makefile.PL didn't finish in a reasonable time\n"; ++ } ++ ++ open($MKFH, 'Makefile') || warn "Can't read Makefile\n"; ++ my $makefile_str = <$MKFH>; ++ close($MKFH); ++ chdir($cwd); ++ return _parse_makefile( $makefile_str ); ++ } + # execute, suppressing noise ... + eval { capture { + if(my $pid = fork()) { # parent +PATCH # Map: target path relative to $patches_dir => source path inside the JAR # (or on-disk dev tree during `make`). The source is located via @INC. @@ -298,14 +373,23 @@ PATCH [ 'Net-Server-2.018/Proto.pm.patch', undef, $net_server_proto_patch ], + [ 'CPAN-FindDependencies-3.13/MakeMaker.pm.patch', + undef, + $cpan_finddeps_makemaker_patch ], ); - # Fast path: if every target exists, skip everything. + # Fast path: if every target exists and inline targets are current, skip everything. my $needs_write = 0; for my $pair (@bundled) { - my ($rel, undef) = @$pair; + my ($rel, undef, $inline_content) = @$pair; my $dest = File::Spec->catfile($patches_dir, $rel); unless (-f $dest) { $needs_write = 1; last } + if (defined $inline_content) { + open my $in, '<', $dest or do { $needs_write = 1; last }; + my $existing = do { local $/; <$in> }; + close $in; + if ($existing ne $inline_content) { $needs_write = 1; last } + } } return unless $needs_write; @@ -313,12 +397,16 @@ PATCH for my $pair (@bundled) { my ($rel, $src_rel, $inline_content) = @$pair; my $dest = File::Spec->catfile($patches_dir, $rel); - next if -f $dest; - my $dest_dir = File::Spec->catpath('', (File::Spec->splitpath($dest))[0,1]); File::Path::make_path($dest_dir) unless -d $dest_dir; if (defined $inline_content) { + if (-f $dest) { + open my $in, '<', $dest or next; + my $existing = do { local $/; <$in> }; + close $in; + next if $existing eq $inline_content; + } if (open my $out, '>', $dest) { print $out $inline_content; close $out; @@ -326,6 +414,8 @@ PATCH next; } + next if -f $dest; + # Locate the source file in @INC (finds either jar:PERL5LIB/… at # runtime or src/main/perl/lib/… during make/test). my $src; diff --git a/src/main/perl/lib/Compress/Bzip2.pm b/src/main/perl/lib/Compress/Bzip2.pm index 69b796d81..9bc3a468d 100644 --- a/src/main/perl/lib/Compress/Bzip2.pm +++ b/src/main/perl/lib/Compress/Bzip2.pm @@ -43,6 +43,28 @@ our @EXPORT_OK = ( map { @$_ } values %EXPORT_TAGS ); $EXPORT_TAGS{'all'} = [ @EXPORT_OK ]; our @EXPORT = qw(); +package Compress::Bzip2::bzFile; + +sub read { + my $self = $_[0]; + my $size = $_[2]; + $size = 4096 unless defined $size; + my $n = $self->bzread($_[1], $size); + return undef if !defined($n) || $n < 0; + return $n; +} + +sub close { + my $self = shift; + return $self->bzclose == 0; +} + +sub print { + my $self = shift; + my $data = join '', @_; + return $self->bzwrite($data) == length($data); +} + 1; __END__ diff --git a/src/test/resources/unit/archive_zip_members_matching_qr.t b/src/test/resources/unit/archive_zip_members_matching_qr.t new file mode 100644 index 000000000..920193668 --- /dev/null +++ b/src/test/resources/unit/archive_zip_members_matching_qr.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl +use strict; +use warnings; +use Test::More tests => 8; + +use Archive::Zip; + +my $zip = Archive::Zip->new(); +$zip->addString('{}', 'Fruit-Role-Fermentable-1.0/META.json'); +$zip->addString('package Fruit::Role::Fermentable;', 'Fruit-Role-Fermentable-1.0/lib/Fruit/Role/Fermentable.pm'); +$zip->addString('notes', 'README'); + +my $meta_re = qr/^([^\/]+\/)?META\.(json|yml)/; +my @meta = $zip->membersMatching($meta_re); +is(scalar(@meta), 1, 'membersMatching accepts qr// regex'); +is($meta[0]->fileName, 'Fruit-Role-Fermentable-1.0/META.json', 'qr// regex matched META file'); +is(scalar($zip->membersMatching($meta_re)), 1, 'membersMatching returns count in scalar context'); +is($zip->contents($meta[0]), '{}', 'zip contents returns member content in scalar context'); +is_deeply([$zip->contents($meta[0])], ['{}', 0], 'zip contents returns content and status in list context'); + +my @meta_hash = $zip->membersMatching({ regex => $meta_re }); +is(scalar(@meta_hash), 1, 'membersMatching accepts hash regex form'); + +my @modules = $zip->membersMatching(qr/\.pm\z/); +is($modules[0]->fileName, 'Fruit-Role-Fermentable-1.0/lib/Fruit/Role/Fermentable.pm', 'membersMatching uses Perl regex semantics'); + +my @plain = $zip->membersMatching('README'); +is($plain[0]->fileName, 'README', 'membersMatching still accepts string patterns');