From 704adfb320d517908ebaafca9da26204c7f8426d Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 16 May 2026 18:18:11 +0200 Subject: [PATCH 1/3] wip: snapshot before DBIx jcpan stabilization Captured pre-existing jcpan/PERL5LIB + DBIx/DBI/runtime edits before structured fix. Co-authored-by: Cursor --- jcpan | 6 + jcpan.bat | 7 + .../backend/bytecode/InterpretedCode.java | 7 +- .../perlonjava/runtime/perlmodule/DBI.java | 31 +- .../runtime/regex/RegexPreprocessor.java | 50 +- .../runtime/runtimetypes/RuntimeCode.java | 36 +- src/main/perl/lib/DBI.pm | 10 +- src/main/perl/lib/DBIx/Simple.pm | 1140 +++++++++++++++++ 8 files changed, 1259 insertions(+), 28 deletions(-) create mode 100644 src/main/perl/lib/DBIx/Simple.pm diff --git a/jcpan b/jcpan index 822f56b02..077da8af0 100755 --- a/jcpan +++ b/jcpan @@ -80,4 +80,10 @@ case "$JCPAN_BIN" in esac export PATH="$SCRIPT_DIR:$PATH" +# Bundled compat layers (see src/main/perl/lib/DBIx/Simple.pm). Must precede ~/.perlonjava/lib, +# which matches PERL5LIB's position in GlobalContext @INC construction. +if [[ -d "$SCRIPT_DIR/src/main/perl/lib" ]]; then + export PERL5LIB="$SCRIPT_DIR/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" +fi + exec "$SCRIPT_DIR/jperl" "$CPAN_SCRIPT" "${ARGS[@]}" diff --git a/jcpan.bat b/jcpan.bat index 788364bea..973233761 100644 --- a/jcpan.bat +++ b/jcpan.bat @@ -33,4 +33,11 @@ rem POSIX sh. See src/main/perl/lib/CPAN/Config.pm (Moose.yml). set "JPERL_BIN=%SCRIPT_DIR%jperl.bat" set "JCPAN_BIN=%SCRIPT_DIR%jcpan.bat" set "PATH=%SCRIPT_DIR%;%PATH%" +if exist "%SCRIPT_DIR%src\main\perl\lib" ( + if defined PERL5LIB ( + set "PERL5LIB=%SCRIPT_DIR%src\main\perl\lib;%PERL5LIB%" + ) else ( + set "PERL5LIB=%SCRIPT_DIR%src\main\perl\lib" + ) +) "%SCRIPT_DIR%jperl.bat" "%SCRIPT_DIR%src\main\perl\bin\cpan" %JCPAN_ARGS% diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index 1ef9cfcdd..7ac66ef37 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -293,7 +293,8 @@ public RuntimeList apply(RuntimeArray args, int callContext) { WarningBitsRegistry.pushCurrent(warningBitsString); } try { - return BytecodeInterpreter.execute(this, args, effectiveContext); + return RuntimeCode.coerceScalarCallResult( + BytecodeInterpreter.execute(this, args, effectiveContext), effectiveContext); } finally { if (warningBitsString != null) { WarningBitsRegistry.popCurrent(); @@ -318,7 +319,9 @@ public RuntimeList apply(String subroutineName, RuntimeArray args, int callConte WarningBitsRegistry.pushCurrent(warningBitsString); } try { - return BytecodeInterpreter.execute(this, args, effectiveContext, subroutineName); + return RuntimeCode.coerceScalarCallResult( + BytecodeInterpreter.execute(this, args, effectiveContext, subroutineName), + effectiveContext); } finally { if (warningBitsString != null) { WarningBitsRegistry.popCurrent(); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index b9da07d66..c4bf2ff58 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -738,8 +738,12 @@ public static RuntimeList disconnect(RuntimeArray args, int ctx) { } /** - * Finishes a statement handle, closing the underlying JDBC PreparedStatement. - * This releases database locks (e.g., SQLite table locks) held by the statement. + * Finishes a statement handle: drops any open {@link ResultSet} but keeps the + * {@link PreparedStatement} usable for subsequent {@code execute()} calls. + *

+ * Closing the JDBC {@code PreparedStatement} here breaks real DBI semantics and + * modules that recycle handles (DBIx::Simple statement cache, etc.). Perl's driver + * finish ends the active cursor, not the lifetime of the prepared statement. * * @param args RuntimeArray containing: * [0] - Statement handle (sth) @@ -749,23 +753,20 @@ public static RuntimeList disconnect(RuntimeArray args, int ctx) { public static RuntimeList finish(RuntimeArray args, int ctx) { RuntimeHash sth = args.get(0).hashDeref(); - // Close the JDBC PreparedStatement to release locks - RuntimeScalar stmtScalar = sth.get("statement"); - if (stmtScalar != null && stmtScalar.value instanceof PreparedStatement stmt) { + RuntimeScalar prevResultRef = sth.get("execute_result"); + if (prevResultRef != null && RuntimeScalarType.isReference(prevResultRef)) { try { - if (!stmt.isClosed()) { - stmt.close(); + RuntimeHash prevResult = prevResultRef.hashDeref(); + RuntimeScalar rsScalar = prevResult.get("resultset"); + if (rsScalar != null && rsScalar.value instanceof ResultSet rs) { + if (!rs.isClosed()) { + rs.close(); + } } - } catch (Exception e) { - // Ignore close errors — statement may already be closed + } catch (Exception ignored) { + // Best effort — cursor may already be closed } } - // Also close any open ResultSet - RuntimeScalar rsScalar = sth.get("execute_result"); - if (rsScalar != null && RuntimeScalarType.isReference(rsScalar)) { - Object rsObj = rsScalar.hashDeref(); - // execute_result may be stored differently; check raw value - } sth.put("Active", new RuntimeScalar(false)); return new RuntimeScalar(1).getList(); diff --git a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java index 5781391f6..de0e5e9ba 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java +++ b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java @@ -134,7 +134,55 @@ static String preProcessRegex(String s, RegexFlags regexFlags) { StringBuilder sb = new StringBuilder(); handleRegex(s, 0, sb, regexFlags, false); String result = sb.toString(); - return result; + return preferOmniHolderLiteralAlternation(result); + } + + /** + * Perl prefers the longest matching alternative when several branches succeed at the same + * offset; {@link Pattern} tries alternatives strictly left-to-right. DBIx::Simple's omniholder + * substitution uses {@code ($quoted|\(\?\?\))}: the nullable quoted repetition matches the empty + * string everywhere, so Java never reaches the literal {@code (??)} branch and SQL stays + * unchanged — JDBC then rejects {@code (??)} as invalid SQL. + *

+ * Detect the usual Java-preprocessed shape {@code ( (?FLAGS:(?:'…'|"…")*)|\(\?\?\) )} + * (single outer capturing group) and swap alternatives so the omniholder literal is tried + * first. + */ + static String preferOmniHolderLiteralAlternation(String javaPattern) { + final String omniBranch = "\\(\\?\\?\\)"; + final String needle = "|" + omniBranch; + if (javaPattern.length() < omniBranch.length() + 4 + || javaPattern.charAt(0) != '(' + || javaPattern.charAt(javaPattern.length() - 1) != ')') { + return javaPattern; + } + int pipeIdx = javaPattern.lastIndexOf(needle); + if (pipeIdx <= 1) { + return javaPattern; + } + int omniStart = pipeIdx + 1; + if (!javaPattern.startsWith(omniBranch, omniStart)) { + return javaPattern; + } + int closingParenIdx = omniStart + omniBranch.length(); + if (closingParenIdx != javaPattern.length() - 1 || javaPattern.charAt(closingParenIdx) != ')') { + return javaPattern; + } + String leftAlt = javaPattern.substring(1, pipeIdx); + // Narrow heuristic so arbitrary ( A | \(??\) ) patterns are untouched. + if (!looksLikeQuotedStarAlternate(leftAlt)) { + return javaPattern; + } + return "(" + omniBranch + "|" + leftAlt + ")"; + } + + /** Left branch produced from Perl {@code (?:'[^']*'|"[^"]*")*} plus inline (?FLAGS: … ). */ + private static boolean looksLikeQuotedStarAlternate(String leftAlt) { + if (!leftAlt.startsWith("(?")) { + return false; + } + // Typical preprocessing embeds both quote flavours inside a non-capturing cluster. + return leftAlt.contains("(?:'[^") && leftAlt.contains("|\"[^"); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index b11f36bd1..cec310c20 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -349,6 +349,27 @@ public static int effectiveCallContext(int callContext) { : callContext; } + /** + * Perl collapses a multi-value list returned from a subroutine when the callee runs in + * scalar context: only the last element survives as the actual return SV. PerlOnJava + * historically returned the raw {@link RuntimeList} and relied on the caller (e.g. + * chained {@code ->}) to call {@link RuntimeList#scalar()}, which ran too late — mortal + * temporaries from intermediate values (DBI execute results, etc.) could be flushed and + * tear down shared JDBC state before the outer method ran. + */ + public static RuntimeList coerceScalarCallResult(RuntimeList result, int effectiveContext) { + if (result == null) { + return null; + } + if (result instanceof RuntimeControlFlowList) { + return result; + } + if (effectiveContext == RuntimeContextType.SCALAR && result.elements.size() > 1) { + return new RuntimeList(result.scalar()); + } + return result; + } + public static boolean isLvalueCode(RuntimeCode code) { return code != null && code.attributes != null && code.attributes.contains("lvalue"); } @@ -2230,13 +2251,15 @@ private static RuntimeList callCachedInner(int callsiteId, MortalList.pushMark(); try { // Prefer PerlSubroutine interface over MethodHandle + RuntimeList out; if (cachedCode.subroutine != null) { - return cachedCode.subroutine.apply(a, effectiveContext); + out = cachedCode.subroutine.apply(a, effectiveContext); } else if (cachedCode.isStatic) { - return (RuntimeList) cachedCode.methodHandle.invoke(a, effectiveContext); + out = (RuntimeList) cachedCode.methodHandle.invoke(a, effectiveContext); } else { - return (RuntimeList) cachedCode.methodHandle.invoke(cachedCode.codeObject, a, effectiveContext); + out = (RuntimeList) cachedCode.methodHandle.invoke(cachedCode.codeObject, a, effectiveContext); } + return coerceScalarCallResult(out, effectiveContext); } finally { MortalList.popMark(); } @@ -3030,8 +3053,9 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int // caller's dynamic scope — e.g., after local $SIG{__WARN__} unwinds, // causing Test::Warn to miss warnings from DESTROY. MortalList.flushAboveMark(); + return result; } - return result; + return coerceScalarCallResult(result, effectiveContext); } } catch (PerlNonLocalReturnException e) { // Non-local return from map/grep block @@ -4011,7 +4035,7 @@ public RuntimeList apply(RuntimeArray a, int callContext) { } else { result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext); } - return result; + return coerceScalarCallResult(result, effectiveContext); } finally { if (warningBits != null) { WarningBitsRegistry.popCurrent(); @@ -4128,7 +4152,7 @@ public RuntimeList apply(String subroutineName, RuntimeArray a, int callContext) } else { result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext); } - return result; + return coerceScalarCallResult(result, effectiveContext); } finally { if (warningBits != null) { WarningBitsRegistry.popCurrent(); diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index 6553d24ac..3e17190cf 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -933,8 +933,11 @@ sub fetch { sub fetchall_arrayref { my ($sth, $slice, $max_rows) = @_; - # Return undef if statement handle is inactive - return undef unless $sth->{Database}{Active}; + # Match Perl DBI: gate on the sth's Active flag (pending/current result set), + # not Database->{Active} (dbh-level connection flag). JDBC-backed handles keep + # Database->{Active} accurate but clear sth->{Active} after DML executes; using + # Database here makes fetchall_arrayref spuriously return [] after SELECT execute(). + return undef unless $sth->{Active}; my @rows; my $row_count = 0; @@ -1001,8 +1004,7 @@ sub fetchall_arrayref { sub fetchall_hashref { my ($sth, $key_field) = @_; - # Return undef if statement handle is inactive - return undef unless $sth->{Database}{Active}; + return undef unless $sth->{Active}; my %results; diff --git a/src/main/perl/lib/DBIx/Simple.pm b/src/main/perl/lib/DBIx/Simple.pm new file mode 100644 index 000000000..3371c3857 --- /dev/null +++ b/src/main/perl/lib/DBIx/Simple.pm @@ -0,0 +1,1140 @@ +use 5.006; +use strict; +use DBI; +use Carp (); + +$DBIx::Simple::VERSION = '1.37'; +$Carp::Internal{$_} = 1 + for qw(DBIx::Simple DBIx::Simple::Result DBIx::Simple::DeadObject); + +my $no_raiseerror = $ENV{PERL_DBIX_SIMPLE_NO_RAISEERROR}; + +my $quoted = qr/(?:'[^']*'|"[^"]*")*/; # 'foo''bar' simply matches the (?:) twice +my $quoted_mysql = qr/(?:(?:[^\\']*(?:\\.[^\\']*)*)'|"(?:[^\\"]*(?:\\.[^\\"]*)*)")*/; + +my %statements; # "$db" => { "$st" => $st, ... } +my %old_statements; # "$db" => [ [ $query, $st ], ... ] +my %keep_statements; # "$db" => $int + +my $err_message = '%s no longer usable (because of %%s)'; +my $err_cause = '%s at %s line %d'; + +package DBIx::Simple; + +### private helper subs + +sub _dummy { bless \my $dummy, 'DBIx::Simple::Dummy' } +sub _swap { + my ($hash1, $hash2) = @_; + my $tempref = ref $hash1; + my $temphash = { %$hash1 }; + %$hash1 = %$hash2; + bless $hash1, ref $hash2; + %$hash2 = %$temphash; + bless $hash2, $tempref; +} + +### constructor + +sub connect { + my ($class, @arguments) = @_; + my $self = { lc_columns => 1, result_class => 'DBIx::Simple::Result' }; + if (defined $arguments[0] and UNIVERSAL::isa($arguments[0], 'DBI::db')) { + $self->{dont_disconnect} = 1; + $self->{dbh} = shift @arguments; + Carp::carp("Additional arguments for $class->connect are ignored") + if @arguments; + } else { + $arguments[3]->{PrintError} = 0 + unless defined $arguments[3] and exists $arguments[3]{PrintError}; + $arguments[3]->{RaiseError} = 1 + unless $no_raiseerror + or defined $arguments[3] and exists $arguments[3]{RaiseError}; + $self->{dbh} = DBI->connect(@arguments); + } + + return undef unless $self->{dbh}; + + $self->{dbd} = $self->{dbh}->{Driver}->{Name}; + bless $self, $class; + + $statements{$self} = {}; + $old_statements{$self} = []; + # PerlOnJava/JDBC: statement recycling is unsafe — finishing one Result invalidates the + # cached Perl DBI::st wrapper while Java keeps one PreparedStatement; the next recycle + # yields an undef sth and crashes DBIx::Simple::query (sqlite.t). + $keep_statements{$self} = DBI::_is_jdbc_handle($self->{dbh}) ? 0 : 16; + + return $self; +} + +sub new { + my ($class) = shift; + $class->connect(@_); +} + +### properties + +sub keep_statements : lvalue { $keep_statements{ $_[0] } } +sub lc_columns : lvalue { $_[0]->{lc_columns} } +sub result_class : lvalue { $_[0]->{result_class} } + +sub abstract : lvalue { + require SQL::Abstract; + $_[0]->{abstract} ||= SQL::Abstract->new; +} + +sub error { + my ($self) = @_; + return 'DBI error: ' . (ref $self ? $self->{dbh}->errstr : $DBI::errstr); +} + +sub dbh { $_[0]->{dbh} } + +### private methods + +# Replace (??) with (?, ?, ?, ...) +sub _replace_omniholder { + my ($self, $query, $binds) = @_; + return if $$query !~ /\(\?\?\)/; + my $omniholders = 0; + my $q = $self->{dbd} =~ /mysql/ ? $quoted_mysql : $quoted; + $$query =~ s[($q|\(\?\?\))] { + $1 eq '(??)' + ? do { + Carp::croak('There can be only one omniholder') + if $omniholders++; + '(' . join(', ', ('?') x @$binds) . ')' + } + : $1 + }eg; +} + +# Invalidate and clean up +sub _die { + my ($self, $cause) = @_; + + defined and $_->_die($cause, 0) + for values %{ $statements{$self} }, + map $$_[1], @{ $old_statements{$self} }; + delete $statements{$self}; + delete $old_statements{$self}; + delete $keep_statements{$self}; + + unless ($self->{dont_disconnect}) { + # Conditional, because destruction order is not guaranteed + # during global destruction. + $self->{dbh}->disconnect() if defined $self->{dbh}; + } + + _swap( + $self, + bless { + what => 'Database object', + cause => $cause + }, 'DBIx::Simple::DeadObject' + ) unless $cause =~ /DESTROY/; # Let's not cause infinite loops :) +} + +### public methods + +sub query { + my ($self, $query, @binds) = @_; + $self->{success} = 0; + + $self->_replace_omniholder(\$query, \@binds); + + my $st; + my $sth; + + my $old = $old_statements{$self}; + + if (defined( my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0] )) { + $st = splice(@$old, $i, 1)->[1]; + $sth = $st->{sth}; + } else { + eval { $sth = $self->{dbh}->prepare($query) } or do { + if ($@) { + $@ =~ s/ at \S+ line \d+\.\n\z//; + Carp::croak($@); + } + $self->{reason} = "Prepare failed ($DBI::errstr)"; + return _dummy; + }; + + # $self is quoted on purpose, to pass along the stringified version, + # and avoid increasing reference count. + $st = bless { + db => "$self", + sth => $sth, + query => $query + }, 'DBIx::Simple::Statement'; + $statements{$self}{$st} = $st; + } + + eval { $sth->execute(@binds) } or do { + if ($@) { + $@ =~ s/ at \S+ line \d+\.\n\z//; + Carp::croak($@); + } + + $self->{reason} = "Execute failed ($DBI::errstr)"; + return _dummy; + }; + + $self->{success} = 1; + + return bless { st => $st, lc_columns => $self->{lc_columns} }, $self->{result_class}; +} + +sub begin_work { $_[0]->{dbh}->begin_work } +sub begin { $_[0]->begin_work } +sub commit { $_[0]->{dbh}->commit } +sub rollback { $_[0]->{dbh}->rollback } +sub func { shift->{dbh}->func(@_) } + +sub last_insert_id { + my ($self) = @_; + + ($self->{dbi_version} ||= DBI->VERSION) >= 1.38 or Carp::croak( + "DBI v1.38 required for last_insert_id" . + "--this is only $self->{dbi_version}, stopped" + ); + + return shift->{dbh}->last_insert_id(@_); +} + +sub disconnect { + my ($self) = @_; + $self->_die(sprintf($err_cause, "$self->disconnect", (caller)[1, 2])); + return 1; +} + +sub DESTROY { + my ($self) = @_; + $self->_die(sprintf($err_cause, "$self->DESTROY", (caller)[1, 2])); +} + +### public methods wrapping SQL::Abstract + +for my $method (qw/select insert update delete/) { + no strict 'refs'; + *$method = sub { + my $self = shift; + return $self->query($self->abstract->$method(@_)); + } +} + +### public method wrapping SQL::Interp + +sub iquery { + require SQL::Interp; + my $self = shift; + return $self->query( SQL::Interp::sql_interp(@_) ); +} + +package DBIx::Simple::Dummy; + +use overload + '""' => sub { shift }, + bool => sub { 0 }; + +sub new { bless \my $dummy, shift } +sub AUTOLOAD { return } + +package DBIx::Simple::DeadObject; + +sub _die { + my ($self) = @_; + Carp::croak( + sprintf( + "(This should NEVER happen!) " . + sprintf($err_message, $self->{what}), + $self->{cause} + ) + ); +} + +sub AUTOLOAD { + my ($self) = @_; + Carp::croak( + sprintf( + sprintf($err_message, $self->{what}), + $self->{cause} + ) + ); +} +sub DESTROY { } + +package DBIx::Simple::Statement; + +sub _die { + my ($self, $cause, $save) = @_; + + $self->{sth}->finish() if defined $self->{sth}; + $self->{dead} = 1; + + my $stringy_db = "$self->{db}"; + my $stringy_self = "$self"; + + my $foo = bless { + what => 'Statement object', + cause => $cause + }, 'DBIx::Simple::DeadObject'; + + DBIx::Simple::_swap($self, $foo); + + my $old = $old_statements{ $foo->{db} }; + my $keep = $keep_statements{ $foo->{db} }; + + if ($save and $keep) { + $foo->{dead} = 0; + shift @$old until @$old + 1 <= $keep; + push @$old, [ $foo->{query}, $foo ]; + } + + delete $statements{ $stringy_db }{ $stringy_self }; +} + +sub DESTROY { + # This better only happen during global destruction... + return if $_[0]->{dead}; + $_[0]->_die('Ehm', 0); +} + +package DBIx::Simple::Result; + +sub _die { + my ($self, $cause) = @_; + if ($cause) { + $self->{st}->_die($cause, 1); + DBIx::Simple::_swap( + $self, + bless { + what => 'Result object', + cause => $cause, + }, 'DBIx::Simple::DeadObject' + ); + } else { + $cause = $self->{st}->{cause}; + DBIx::Simple::_swap( + $self, + bless { + what => 'Result object', + cause => $cause + }, 'DBIx::Simple::DeadObject' + ); + Carp::croak( + sprintf( + sprintf($err_message, $self->{what}), + $cause + ) + ); + } +} + +sub func { shift->{st}->{sth}->func(@_) } +sub attr { my $dummy = $_[0]->{st}->{sth}->{$_[1]} } + +sub columns { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $c = $_[0]->{st}->{sth}->{ $_[0]->{lc_columns} ? 'NAME_lc' : 'NAME' }; + return wantarray ? @$c : $c; +} + +sub bind { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + $_[0]->{st}->{sth}->bind_columns(\@_[1..$#_]); +} + + +### Single + +sub fetch { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return $_[0]->{st}->{sth}->fetch; +} + +sub into { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $sth = $_[0]->{st}->{sth}; + $sth->bind_columns(\@_[1..$#_]) if @_ > 1; + return $sth->fetch; +} + +sub list { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return $_[0]->{st}->{sth}->fetchrow_array if wantarray; + return($_[0]->{st}->{sth}->fetchrow_array)[-1]; +} + +sub array { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $row = $_[0]->{st}->{sth}->fetchrow_arrayref or return; + return [ @$row ]; +} + +sub hash { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return $_[0]->{st}->{sth}->fetchrow_hashref( + $_[0]->{lc_columns} ? 'NAME_lc' : 'NAME' + ); +} + +sub kv_list { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my @keys = $_[0]->columns; + my $values = $_[0]->array or return; + Carp::croak("Different numbers of column names and values") + if @keys != @$values; + return map { $keys[$_], $values->[$_] } 0 .. $#keys if wantarray; + return [ map { $keys[$_], $values->[$_] } 0 .. $#keys ]; +} + +sub kv_array { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + scalar shift->kv_list(@_); +} + +sub object { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $self = shift; + my $class = shift || ':RowObject'; + $class =~ s/^:/DBIx::Simple::Result::/; + if (not $class->can('new_from_dbix_simple') || $class->can('new')) { + (my $filename = "$class.pm") =~ s[::][/]g; + require $filename; + } + if ($class->can('new_from_dbix_simple')) { + return scalar $class->new_from_dbix_simple($self, @_); + } + if ($class->can('new')) { + return $class->new( $self->kv_list ); + } + Carp::croak( + qq(Can't locate object method "new_from_dbix_simple" or "new" ) . + qq(via package "$class".) + ); +} + +### Slurp + +sub flat { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return map @$_, $_[0]->arrays if wantarray; + return [ map @$_, $_[0]->arrays ]; +} + +sub arrays { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return @{ $_[0]->{st}->{sth}->fetchall_arrayref } if wantarray; + return $_[0]->{st}->{sth}->fetchall_arrayref; +} + +sub hashes { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my @return; + my $dummy; + push @return, $dummy while $dummy = $_[0]->hash; + return wantarray ? @return : \@return; +} + +sub kv_flat { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return map @$_, $_[0]->kv_arrays if wantarray; + return [ map @$_, $_[0]->kv_arrays ]; +} + +sub kv_arrays { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my @return; + my $dummy; + push @return, $dummy while $dummy = $_[0]->kv_array; + return wantarray ? @return : \@return; +} + +sub objects { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $self = shift; + my $class = shift || ':RowObject'; + $class =~ s/^:/DBIx::Simple::Result::/; + if (not $class->can('new_from_dbix_simple') || $class->can('new')) { + (my $package = "$class.pm") =~ s[::][/]g; + require $package; + } + if ($class->can('new_from_dbix_simple')) { + return $class->new_from_dbix_simple($self, @_) if wantarray; + return [ $class->new_from_dbix_simple($self, @_) ]; + } + if ($class->can('new')) { + return map { $class->new( @$_ ) } $self->kv_arrays if wantarray; + return [ map { $class->new( @$_ ) } $self->kv_arrays ]; + } + Carp::croak( + qq(Can't locate object method "new_from_dbix_simple" or "new" ) . + qq(via package "$class" (perhaps you forgot to load "$class"?)) + ); +} + +sub _map { + my ($keys, $values) = @_; + my %return; + @return{@$keys} = @$values; + return wantarray ? %return : \%return; +} + +sub _group { + my ($keys, $values) = @_; + my %return; + push @{ $return{shift @$keys} }, shift @$values while @$values; + return wantarray ? %return : \%return; +} + +sub _keys_and_hashes { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my ($self, $keyname) = @_; + Carp::croak('Key column name not optional') if not defined $keyname; + my @rows = $self->hashes; + my @keys; + push @keys, delete $_->{$keyname} for @rows; + return \@keys, \@rows; +} + +sub _keys_and_arrays { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my ($self, $keyindex) = @_; + $keyindex += 0; + my @rows = $self->arrays; + my @keys; + push @keys, splice @$_, $keyindex, 1 for @rows; + return \@keys, \@rows; +} + +sub group_hashes { return _group shift->_keys_and_hashes(@_) } +sub map_hashes { return _map shift->_keys_and_hashes(@_) } +sub group_arrays { return _group shift->_keys_and_arrays(@_) } +sub map_arrays { return _map shift->_keys_and_arrays(@_) } + +sub map { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + return map @$_, @{ $_[0]->{st}->{sth}->fetchall_arrayref } if wantarray; + return { map @$_, @{ $_[0]->{st}->{sth}->fetchall_arrayref } }; +} + +sub group { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my %return; + while (my $row = $_[0]->fetch) { + push @{ $return{ $row->[0] } }, $row->[1]; + } + return wantarray ? %return : \%return; +} + +sub rows { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + $_[0]->{st}->{sth}->rows; +} + +sub xto { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + require DBIx::XHTML_Table; + my $self = shift; + my $attr = ref $_[0] ? $_[0] : { @_ }; + + # Old DBD::SQLite (.29) spits out garbage if done *after* fetching. + my $columns = $self->{st}->{sth}->{NAME}; + + return DBIx::XHTML_Table->new( + scalar $self->arrays, + $columns, + $attr + ); +} + +sub html { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my $self = shift; + my $attr = ref $_[0] ? $_[0] : { @_ }; + return $self->xto($attr)->output($attr); +} + +sub text { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my ($self, $type) = @_; + my $text_table = defined $type && length $type + ? 0 + : eval { require Text::Table; $type = 'table'; 1 }; + $type ||= 'neat'; + if ($type eq 'box' or $type eq 'table') { + my $box = $type eq 'box'; + $text_table or require Text::Table; + my @columns = map +{ title => $_, align_title => 'center' }, + @{ $self->{st}->{sth}->{NAME} }; + my $c = 0; + splice @columns, $_ + $c++, 0, \' | ' for 1 .. $#columns; + my $table = Text::Table->new( + ($box ? \'| ' : ()), + @columns, + ($box ? \' |' : ()) + ); + $table->load($self->arrays); + my $rule = $table->rule(qw/- +/); + return join '', + ($box ? $rule : ()), + $table->title, $rule, $table->body, + ($box ? $rule : ()); + } + Carp::carp("Unknown type '$type'; using 'neat'") if $type ne 'neat'; + return join '', map DBI::neat_list($_) . "\n", $self->arrays; +} + +sub finish { + $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my ($self) = @_; + $self->_die( + sprintf($err_cause, "$self->finish", (caller)[1, 2]) + ); +} + +sub DESTROY { + return if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject'; + my ($self) = @_; + $self->_die( + sprintf($err_cause, "$self->DESTROY", (caller)[1, 2]) + ); +} + +1; + +__END__ + +=head1 NAME + +DBIx::Simple - Very complete easy-to-use OO interface to DBI + +=head1 SYNOPSIS + +=head2 DBIx::Simple + + $db = DBIx::Simple->connect(...) # or ->new + + $db->keep_statements = 16 + $db->lc_columns = 1 + $db->result_class = 'DBIx::Simple::Result'; + + $db->begin_work $db->commit + $db->rollback $db->disconnect + $db->func(...) $db->last_insert_id + + $result = $db->query(...) + +=head2 DBIx::SImple + SQL::Interp + + $result = $db->iquery(...) + +=head2 DBIx::Simple + SQL::Abstract + + $db->abstract = SQL::Abstract->new(...) + + $result = $db->select(...) + $result = $db->insert(...) + $result = $db->update(...) + $result = $db->delete(...) + +=head2 DBIx::Simple::Result + + @columns = $result->columns + + $result->into($foo, $bar, $baz) + $row = $result->fetch + + @row = $result->list @rows = $result->flat + $row = $result->array @rows = $result->arrays + $row = $result->hash @rows = $result->hashes + @row = $result->kv_list @rows = $result->kv_flat + $row = $result->kv_array @rows = $result->kv_arrays + $obj = $result->object @objs = $result->objects + + %map = $result->map %grouped = $result->group + %map = $result->map_hashes(...) %grouped = $result->group_hashes(...) + %map = $result->map_arrays(...) %grouped = $result->group_arrays(...) + + $rows = $result->rows + + $dump = $result->text + + $result->finish + +=head2 DBIx::Simple::Result + DBIx::XHTML_Table + + $html = $result->html(...) + + $table_object = $result->xto(...) + +=head2 Examples + +Please read L for code examples. + +=head1 DESCRIPTION + +DBIx::Simple provides a simplified interface to DBI, Perl's powerful database +module. + +This module is aimed at rapid development and easy maintenance. Query +preparation and execution are combined in a single method, the result object +(which is a wrapper around the statement handle) provides easy row-by-row and +slurping methods. + +The C method returns either a result object, or a dummy object. The +dummy object returns undef (or an empty list) for all methods and when used in +boolean context, is false. The dummy object lets you postpone (or skip) error +checking, but it also makes immediate error checking simply C<< +$db->query(...) or die $db->error >>. + +=head2 DBIx::Simple methods + +=head3 Class methods + +=over 14 + +=item C, C + +=item C, C + +The C or C class method takes either an existing DBI object +($dbh), or a list of arguments to pass to C<< DBI->connect >>. See L for a +detailed description. + +You cannot use this method to clone a DBIx::Simple object: the $dbh passed +should be a DBI::db object, not a DBIx::Simple object. + +For new connections, PrintError is disabled by default. If you enable it, +beware that it will report line numbers in DBIx/Simple.pm. + +For new connections, B unless the environment +variable C is set to a non-empty non-0 value. + +This method is the constructor and returns a DBIx::Simple object on success. On +failure, it returns undef. + +=back + +=head3 Object methods + +=over 14 + +=item C + +Prepares and executes the query and returns a result object. + +If the string C<(??)> is present in the query, it is replaced with a list of as +many question marks as @values. + +The database drivers substitute placeholders (question marks that do not appear +in quoted literals) in the query with the given @values, after them escaping +them. You should always use placeholders, and never use raw user input in +database queries. + +On success, returns a DBIx::Simple::Result object. On failure, returns a +DBIx::Simple::Dummy object. + +=item C + +Uses SQL::Interp to interpolate values into a query, and uses the resulting +generated query and bind arguments with C. See SQL::Interp's +documentation for usage information. + +Requires Mark Stosberg's SQL::Interp, which is available from CPAN. SQL::Interp +is a fork from David Manura's SQL::Interpolate. + +=item C, C, C and C +methods. On first access, will create one with SQL::Abstract's default options. + +Requires Nathan Wiger's SQL::Abstract, which is available from CPAN. + +In theory, you can assign any object to this property, as long as that object +has these four methods, and they return a list suitable for use with the +C method. + +=back + +=head2 DBIx::Simple::Dummy + +The C method of DBIx::Simple returns a dummy object on failure. Its +methods all return an empty list or undef, depending on context. When used in +boolean context, a dummy object evaluates to false. + +=head2 DBIx::Simple::Result methods + +Methods documented to return "a list" return a reference to an array of the +same in scalar context, unless something else is explicitly mentioned. + +=over 14 + +=item C + +Returns a list of column names. Affected by C. + +=item C + +Binds the given LIST of variables to the columns. Unlike with DBI's +C, passing references is not needed. + +Bound variables are very efficient. Binding a tied variable doesn't work. + +=item C + +Returns a copy of an sth attribute (property). See L for details. + +=item C + +This calls the C method on the sth of DBI. See L for details. + +=item C + +Returns the number of rows affected by the last row affecting command, or -1 if +the number of rows is not known or not available. + +For SELECT statements, it is generally not possible to know how many rows are +returned. MySQL does provide this information. See L for a detailed +explanation. + +=item C + +Finishes the statement. After finishing a statement, it can no longer be used. +When the result object is destroyed, its statement handle is automatically +finished and destroyed. There should be no reason to call this method +explicitly; just let the result object go out of scope. + +=back + +=head3 Fetching a single row at a time + +=over 14 + +=item C + +Returns a reference to the array that holds the values. This is the same array +every time. + +Subsequent fetches (using any method) may change the values in the variables +passed and the returned reference's array. + +=item C + +Combines C with C. Returns what C returns. + +=item C + +Returns a list of values, or (in scalar context), only the last value. + +=item C + +Returns a reference to an array. + +=item C + +Returns a reference to a hash, keyed by column name. Affected by C. + +=item C + +Returns an ordered list of interleaved keys and values. Affected by +C. + +=item C + +Returns a reference to an array of interleaved column names and values. Like +kv, but returns an array reference even in list context. Affected by +C. + +=item C + +Returns an instance of $class. See "Object construction". Possibly affected by +C. + +=back + +=head3 Fetching all remaining rows + +=over 14 + +=item C + +Returns a flattened list. + +=item C + +Returns a list of references to arrays + +=item C + +Returns a list of references to hashes, keyed by column name. Affected by +C. + +=item C + +Returns an flattened list of interleaved column names and values. Affected by +C. + +=item C + +Returns a list of references to arrays of interleaved column names and values. +Affected by C. + +=item C + +Returns a list of instances of $class. See "Object construction". Possibly +affected by C. + +=item C + +=item C + +Constructs a simple hash, using the two columns as key/value pairs. Should only +be used with queries that return two columns. Returns a list of interleaved +keys and values, or (in scalar context), a reference to a hash. + +With unique keys, use C. With non-unique keys, use C, which gives +an array of values per key. + +=item C + +=item C + +Constructs a hash keyed by the values in the chosen column, and returns a list +of interleaved keys and values, or (in scalar context), a reference to a hash. +Affected by C. + +With unique keys, use C, which gives a single hash per key. With +non-unique keys, use C, which gives an array of hashes per key. + +=item C + +=item C + +Constructs a hash keyed by the values in the chosen column, and returns a list +of interleaved keys and values, or (in scalar context), a reference to a hash. + +With unique keys, use C, which gives a single array per key. With +non-unique keys, use C, which gives an array of arrays per key. + +=item C + +Returns a DBIx::XHTML_Table object, passing the constructor a reference to +C<%attr>. + +Requires Jeffrey Hayes Anderson's DBIx::XHTML_Table, which is available from +CPAN. + +In general, using the C method (described below) is much easier. C +is available in case you need more flexibility. Not affected by C. + +=item C + +Returns an (X)HTML formatted table, using the DBIx::XHTML_Table module. Passes +a reference to C<%attr> to both the constructor and the C method. + +Requires Jeffrey Hayes Anderson's DBIx::XHTML_Table, which is available from +CPAN. + +This method is a shortcut method. That means that + + $result->html + + $result->html( + tr => { bgcolor => [ 'silver', 'white' ] }, + no_ucfirst => 1 + ) + +do the same as: + + $result->xto->output + + $result->xto( + tr => { bgcolor => [ 'silver', 'white' ] } + )->output( + no_ucfirst => 1 + ); + +=item C + +Returns a string with a simple text representation of the data. C<$type> +can be any of: C, C, C. It defaults to C
if +Text::Table is installed, to C if it isn't. + +C
and C require Anno Siegel's Text::Table, which is available from +CPAN. + +=back + +=head2 Object construction + +DBIx::Simple has basic support for returning results as objects. The actual +construction method has to be provided by the chosen class, making this +functionality rather advanced and perhaps unsuited for beginning programmers. + +When the C or C method is called on the result object returned +by one of the query methods, two approaches are tried. In either case, pass the +name of a class as the first argument. A prefix of a single colon can be used +as an alias for C, e.g. C<":Example"> is short for +C<"DBIx::Simple::Result::Example">. Modules are loaded on demand. + +The default class when no class is given, is C<:RowObject>. It requires Jos +Boumans' Object::Accessor, which is available from CPAN. + +=head3 Simple object construction + +When C is given a class that provides a C method, but not a +C method, C is called with a list of interleaved +column names and values, like a flattened hash, but ordered. C causes +C to be called multiple times, once for each remaining row. + +Example: + + { + package DBIx::Simple::Result::ObjectExample; + sub new { + my ($class, %args) = @_; + return bless $class, \%args; + } + + sub foo { ... } + sub bar { ... } + } + + + $db->query('SELECT foo, bar FROM baz')->object(':ObjectExample')->foo(); + +=head3 Advanced object construction + +When C or C is given a class that provides a +C method, any C is ignored, and +C is called with a list of the DBIx::Simple::Result +object and any arguments passed to C or C. + +C is called in scalar context for C, and in list +context for C. In scalar context, it should fetch I, +and in list context, it should fetch I. + +Example: + + { + package DBIx::Simple::Result::ObjectExample; + sub new_from_dbix_simple { + my ($class, $result, @args) = @_; + return map { bless $class, $_ } $result->hashes if wantarray; + return bless $class, $result->hash; + } + + sub foo { ... } + sub bar { ... } + } + + $db->query('SELECT foo, bar FROM baz')->object(':ObjectExample')->foo(); + +=head1 MISCELLANEOUS + +The mapping methods do not check whether the keys are unique. Rows that are +fetched later overwrite earlier ones. + +=head1 LICENSE + +Pick your favourite OSI approved license :) + +http://www.opensource.org/licenses/alphabetical + +=head1 AUTHOR + +Juerd Waalboer <#####@juerd.nl> + +=head1 SEE ALSO + +L, L + +L, L, L, L + +=cut + From e05f7ffe120f37bf268e5b81a351899f34749c35 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 16 May 2026 18:50:17 +0200 Subject: [PATCH 2/3] fix: jcpan DBIx::Simple chain + JDBC fetchrow_hashref NAME_lc - Hold blessed method invocants across dispatchPerlMethodAfterSelfInjected / callCachedInner refcount boundaries (scalar $db->query->arrays). - JDBC fetchrow_hashref honors second arg and NAME fallback like DBI.pm. - Add dev/tools/dbix_simple_chain_repro.pl and dev/modules/dbix_simple.md. - Unit regression: dbi_fetchrow_hashref_name_lc.t. Generated with [Cursor](https://cursor.com/docs) Co-Authored-By: Cursor --- dev/modules/dbix_simple.md | 99 +++++++++++++++ dev/tools/dbix_simple_chain_repro.pl | 43 +++++++ .../perlonjava/runtime/perlmodule/DBI.java | 52 +++++++- .../runtime/runtimetypes/RuntimeCode.java | 120 ++++++++++++++---- .../unit/dbi_fetchrow_hashref_name_lc.t | 34 +++++ 5 files changed, 319 insertions(+), 29 deletions(-) create mode 100644 dev/modules/dbix_simple.md create mode 100644 dev/tools/dbix_simple_chain_repro.pl create mode 100644 src/test/resources/unit/dbi_fetchrow_hashref_name_lc.t diff --git a/dev/modules/dbix_simple.md b/dev/modules/dbix_simple.md new file mode 100644 index 000000000..70ead9f92 --- /dev/null +++ b/dev/modules/dbix_simple.md @@ -0,0 +1,99 @@ +# jcpan DBIx::Simple stabilization + +## Overview + +`./jcpan -t DBIx::Simple` exercises the vendored OO DBI wrapper bundled under +[`src/main/perl/lib/DBIx/Simple.pm`](../../src/main/perl/lib/DBIx/Simple.pm). +The [`jcpan`](../../jcpan) launcher prepends that tree to `PERL5LIB`, so jcpan runs +prefer the JDBC-aware fork over stale copies under `~/.perlonjava/lib`. + +## Symptoms + +| Layer | When it bites | Symptoms | +| ----- | ------------- | ------- | +| A. Wrong `@INC` / old `Simple.pm` | `./jperl` without bundled `PERL5LIB`; first hit is `~/.perlonjava/lib/DBIx/Simple.pm` | `keep_statements` stays **16**, `old_statements` recycling clashes with JDBC `finish`/`execute_result` semantics → **`execute` on undef** after chained queries, bogus row counts | +| B. JVM method-chain lifetime | Bundled Simple (`keep_statements == 0` on JDBC) | **`scalar $db->query($sql)->arrays`** returns **too few rows** vs **`my $r = $db->query($sql); scalar $r->arrays`** for the same SQL | +| C. JDBC `fetchrow_hashref` | Upstream **`t/sqlite.t`** with `lc_columns` (default hash keys **`foo`** not **`FOO`**) | **`fetchrow_hashref`** ignored **`NAME_lc`** / **`'NAME_lc'`** argument — hashes missing expected keys | + +Layer B points at PerlOnJava **`scalar` / `->` / mortal or refcount boundaries**, not DBIx `wantarray` in `arrays` alone. + +## Reproduction + +Always prefer the same library order jcpan uses: + +```bash +export PERL5LIB="$PWD/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" +timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl +``` + +Smoke compare with system ordering (may load `~/.perlonjava/lib`): + +```bash +timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl +``` + +Minimal inline check (`keep_statements` must be **0** on JDBC): + +```bash +PERL5LIB="$PWD/src/main/perl/lib" ./jperl -e 'use DBIx::Simple; use DBI; \ + my $db=DBIx::Simple->connect(q{dbi:SQLite:dbname=:memory:},"","",{RaiseError=>1}); \ + print "keep=".$db->keep_statements."\n"' +``` + +Full module test harness (agents: **wrap jcpan** in `timeout`; capture TAP to a file). +Bundled **`DBIx/Simple.pm`** skips upstream **`t/`** unless you force it: + +```bash +JCPAN_RUN_BUNDLED_TESTS=1 timeout 3600 ./jcpan -t DBIx::Simple > /tmp/jcpan_dbix_simple.txt 2>&1 +echo EXIT:$? >> /tmp/jcpan_dbix_simple.txt +``` + +## JDBC /statement notes (bundled fork) + +SQLite on PerlOnJava uses JDBC. Recycling finished statement wrappers while the +same `PreparedStatement` is reused is unsafe; bundled `Simple.pm` forces +`keep_statements = 0` when [`DBI::_is_jdbc_handle`](../../src/main/perl/lib/DBI.pm) +returns true (`connection`/`statement`/`ImplementorClass` heuristics). + +## Resolution log + +| Date | Change | +| ---- | ------ | +| 2026-05-16 | Added this doc + `dev/tools/dbix_simple_chain_repro.pl`; jcpan **`PERL5LIB`** prepend documented upstream in `jcpan` comments. **Layer B**: blessed method-call invocant **refcount hold** across `dispatchPerlMethodAfterSelfInjected` / `callCachedInner` (`RuntimeCode.java`). **Layer C**: JDBC **`DBI.fetchrow_hashref`** honors the optional **second argument** (`NAME_lc`) like `DBI.pm`, fixing **`t/sqlite.t`** hash key expectations under bundled tests. | + +## `RuntimeCode.coerceScalarCallResult` + +Collapsing multi-return lists at subroutine boundaries matches Perl semantics +and avoids late `RuntimeList.scalar()` on intermediates (see inline comment in +`RuntimeCode`). It alone did **not** fix Layer B; keep it unless regressions justify +narrowing/reverting after the JDBC chain fix lands. + +## Next steps + +### Implemented in this iteration (carry forward checklist) + +| Item | Status | +| ---- | ------ | +| Document layers A/B/C + repro + bundled jcpan knobs | ✓ [`dev/modules/dbix_simple.md`](dbix_simple.md) | +| Repro harness | ✓ [`dev/tools/dbix_simple_chain_repro.pl`](../../dev/tools/dbix_simple_chain_repro.pl) | +| Layer B — blessed invocant refcount across method dispatch | ✓ [`RuntimeCode.java`](../../src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java) | +| Layer C — JDBC `fetchrow_hashref($sth, 'NAME_lc')` | ✓ [`DBI.java`](../../src/main/java/org/perlonjava/runtime/perlmodule/DBI.java) | +| Regression test for Layer C (`NAME_lc` keys) | ✓ [`unit/dbi_fetchrow_hashref_name_lc.t`](../../src/test/resources/unit/dbi_fetchrow_hashref_name_lc.t) | + +### After merge / ongoing + +1. **CI / review** — Ensure PR **`make`** and any Cloud CI workflows are green before merge. + +2. **Bundled jcpan smoke** — Default `./jcpan -t DBIx::Simple` still skips upstream `t/` when `Simple.pm` is bundled; for full parity use: + ```bash + JCPAN_RUN_BUNDLED_TESTS=1 timeout 3600 ./jcpan -t DBIx::Simple > /tmp/jcpan_dbix_simple.txt 2>&1 + ``` + +3. **Interpreter parity** (only if regressions reported) — Run the chain repro under `./jperl --interpreter` and compare row counts vs JVM. + +4. **Optional follow-ups** — If Layer B surfaces again elsewhere, revisit `scalar`/method-chain lowering (e.g. `Dereference` / late `scalar()` collapse) alongside `MortalList` boundaries; extend unit coverage for `FetchHashKeyName` / `NAME_uc` only if bugs appear. + +## References + +- [`AGENTS.md`](../../AGENTS.md) — jcpan/`timeout`, no orphan JVMs. +- [`dev/modules/jcpan_bundled_dbd_and_convert_ber.md`](jcpan_bundled_dbd_and_convert_ber.md) — bundled-module test knobs. diff --git a/dev/tools/dbix_simple_chain_repro.pl b/dev/tools/dbix_simple_chain_repro.pl new file mode 100644 index 000000000..0cf762166 --- /dev/null +++ b/dev/tools/dbix_simple_chain_repro.pl @@ -0,0 +1,43 @@ +#!/usr/bin/env perl +# Repro for DBIx::Simple chained query vs temporaries on PerlOnJava (see dev/modules/dbix_simple.md). +# Run with bundled lib first: +# PERL5LIB="$PWD/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl + +use strict; +use warnings; + +use DBIx::Simple (); + +my $db = DBIx::Simple->connect( 'dbi:SQLite:dbname=:memory:', '', '', + { RaiseError => 1 } ); + +print STDERR "keep_statements=", $db->keep_statements, "\n"; + +$db->query(q{CREATE TABLE t (id INTEGER NOT NULL)}); +$db->query(q{INSERT INTO t VALUES (1),(2),(3)}); + +my $chain_ref = + scalar $db->query('SELECT id FROM t ORDER BY id')->arrays; + +my $r = $db->query('SELECT id FROM t ORDER BY id'); +my $stored_ref = scalar $r->arrays; + +die "chain: expected ARRAY ref, got " + . ( defined $chain_ref ? ref $chain_ref || 'plain scalar' : 'undef' ) + unless ref($chain_ref) eq 'ARRAY'; + +die "stored: expected ARRAY ref, got " + . ( defined $stored_ref ? ref $stored_ref || 'plain scalar' : 'undef' ) + unless ref($stored_ref) eq 'ARRAY'; + +my $chain_n = scalar @$chain_ref; +my $stored_n = scalar @$stored_ref; + +print "chain_rows=$chain_n stored_rows=$stored_n\n"; + +if ( $chain_n != $stored_n ) { + die "FAIL: scalar \\\$db->query(...)->arrays row count mismatch " + . "(stored=$stored_n, chain=$chain_n)\n"; +} + +print "OK\n"; diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index c4bf2ff58..611e9df20 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -599,6 +599,25 @@ public static RuntimeList fetchrow_arrayref(RuntimeArray args, int ctx) { }, dbh, "fetchrow_arrayref"); } + /** Like Perl: {@code $sth->{$key} || $sth->{NAME}} for column label arrays. */ + private static RuntimeArray columnNamesAttribute(RuntimeHash sth, String key) { + if (sth == null) { + return null; + } + String[] tryKeys = "NAME".equals(key) ? new String[] {"NAME"} : new String[] {key, "NAME"}; + for (String k : tryKeys) { + RuntimeScalar ref = sth.get(k); + if (ref == null || ref.type == RuntimeScalarType.UNDEF) { + continue; + } + RuntimeArray arr = ref.arrayDeref(); + if (arr != null && !arr.isEmpty()) { + return arr; + } + } + return null; + } + /** * Fetches the next row from a result set as a hash reference. * @@ -632,16 +651,39 @@ public static RuntimeList fetchrow_hashref(RuntimeArray args, int ctx) { RuntimeHash row = new RuntimeHash(); ResultSetMetaData metaData = rs.getMetaData(); - // Get the column name style to use - String nameStyle = sth.get("FetchHashKeyName").toString(); - if (nameStyle.isEmpty()) { + // Match DBI.pm: fetchrow_hashref($sth, $name) reads $sth->{$name || FetchHashKeyName || 'NAME'} + String nameStyle = null; + if (args.size() > 1) { + RuntimeScalar nameArg = args.get(1); + if (nameArg != null && nameArg.type != RuntimeScalarType.UNDEF) { + String explicit = nameArg.toString(); + if (explicit != null && !explicit.isEmpty()) { + nameStyle = explicit; + } + } + } + if (nameStyle == null) { + RuntimeScalar fk = sth.get("FetchHashKeyName"); + if (fk != null && fk.type != RuntimeScalarType.UNDEF) { + String s = fk.toString(); + if (!s.isEmpty()) { + nameStyle = s; + } + } + } + if (nameStyle == null) { nameStyle = "NAME"; } - RuntimeArray columnNames = sth.get(nameStyle).arrayDeref(); + int colCount = metaData.getColumnCount(); + RuntimeArray columnNames = columnNamesAttribute(sth, nameStyle); + if (columnNames == null || columnNames.size() < colCount) { + throw new IllegalStateException( + "fetchrow_hashref: missing column NAME list for key \"" + nameStyle + "\""); + } // For each column, add column name -> value pair to hash. // See fetchrow_arrayref for rationale on UTF-8 encode to BYTE_STRING. - for (int i = 1; i <= metaData.getColumnCount(); i++) { + for (int i = 1; i <= colCount; i++) { String columnName = columnNames.get(i - 1).toString(); Object value = rs.getObject(i); RuntimeScalar val; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index cec310c20..3747a237b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -370,6 +370,48 @@ public static RuntimeList coerceScalarCallResult(RuntimeList result, int effecti return result; } + /** + * Keep the blessed invocant's referent alive for the duration of a method dispatch. + * Nested {@code MortalList.flushAboveMark()} (e.g. from {@link RuntimeScalar#set}) + * can otherwise dequeue deferred decrements and run DESTROY on chain temporaries such as + * {@code $db->query(...)->arrays} mid-callee — JDBC cursors appear truncated vs a lexical + * holding the intermediate result (DBIx::Simple). + */ + private static RuntimeBase acquireMethodInvocantHold(RuntimeScalar runtimeScalar) { + RuntimeScalar v = runtimeScalar; + while (v != null && v.type == RuntimeScalarType.READONLY_SCALAR) { + v = (RuntimeScalar) v.value; + } + if (v == null || !RuntimeScalarType.isReference(v)) { + return null; + } + if (!(v.value instanceof RuntimeBase base)) { + return null; + } + if (base.blessId == 0) { + return null; + } + if (base.refCount == Integer.MIN_VALUE || base.currentlyDestroying) { + return null; + } + if (base.refCount < 0) { + return null; + } + base.traceRefCount(+1, "RuntimeCode.method invocant hold (+1)"); + base.refCount++; + return base; + } + + private static void releaseMethodInvocantHold(RuntimeBase holdBase) { + if (holdBase == null) { + return; + } + holdBase.traceRefCount(-1, "RuntimeCode.method invocant hold release (-1)"); + if (holdBase.refCount > 0 && holdBase.refCount != Integer.MIN_VALUE && !holdBase.currentlyDestroying) { + holdBase.refCount--; + } + } + public static boolean isLvalueCode(RuntimeCode code) { return code != null && code.attributes != null && code.attributes.contains("lvalue"); } @@ -2203,6 +2245,8 @@ private static RuntimeList callCachedInner(int callsiteId, return callCached(callsiteId, runtimeScalar.tiedFetch(), method, currentSub, args, callContext); } + RuntimeBase pjMethodInvHold = acquireMethodInvocantHold(runtimeScalar); + try { // Fast path: check inline cache for monomorphic call sites if (method.type == RuntimeScalarType.STRING || method.type == RuntimeScalarType.BYTE_STRING) { // Unwrap READONLY_SCALAR for blessId check (same as in call()) @@ -2317,34 +2361,30 @@ private static RuntimeList callCachedInner(int callsiteId, } } - // Fall back to regular call - return call(runtimeScalar, method, currentSub, args, callContext); + // Fall back without nesting through call(...) — avoids double refcount hold + // (this outer frame already holds the invocant for the inlined-cache miss path). + RuntimeArray aFallback = new RuntimeArray(); + aFallback.elements.add(runtimeScalar); + for (RuntimeBase arg : args) { + arg.setArrayOfAlias(aFallback); + } + return dispatchPerlMethodAfterSelfInjected(runtimeScalar, method, currentSub, aFallback, callContext); + } finally { + releaseMethodInvocantHold(pjMethodInvHold); + } } /** - * Call a method in a Perl-like class hierarchy using the C3 linearization algorithm. - * - * @param runtimeScalar The object to call the method on. - * @param method The method to resolve. - * @param currentSub The subroutine to resolve SUPER::method in. - * @param args The arguments to pass to the method. - * @param callContext The call context. - * @return The result of the method call. + * Dispatches {@code METHOD $self, ...} after {@code $self} is already element 0 of {@code args}. + * Caller must unwrap TIED_SCALAR and apply {@link #acquireMethodInvocantHold}/{@link + * #releaseMethodInvocantHold} unless another frame already retains the blessed invocant. */ - public static RuntimeList call(RuntimeScalar runtimeScalar, - RuntimeScalar method, - RuntimeScalar currentSub, - RuntimeArray args, - int callContext) { - // Handle tied scalars: the invocant may be a TIED_SCALAR returned - // from a tied hash / array FETCH. Unwrap before dispatch so - // isReference / blessId checks see the real underlying value. - if (runtimeScalar.type == RuntimeScalarType.TIED_SCALAR) { - return call(runtimeScalar.tiedFetch(), method, currentSub, args, callContext); - } - - // insert `this` into the parameter list - args.elements.addFirst(runtimeScalar); + private static RuntimeList dispatchPerlMethodAfterSelfInjected( + RuntimeScalar runtimeScalar, + RuntimeScalar method, + RuntimeScalar currentSub, + RuntimeArray args, + int callContext) { // System.out.println("call ->" + method + " " + currentPackage + " " + args + " " + callContext); @@ -2536,6 +2576,38 @@ public static RuntimeList call(RuntimeScalar runtimeScalar, } } + /** + * Call a method in a Perl-like class hierarchy using the C3 linearization algorithm. + * + * @param runtimeScalar The object to call the method on. + * @param method The method to resolve. + * @param currentSub The subroutine to resolve SUPER::method in. + * @param args The arguments to pass to the method. + * @param callContext The call context. + * @return The result of the method call. + */ + public static RuntimeList call(RuntimeScalar runtimeScalar, + RuntimeScalar method, + RuntimeScalar currentSub, + RuntimeArray args, + int callContext) { + // Handle tied scalars: the invocant may be a TIED_SCALAR returned + // from a tied hash / array FETCH. Unwrap before dispatch so + // isReference / blessId checks see the real underlying value. + if (runtimeScalar.type == RuntimeScalarType.TIED_SCALAR) { + return call(runtimeScalar.tiedFetch(), method, currentSub, args, callContext); + } + + RuntimeBase invHold = acquireMethodInvocantHold(runtimeScalar); + // insert `this` into the parameter list + args.elements.addFirst(runtimeScalar); + try { + return dispatchPerlMethodAfterSelfInjected(runtimeScalar, method, currentSub, args, callContext); + } finally { + releaseMethodInvocantHold(invHold); + } + } + /** * Implementation of Perl's caller() builtin. * This version doesn't have access to __SUB__, so it can't honor set_subname for JVM code. diff --git a/src/test/resources/unit/dbi_fetchrow_hashref_name_lc.t b/src/test/resources/unit/dbi_fetchrow_hashref_name_lc.t new file mode 100644 index 000000000..ca55d973f --- /dev/null +++ b/src/test/resources/unit/dbi_fetchrow_hashref_name_lc.t @@ -0,0 +1,34 @@ +use strict; +use warnings; +use Test::More; +use DBI; + +# Regression guard for JDBC DBI.pm-style fetchrow_hashref($sth, 'NAME_lc') +# (DBIx::Simple lc_columns defaults; upstream DBIx-Simple t/sqlite.t hashes). + +BEGIN { + eval { require DBD::SQLite; 1 } + or plan skip_all => 'DBD::SQLite required'; +} + +my $dbh = DBI->connect( + 'dbi:SQLite:dbname=:memory:', + '', + '', + { RaiseError => 1, PrintError => 0 }, +); + +$dbh->do('CREATE TABLE xyzzy (FOO, bar)'); +$dbh->do(q{INSERT INTO xyzzy VALUES ('a', 'b')}); + +my $sth = $dbh->prepare('SELECT FOO, bar FROM xyzzy ORDER BY foo'); +$sth->execute; + +my $href = $sth->fetchrow_hashref('NAME_lc'); +is_deeply( + $href, + { foo => 'a', bar => 'b' }, + 'fetchrow_hashref honors NAME_lc (lowercase mixed-case labels)', +); + +done_testing; From 1fc067c2073765a6e362eef90a0514f9e4e9c50d Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 16 May 2026 18:58:21 +0200 Subject: [PATCH 3/3] chore: drop jcpan fs PERL5LIB hack; clarify DBIx jar @INC docs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Launcher no longer prepends checkout-only src/main/perl/lib — bundled .pm remain jar:PERL5LIB unless ~/.perlonjava/lib shadows. Refresh dbix_simple.md and chain repro banner. Generated with [Cursor](https://cursor.com/docs) Co-Authored-By: Cursor --- dev/modules/dbix_simple.md | 39 +++++++++++++++++----------- dev/tools/dbix_simple_chain_repro.pl | 5 ++-- jcpan | 6 ----- jcpan.bat | 7 ----- 4 files changed, 27 insertions(+), 30 deletions(-) diff --git a/dev/modules/dbix_simple.md b/dev/modules/dbix_simple.md index 70ead9f92..4be9deffd 100644 --- a/dev/modules/dbix_simple.md +++ b/dev/modules/dbix_simple.md @@ -2,16 +2,19 @@ ## Overview -`./jcpan -t DBIx::Simple` exercises the vendored OO DBI wrapper bundled under -[`src/main/perl/lib/DBIx/Simple.pm`](../../src/main/perl/lib/DBIx/Simple.pm). -The [`jcpan`](../../jcpan) launcher prepends that tree to `PERL5LIB`, so jcpan runs -prefer the JDBC-aware fork over stale copies under `~/.perlonjava/lib`. +`./jcpan -t DBIx::Simple` exercises the vendored OO DBI wrapper. The **source of truth +at runtime** is the copy packed into the fat JAR as **`jar:PERL5LIB`** (built from +[`src/main/perl/lib/DBIx/Simple.pm`](../../src/main/perl/lib/DBIx/Simple.pm) when you **`make`). +GlobalContext **`@INC`** prefers **`PERL5LIB` / `-I`**, then **`~/.perlonjava/lib`**, +then the JAR — so a **leftover** `DBIx/Simple.pm` under **`~/.perlonjava/lib`** +(can happen after older jcpan installs) **shadows** the JDBC-aware bundled copy until +removed or superseded by a reinstall that leaves that path unused. ## Symptoms | Layer | When it bites | Symptoms | | ----- | ------------- | ------- | -| A. Wrong `@INC` / old `Simple.pm` | `./jperl` without bundled `PERL5LIB`; first hit is `~/.perlonjava/lib/DBIx/Simple.pm` | `keep_statements` stays **16**, `old_statements` recycling clashes with JDBC `finish`/`execute_result` semantics → **`execute` on undef** after chained queries, bogus row counts | +| A. Stale jcpan-installed `Simple.pm` | **`~/.perlonjava/lib/DBIx/Simple.pm`** appears **before** `jar:PERL5LIB` in **`@INC`** | `keep_statements` stays **16**, `old_statements` recycling clashes with JDBC `finish`/`execute_result` semantics → **`execute` on undef** after chained queries, bogus row counts | | B. JVM method-chain lifetime | Bundled Simple (`keep_statements == 0` on JDBC) | **`scalar $db->query($sql)->arrays`** returns **too few rows** vs **`my $r = $db->query($sql); scalar $r->arrays`** for the same SQL | | C. JDBC `fetchrow_hashref` | Upstream **`t/sqlite.t`** with `lc_columns` (default hash keys **`foo`** not **`FOO`**) | **`fetchrow_hashref`** ignored **`NAME_lc`** / **`'NAME_lc'`** argument — hashes missing expected keys | @@ -19,25 +22,29 @@ Layer B points at PerlOnJava **`scalar` / `->` / mortal or refcount boundaries** ## Reproduction -Always prefer the same library order jcpan uses: +Default (uses whatever **`@INC`** resolves — often JAR unless **`~/.perlonjava`** shadows): ```bash -export PERL5LIB="$PWD/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl ``` -Smoke compare with system ordering (may load `~/.perlonjava/lib`): +Minimal inline check (**`keep_statements` must be `0` on JDBC** when the **bundled** +`Simple.pm` is the one loaded): ```bash -timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl +./jperl -e 'use DBIx::Simple; use DBI; \ + my $db=DBIx::Simple->connect(q{dbi:SQLite:dbname=:memory:},"","",{RaiseError=>1}); \ + print "keep=".$db->keep_statements."\n"' ``` -Minimal inline check (`keep_statements` must be **0** on JDBC): +If that prints **`16`**, you are almost certainly loading a **non-JAR** copy (typically +remove **`$HOME/.perlonjava/lib/DBIx/Simple.pm`** — and parent dirs if empty — then retry). + +Optional: exercise an **editable workspace** `.pm` **before rebuilding the JAR** (not how +releases behave): ```bash -PERL5LIB="$PWD/src/main/perl/lib" ./jperl -e 'use DBIx::Simple; use DBI; \ - my $db=DBIx::Simple->connect(q{dbi:SQLite:dbname=:memory:},"","",{RaiseError=>1}); \ - print "keep=".$db->keep_statements."\n"' +./jperl -I"$PWD/src/main/perl/lib" dev/tools/dbix_simple_chain_repro.pl ``` Full module test harness (agents: **wrap jcpan** in `timeout`; capture TAP to a file). @@ -59,7 +66,7 @@ returns true (`connection`/`statement`/`ImplementorClass` heuristics). | Date | Change | | ---- | ------ | -| 2026-05-16 | Added this doc + `dev/tools/dbix_simple_chain_repro.pl`; jcpan **`PERL5LIB`** prepend documented upstream in `jcpan` comments. **Layer B**: blessed method-call invocant **refcount hold** across `dispatchPerlMethodAfterSelfInjected` / `callCachedInner` (`RuntimeCode.java`). **Layer C**: JDBC **`DBI.fetchrow_hashref`** honors the optional **second argument** (`NAME_lc`) like `DBI.pm`, fixing **`t/sqlite.t`** hash key expectations under bundled tests. | +| 2026-05-16 | Added this doc + `dev/tools/dbix_simple_chain_repro.pl`. **Layer B**: blessed method-call invocant **refcount hold** across `dispatchPerlMethodAfterSelfInjected` / `callCachedInner` (`RuntimeCode.java`). **Layer C**: JDBC **`DBI.fetchrow_hashref`** honors the optional **second argument** (`NAME_lc`) like `DBI.pm`, fixing **`t/sqlite.t`** hash key expectations under bundled tests. | ## `RuntimeCode.coerceScalarCallResult` @@ -91,7 +98,9 @@ narrowing/reverting after the JDBC chain fix lands. 3. **Interpreter parity** (only if regressions reported) — Run the chain repro under `./jperl --interpreter` and compare row counts vs JVM. -4. **Optional follow-ups** — If Layer B surfaces again elsewhere, revisit `scalar`/method-chain lowering (e.g. `Dereference` / late `scalar()` collapse) alongside `MortalList` boundaries; extend unit coverage for `FetchHashKeyName` / `NAME_uc` only if bugs appear. +4. **Stale `~/.perlonjava`** — If Layer A symptoms return, delete **`$HOME/.perlonjava/lib/DBIx/Simple.pm`** when it should not override the JAR bundle (see [`GlobalContext`](../../src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java) `@INC` ordering). + +5. **Optional follow-ups** — If Layer B surfaces again elsewhere, revisit `scalar`/method-chain lowering (e.g. `Dereference` / late `scalar()` collapse) alongside `MortalList` boundaries; extend unit coverage for `FetchHashKeyName` / `NAME_uc` only if bugs appear. ## References diff --git a/dev/tools/dbix_simple_chain_repro.pl b/dev/tools/dbix_simple_chain_repro.pl index 0cf762166..fe7d457c7 100644 --- a/dev/tools/dbix_simple_chain_repro.pl +++ b/dev/tools/dbix_simple_chain_repro.pl @@ -1,7 +1,8 @@ #!/usr/bin/env perl # Repro for DBIx::Simple chained query vs temporaries on PerlOnJava (see dev/modules/dbix_simple.md). -# Run with bundled lib first: -# PERL5LIB="$PWD/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl +# Run: timeout 120 ./jperl dev/tools/dbix_simple_chain_repro.pl +# (Bundled JDBC fork lives in jar:PERL5LIB unless ~/.perlonjava/lib shadows it.) +# Optional workspace edit cycle: ./jperl -I"$PWD/src/main/perl/lib" dev/tools/dbix_simple_chain_repro.pl use strict; use warnings; diff --git a/jcpan b/jcpan index 077da8af0..822f56b02 100755 --- a/jcpan +++ b/jcpan @@ -80,10 +80,4 @@ case "$JCPAN_BIN" in esac export PATH="$SCRIPT_DIR:$PATH" -# Bundled compat layers (see src/main/perl/lib/DBIx/Simple.pm). Must precede ~/.perlonjava/lib, -# which matches PERL5LIB's position in GlobalContext @INC construction. -if [[ -d "$SCRIPT_DIR/src/main/perl/lib" ]]; then - export PERL5LIB="$SCRIPT_DIR/src/main/perl/lib${PERL5LIB:+:$PERL5LIB}" -fi - exec "$SCRIPT_DIR/jperl" "$CPAN_SCRIPT" "${ARGS[@]}" diff --git a/jcpan.bat b/jcpan.bat index 973233761..788364bea 100644 --- a/jcpan.bat +++ b/jcpan.bat @@ -33,11 +33,4 @@ rem POSIX sh. See src/main/perl/lib/CPAN/Config.pm (Moose.yml). set "JPERL_BIN=%SCRIPT_DIR%jperl.bat" set "JCPAN_BIN=%SCRIPT_DIR%jcpan.bat" set "PATH=%SCRIPT_DIR%;%PATH%" -if exist "%SCRIPT_DIR%src\main\perl\lib" ( - if defined PERL5LIB ( - set "PERL5LIB=%SCRIPT_DIR%src\main\perl\lib;%PERL5LIB%" - ) else ( - set "PERL5LIB=%SCRIPT_DIR%src\main\perl\lib" - ) -) "%SCRIPT_DIR%jperl.bat" "%SCRIPT_DIR%src\main\perl\bin\cpan" %JCPAN_ARGS%