+ * The child scope's local variable index is propagated to the parent scope + * to prevent slot reuse across conditional branches. Without this, the JVM + * verifier can fail with VerifyError when the same slot holds different types + * (e.g., int vs reference, or RuntimeScalar vs RegexState) in different branches, + * causing ASM's COMPUTE_FRAMES to merge them as Top or java/lang/Object. * * @param scopeIndex The index representing the starting point of the scope to exit. */ public void exitScope(int scopeIndex) { clearVisibleVariablesCache(); + // Capture the child scope's max local variable index before popping + int childIndex = symbolTableStack.peek().index; // Pop entries from the stacks until reaching the specified scope index while (symbolTableStack.size() > scopeIndex) { symbolTableStack.pop(); @@ -191,6 +199,13 @@ public void exitScope(int scopeIndex) { featureFlagsStack.pop(); strictOptionsStack.pop(); } + // Propagate the child scope's index to the parent to prevent slot reuse. + // This ensures that local variable slots allocated inside conditional branches + // (e.g., if/else blocks) are not reused in subsequent code, avoiding type + // conflicts at JVM branch merge points. + if (symbolTableStack.peek().index < childIndex) { + symbolTableStack.peek().index = childIndex; + } } /** diff --git a/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java b/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java index 2de094029..fc63df494 100644 --- a/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java +++ b/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java @@ -197,7 +197,7 @@ public static RuntimeScalar compareVersion(RuntimeScalar hasVersion, RuntimeScal throw new PerlCompilerException("Either package version or REQUIRE is not a lax version number"); } if (compareVersions(hasStr, wantStr) < 0) { - throw new PerlCompilerException(perlClassName + " version " + wantStr + " required--this is only version " + hasVersion); + throw new PerlCompilerException(perlClassName + " version " + wantVersion + " required--this is only version " + hasVersion); } } return hasVersion; @@ -222,6 +222,13 @@ public static String normalizeVersion(RuntimeScalar wantVersion) { if (parts.length < 3) { String major = parts[0]; String minor = parts.length > 1 ? parts[1] : "0"; + // Right-pad minor with zeros to at least 3 chars. + // In Perl's version system, decimal digits are grouped in 3s: + // 0.01 -> "010" -> v0.10.0, not v0.1.0 + // 0.5 -> "500" -> v0.500.0 + while (minor.length() < 3) { + minor = minor + "0"; + } String patch = minor.length() > 3 ? minor.substring(3) : "0"; if (minor.length() > 3) { minor = minor.substring(0, 3); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Builtin.java b/src/main/java/org/perlonjava/runtime/perlmodule/Builtin.java index dd14ea023..a5d2a0c39 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Builtin.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Builtin.java @@ -110,9 +110,8 @@ public static RuntimeList unweaken(RuntimeArray args, int ctx) { } public static RuntimeList isWeak(RuntimeArray args, int ctx) { - RuntimeScalar ref = args.get(0); - // Implementation to check if reference is weak - return new RuntimeList(scalarFalse); + // Delegate to Scalar::Util::isweak - on JVM all refs are effectively weak + return ScalarUtil.isweak(args, ctx); } public static RuntimeList blessed(RuntimeArray args, int ctx) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index 97a519ea9..0eea451d3 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -203,13 +203,25 @@ public static RuntimeList prepare(RuntimeArray args, int ctx) { sth.put("Type", new RuntimeScalar("st")); // Add NUM_OF_FIELDS by getting metadata - ResultSetMetaData metaData = stmt.getMetaData(); - int numFields = (metaData != null) ? metaData.getColumnCount() : 0; + int numFields = 0; + try { + ResultSetMetaData metaData = stmt.getMetaData(); + if (metaData != null) { + numFields = metaData.getColumnCount(); + } + } catch (Exception e) { + // Some drivers (e.g. sqlite-jdbc) throw on DDL statements + } sth.put("NUM_OF_FIELDS", new RuntimeScalar(numFields)); // Add NUM_OF_PARAMS by getting parameter count - ParameterMetaData paramMetaData = stmt.getParameterMetaData(); - int numParams = paramMetaData.getParameterCount(); + int numParams = 0; + try { + ParameterMetaData paramMetaData = stmt.getParameterMetaData(); + numParams = paramMetaData.getParameterCount(); + } catch (Exception e) { + // Some drivers (e.g. sqlite-jdbc) throw on DDL/non-parameterized statements + } sth.put("NUM_OF_PARAMS", new RuntimeScalar(numParams)); // Create blessed reference for statement handle @@ -317,7 +329,19 @@ public static RuntimeList execute(RuntimeArray args, int ctx) { // Store execution result in statement handle sth.put("execute_result", result.createReference()); - return result.createReference().getList(); + + // Return value per DBI spec: + // - For DML (INSERT/UPDATE/DELETE): number of rows affected, or "0E0" for 0 rows + // - For SELECT: -1 (unknown number of rows) + if (hasResultSet) { + return new RuntimeScalar(-1).getList(); + } else { + int updateCount = stmt.getUpdateCount(); + if (updateCount == 0) { + return new RuntimeScalar("0E0").getList(); + } + return new RuntimeScalar(updateCount).getList(); + } }, dbh, "execute"); } @@ -341,10 +365,25 @@ public static RuntimeList fetchrow_arrayref(RuntimeArray args, int ctx) { if (rs.next()) { RuntimeArray row = new RuntimeArray(); ResultSetMetaData metaData = rs.getMetaData(); + int colCount = metaData.getColumnCount(); // Convert each column value to string and add to row array - for (int i = 1; i <= metaData.getColumnCount(); i++) { + for (int i = 1; i <= colCount; i++) { RuntimeArray.push(row, RuntimeScalar.newScalarOrString(rs.getObject(i))); } + + // Update bound columns if any (for bind_columns + fetch pattern) + RuntimeScalar boundRef = sth.get("bound_columns"); + if (boundRef != null && boundRef.type != RuntimeScalarType.UNDEF) { + RuntimeHash boundColumns = boundRef.hashDeref(); + for (int i = 1; i <= colCount; i++) { + RuntimeScalar ref = boundColumns.get(String.valueOf(i)); + if (ref != null && ref.type != RuntimeScalarType.UNDEF) { + // Dereference the scalar ref and set its value + ref.scalarDeref().set(row.get(i - 1)); + } + } + } + return row.createReference().getList(); } @@ -788,25 +827,63 @@ public static RuntimeList data_sources(RuntimeArray args, int ctx) { public static RuntimeList get_info(RuntimeArray args, int ctx) { RuntimeHash dbh = args.get(0).hashDeref(); + int infoType = args.size() > 1 ? args.get(1).getInt() : -1; return executeWithErrorHandling(() -> { - RuntimeHash info = new RuntimeHash(); Connection conn = (Connection) dbh.get("connection").value; DatabaseMetaData meta = conn.getMetaData(); - // Add standard database information using available JDBC methods - info.put("DBMS_NAME", RuntimeScalar.newScalarOrString(meta.getDatabaseProductName())); - info.put("DBMS_VERSION", RuntimeScalar.newScalarOrString(meta.getDatabaseProductVersion())); - info.put("DRIVER_NAME", RuntimeScalar.newScalarOrString(meta.getDriverName())); - info.put("DRIVER_VERSION", RuntimeScalar.newScalarOrString(meta.getDriverVersion())); - info.put("IDENTIFIER_QUOTE_CHAR", RuntimeScalar.newScalarOrString(meta.getIdentifierQuoteString())); - info.put("SQL_KEYWORDS", RuntimeScalar.newScalarOrString(meta.getSQLKeywords())); - info.put("MAX_CONNECTIONS", RuntimeScalar.newScalarOrString(meta.getMaxConnections())); - info.put("USER_NAME", RuntimeScalar.newScalarOrString(meta.getUserName())); - info.put("NUMERIC_FUNCTIONS", RuntimeScalar.newScalarOrString(meta.getNumericFunctions())); - info.put("STRING_FUNCTIONS", RuntimeScalar.newScalarOrString(meta.getStringFunctions())); - - return info.createReference().getList(); + // DBI get_info() takes a numeric SQL info type constant and returns a scalar. + // Standard DBI::Const::GetInfoType constants: + // 6 = SQL_DRIVER_NAME + // 7 = SQL_DRIVER_VER + // 17 = SQL_DBMS_NAME + // 18 = SQL_DBMS_VER + // 29 = SQL_IDENTIFIER_QUOTE_CHAR + // 41 = SQL_CATALOG_NAME_SEPARATOR + // 47 = SQL_USER_NAME + // 89 = SQL_KEYWORDS + // 112 = SQL_NUMERIC_FUNCTIONS + // 116 = SQL_MAX_CONNECTIONS (0 = no limit) + // 119 = SQL_STRING_FUNCTIONS + String result; + switch (infoType) { + case 6: + result = meta.getDriverName(); + break; + case 7: + result = meta.getDriverVersion(); + break; + case 17: + result = meta.getDatabaseProductName(); + break; + case 18: + result = meta.getDatabaseProductVersion(); + break; + case 29: + result = meta.getIdentifierQuoteString(); + break; + case 41: + result = meta.getCatalogSeparator(); + break; + case 47: + result = meta.getUserName(); + break; + case 89: + result = meta.getSQLKeywords(); + break; + case 112: + result = meta.getNumericFunctions(); + break; + case 116: + return new RuntimeScalar(meta.getMaxConnections()).getList(); + case 119: + result = meta.getStringFunctions(); + break; + default: + return new RuntimeScalar().getList(); + } + return RuntimeScalar.newScalarOrString(result != null ? result : "").getList(); }, dbh, "get_info"); } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java index b216db5a0..a4977d3b5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java @@ -185,8 +185,14 @@ public static RuntimeList isweak(RuntimeArray args, int ctx) { if (args.size() != 1) { throw new IllegalStateException("Bad number of arguments for isweak() method"); } - // Placeholder for isweak functionality - return new RuntimeScalar(false).getList(); + // On the JVM, the tracing garbage collector handles circular references + // natively, so all references are effectively "weak" from a GC perspective. + // Return true for any reference to indicate it has been "weakened". + RuntimeScalar arg = args.get(0); + boolean isRef = arg.type == RuntimeScalarType.REFERENCE + || arg.type == RuntimeScalarType.ARRAYREFERENCE + || arg.type == RuntimeScalarType.HASHREFERENCE; + return new RuntimeScalar(isRef).getList(); } /** diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Strict.java b/src/main/java/org/perlonjava/runtime/perlmodule/Strict.java index 22645f091..5a4ff6318 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Strict.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Strict.java @@ -54,6 +54,9 @@ public static void initialize() { try { strict.registerMethod("import", "useStrict", ";$"); strict.registerMethod("unimport", "noStrict", ";$"); + strict.registerMethod("bits", "strictBits", null); + strict.registerMethod("all_bits", "strictAllBits", null); + strict.registerMethod("all_explicit_bits", "strictAllExplicitBits", null); // Set $VERSION so CPAN.pm can detect our bundled version GlobalVariable.getGlobalVariable("strict::VERSION").set(new RuntimeScalar("1.14")); } catch (NoSuchMethodException e) { @@ -127,6 +130,67 @@ public static RuntimeList noStrict(RuntimeArray args, int ctx) { return new RuntimeScalar().getList(); } + // Combined bitmask for all strict options + private static final int ALL_BITS = HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS; + // Combined bitmask for all explicit strict options + private static final int ALL_EXPLICIT_BITS = HINT_EXPLICIT_STRICT_REFS | HINT_EXPLICIT_STRICT_SUBS | HINT_EXPLICIT_STRICT_VARS; + + /** + * Returns the bitmask for the given strict categories. + * Called as strict::bits('refs', 'subs', 'vars') from Perl. + * When called from the strict package itself, also includes explicit bits. + * + * @param args The category names. + * @param ctx The context in which the method is called. + * @return A RuntimeList containing the integer bitmask. + */ + public static RuntimeList strictBits(RuntimeArray args, int ctx) { + int bits = 0; + if (args.size() == 0) { + bits = ALL_BITS; + } else { + for (int i = 0; i < args.size(); i++) { + String category = args.get(i).toString(); + switch (category) { + case "refs": + bits |= HINT_STRICT_REFS; + break; + case "subs": + bits |= HINT_STRICT_SUBS; + break; + case "vars": + bits |= HINT_STRICT_VARS; + break; + default: + throw new IllegalArgumentException("Unknown 'strict' tag(s) '" + category + "'"); + } + } + } + return new RuntimeScalar(bits).getList(); + } + + /** + * Returns the combined bitmask for all strict categories (refs | subs | vars). + * + * @param args Unused. + * @param ctx The context in which the method is called. + * @return A RuntimeList containing the integer bitmask 0x602. + */ + public static RuntimeList strictAllBits(RuntimeArray args, int ctx) { + return new RuntimeScalar(ALL_BITS).getList(); + } + + /** + * Returns the combined bitmask for all explicit strict categories. + * + * @param args Unused. + * @param ctx The context in which the method is called. + * @return A RuntimeList containing the integer bitmask 0xe0. + */ + public static RuntimeList strictAllExplicitBits(RuntimeArray args, int ctx) { + return new RuntimeScalar(ALL_EXPLICIT_BITS).getList(); + } + public static String stringifyStrictOptions(int strictOptions) { StringBuilder result = new StringBuilder(); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java index 8469ada16..708632d53 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java @@ -132,15 +132,18 @@ public static RuntimeList can(RuntimeArray args, int ctx) { } } + // Perl's can() must NOT consider AUTOLOAD - it should only find + // methods that are actually defined in the hierarchy. + // See perlobj: "can cannot know whether an object will be able to + // provide a method through AUTOLOAD" RuntimeScalar method = InheritanceResolver.findMethodInHierarchy(methodName, perlClassName, null, 0); - if (method != null) { + if (method != null && !isAutoloadDispatch(method, methodName, perlClassName)) { return method.getList(); } String normalizedName = NameNormalizer.normalizeVariableName(methodName, perlClassName); if (GlobalVariable.existsGlobalCodeRef(normalizedName)) { RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(normalizedName); - // Only return the code ref if it's actually defined (has a real subroutine) if (codeRef.getDefinedBoolean()) { return codeRef.getList(); } @@ -154,7 +157,7 @@ public static RuntimeList can(RuntimeArray args, int ctx) { String effectiveMethodName = decodedMethodName != null ? decodedMethodName : methodName; String effectiveClassName = decodedClassName != null ? decodedClassName : perlClassName; method = InheritanceResolver.findMethodInHierarchy(effectiveMethodName, effectiveClassName, null, 0); - if (method != null) { + if (method != null && !isAutoloadDispatch(method, effectiveMethodName, effectiveClassName)) { return method.getList(); } } @@ -167,13 +170,47 @@ public static RuntimeList can(RuntimeArray args, int ctx) { String effectiveMethodName = methodNameAsOctets != null ? methodNameAsOctets : methodName; String effectiveClassName = classNameAsOctets != null ? classNameAsOctets : perlClassName; method = InheritanceResolver.findMethodInHierarchy(effectiveMethodName, effectiveClassName, null, 0); - if (method != null) { + if (method != null && !isAutoloadDispatch(method, effectiveMethodName, effectiveClassName)) { return method.getList(); } } return new RuntimeList(); } + /** + * Check if a method resolution result was found via AUTOLOAD dispatch + * rather than being a directly defined method. + *
+ * The AUTOLOAD coderef has autoloadVariableName set (e.g. "Foo::AUTOLOAD"). + * We detect AUTOLOAD dispatch by checking if the resolved coderef is actually + * an AUTOLOAD handler AND the method we asked for is not "AUTOLOAD" itself. + * We also verify the coderef came from the AUTOLOAD hierarchy by checking + * that the method doesn't actually exist as a direct definition. + */ + private static boolean isAutoloadDispatch(RuntimeScalar method, String methodName, String className) { + if (!(method.value instanceof RuntimeCode code)) { + return false; + } + if (code.autoloadVariableName == null) { + return false; + } + // If the method IS "AUTOLOAD", it's a direct lookup, not AUTOLOAD dispatch + if ("AUTOLOAD".equals(methodName)) { + return false; + } + // Verify by checking if the method actually exists as a real subroutine + // in the class hierarchy. The autoloadVariableName indicates it was + // resolved via the AUTOLOAD fallback path. + String normalizedName = NameNormalizer.normalizeVariableName(methodName, className); + if (GlobalVariable.existsGlobalCodeRef(normalizedName)) { + RuntimeScalar directRef = GlobalVariable.getGlobalCodeRef(normalizedName); + if (directRef.getDefinedBoolean() && directRef != method) { + return false; // There's a real method with this name + } + } + return true; + } + /** * Checks if the object is of a given class or a subclass. * Note: This is a Perl method, it expects `this` to be the first argument. diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java b/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java index d23a3d4d4..cf51b187f 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java @@ -39,7 +39,7 @@ public static void initialize() { try { utf8.registerMethod("import", "useUtf8", ";$"); utf8.registerMethod("unimport", "noUtf8", ";$"); - utf8.registerMethod("upgrade", "$"); + utf8.registerMethod("upgrade", null); utf8.registerMethod("downgrade", "$;$"); utf8.registerMethod("encode", "$"); utf8.registerMethod("decode", "$"); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index f3ba027f4..7ccd0744c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -508,26 +508,63 @@ public static boolean isPackageLoaded(String className) { // Ensure we have the :: suffix for the prefix check final String prefix = className.endsWith("::") ? className : className + "::"; - // Check if any code references exist with this class prefix + // Check if any code references exist directly in this class (not in sub-packages). + // A key like "Foo::Bar::baz" belongs to package "Foo::Bar", not "Foo". + // After stripping the prefix, the remaining part must NOT contain "::" + // to be a direct member of this package. boolean exists = globalCodeRefs.keySet().stream() - .anyMatch(key -> key.startsWith(prefix)); + .anyMatch(key -> key.startsWith(prefix) && !key.substring(prefix.length()).contains("::")); // Cache the result packageExistsCache.put(className, exists); return exists; } + /** + * Resolves a fully-qualified variable name through stash hash redirections. + *
+ * When {@code *PKG:: = \%OtherPkg::} is executed, accesses to {@code PKG::name} + * should resolve to {@code OtherPkg::name}. This method checks if the package + * portion of the name has been redirected to another package's RuntimeStash, and + * if so, rewrites the name accordingly. + *
+ * This is critical for the {@code local *__ANON__:: = $namespace} pattern used + * by Package::Stash::PP, where glob vivification through the aliased stash must + * create entries visible in the target package's symbol table. + * + * @param fullName The fully-qualified variable name (e.g., "__ANON__::foo"). + * @return The resolved name (e.g., "Foo::foo" if __ANON__:: was redirected to Foo::), + * or the original name if no redirection is active. + */ + public static String resolveStashHashRedirect(String fullName) { + int lastDoubleColon = fullName.lastIndexOf("::"); + if (lastDoubleColon >= 0) { + String pkgPart = fullName.substring(0, lastDoubleColon + 2); + RuntimeHash stashHash = globalHashes.get(pkgPart); + if (stashHash instanceof RuntimeStash stash && !stash.namespace.equals(pkgPart)) { + String shortName = fullName.substring(lastDoubleColon + 2); + return stash.namespace + shortName; + } + } + return fullName; + } + /** * Retrieves a global IO reference by its key, initializing it if necessary. + *
+ * Resolves stash hash redirections so that glob vivification through an aliased + * stash (e.g., after {@code *__ANON__:: = \%Foo::}) creates entries in the correct + * package's symbol table. * * @param key The key of the global IO reference. * @return The RuntimeScalar representing the global IO reference. */ public static RuntimeGlob getGlobalIO(String key) { - RuntimeGlob glob = globalIORefs.get(key); + String resolvedKey = resolveStashHashRedirect(key); + RuntimeGlob glob = globalIORefs.get(resolvedKey); if (glob == null) { - glob = new RuntimeGlob(key); - globalIORefs.put(key, glob); + glob = new RuntimeGlob(resolvedKey); + globalIORefs.put(resolvedKey, glob); } return glob; } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java index 631e1d189..8c307bd52 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeList.java @@ -567,7 +567,9 @@ public RuntimeArray setFromList(RuntimeList value) { // Overwriting `elements` would discard the TieArray wrapper while leaving // `type == TIED_ARRAY`, leading to ClassCastException when tie operations // cast `array.elements` back to TieArray. - if (runtimeArray.type == RuntimeArray.TIED_ARRAY) { + // For autovivify arrays, we must also go through setFromList() to trigger + // the autovivification that converts the parent scalar from UNDEF to ARRAYREFERENCE. + if (runtimeArray.type == RuntimeArray.TIED_ARRAY || runtimeArray.type == RuntimeArray.AUTOVIVIFY_ARRAY) { RuntimeList remainingList = new RuntimeList(); remainingList.elements.addAll(remaining); runtimeArray.setFromList(remainingList); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/WarningFlags.java b/src/main/java/org/perlonjava/runtime/runtimetypes/WarningFlags.java index 2d82af4a8..ddbc282c6 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/WarningFlags.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/WarningFlags.java @@ -59,6 +59,7 @@ public class WarningFlags { warningHierarchy.put("exec", new String[]{"io::exec"}); warningHierarchy.put("reserved", new String[]{}); warningHierarchy.put("prototype", new String[]{}); + warningHierarchy.put("qw", new String[]{"syntax::qw"}); warningHierarchy.put("newline", new String[]{"io::newline"}); warningHierarchy.put("NONFATAL", new String[]{}); warningHierarchy.put("non_unicode", new String[]{}); diff --git a/src/main/perl/lib/B.pm b/src/main/perl/lib/B.pm index 4021cfd12..321ed2e22 100644 --- a/src/main/perl/lib/B.pm +++ b/src/main/perl/lib/B.pm @@ -49,6 +49,12 @@ package B::SV { return bless { ref => $ref }, $class; } + sub REFCNT { + # JVM uses tracing GC, not reference counting. + # Return 0 to indicate objects are always reclaimable. + return 0; + } + sub FLAGS { my $self = shift; my $r = $self->{ref}; diff --git a/src/main/perl/lib/DBD/SQLite.pm b/src/main/perl/lib/DBD/SQLite.pm new file mode 100644 index 000000000..624d63390 --- /dev/null +++ b/src/main/perl/lib/DBD/SQLite.pm @@ -0,0 +1,53 @@ +package DBD::SQLite; +use strict; +use warnings; + +our $VERSION = '1.74'; + +# Translate Perl DBI DSN to JDBC URL for SQLite +# Handles: +# dbi:SQLite:dbname=:memory: -> jdbc:sqlite::memory: +# dbi:SQLite::memory: -> jdbc:sqlite::memory: +# dbi:SQLite:dbname=/path/to/db -> jdbc:sqlite:/path/to/db +# dbi:SQLite:/path/to/db -> jdbc:sqlite:/path/to/db +# dbi:SQLite:dbname=file.db -> jdbc:sqlite:file.db +sub _dsn_to_jdbc { + my ($class, $dsn_rest) = @_; + + my $dbname; + if ($dsn_rest =~ /(?:^|;)dbname=(.+?)(?:;|$)/) { + $dbname = $1; + } elsif ($dsn_rest =~ /(?:^|;)database=(.+?)(?:;|$)/i) { + $dbname = $1; + } elsif ($dsn_rest =~ /^:memory:$/) { + $dbname = ':memory:'; + } elsif ($dsn_rest !~ /=/) { + $dbname = $dsn_rest; + } else { + $dbname = ':memory:'; + } + + return "jdbc:sqlite:$dbname"; +} + +1; + +__END__ + +=head1 NAME + +DBD::SQLite - PerlOnJava SQLite driver via JDBC (sqlite-jdbc) + +=head1 SYNOPSIS + + use DBI; + my $dbh = DBI->connect("dbi:SQLite:dbname=:memory:", "", ""); + my $dbh = DBI->connect("dbi:SQLite::memory:", "", ""); + my $dbh = DBI->connect("dbi:SQLite:dbname=/path/to/db.sqlite", "", ""); + +=head1 DESCRIPTION + +This is a PerlOnJava compatibility shim that translates Perl DBI DSN format +to JDBC URL format for the Xerial sqlite-jdbc driver bundled with PerlOnJava. + +=cut diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index e60afd62a..9cd00af4d 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -3,10 +3,88 @@ use strict; use warnings; use XSLoader; +our $VERSION = '1.643'; + XSLoader::load( 'DBI' ); # NOTE: The rest of the code is in file: -# src/main/java/org/perlonjava/perlmodule/DBI.java +# src/main/java/org/perlonjava/runtime/perlmodule/DBI.java + +# SQL type constants (from DBI spec, java.sql.Types values) +# Used by DBIx::Class::Storage::DBI::SQLite and others +use constant { + SQL_GUID => -11, + SQL_WLONGVARCHAR => -10, + SQL_WVARCHAR => -9, + SQL_WCHAR => -8, + SQL_BIGINT => -5, + SQL_BIT => -7, + SQL_TINYINT => -6, + SQL_LONGVARBINARY => -4, + SQL_VARBINARY => -3, + SQL_BINARY => -2, + SQL_LONGVARCHAR => -1, + SQL_UNKNOWN_TYPE => 0, + SQL_ALL_TYPES => 0, + SQL_CHAR => 1, + SQL_NUMERIC => 2, + SQL_DECIMAL => 3, + SQL_INTEGER => 4, + SQL_SMALLINT => 5, + SQL_FLOAT => 6, + SQL_REAL => 7, + SQL_DOUBLE => 8, + SQL_DATETIME => 9, + SQL_DATE => 9, + SQL_INTERVAL => 10, + SQL_TIME => 10, + SQL_TIMESTAMP => 11, + SQL_VARCHAR => 12, + SQL_BOOLEAN => 16, + SQL_UDT => 17, + SQL_UDT_LOCATOR => 18, + SQL_ROW => 19, + SQL_REF => 20, + SQL_BLOB => 30, + SQL_BLOB_LOCATOR => 31, + SQL_CLOB => 40, + SQL_CLOB_LOCATOR => 41, + SQL_ARRAY => 50, + SQL_MULTISET => 55, + SQL_TYPE_DATE => 91, + SQL_TYPE_TIME => 92, + SQL_TYPE_TIMESTAMP => 93, + SQL_TYPE_TIME_WITH_TIMEZONE => 94, + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95, +}; + +# DSN translation: convert Perl DBI DSN format to JDBC URL +# This wraps the Java-side connect() to support dbi:Driver:... format +{ + no warnings 'redefine'; + my $orig_connect = \&connect; + *connect = sub { + my ($class, $dsn, $user, $pass, $attr) = @_; + $dsn = '' unless defined $dsn; + my $driver_name; + if ($dsn =~ /^dbi:(\w+):(.*)$/i) { + my ($driver, $rest) = ($1, $2); + $driver_name = $driver; + my $dbd_class = "DBD::$driver"; + eval "require $dbd_class"; + if ($dbd_class->can('_dsn_to_jdbc')) { + $dsn = $dbd_class->_dsn_to_jdbc($rest); + } + } + my $dbh = $orig_connect->($class, $dsn, $user, $pass, $attr); + if ($dbh && $driver_name) { + # Set Driver attribute so DBIx::Class can detect the driver + # (e.g. $dbh->{Driver}{Name} returns "SQLite") + $dbh->{Driver} = bless { Name => $driver_name }, 'DBI::dr'; + } + return $dbh; + }; +} # Example: # @@ -26,6 +104,19 @@ our $MAX_CACHED_STATEMENTS = 100; our %CACHED_CONNECTIONS; our $MAX_CACHED_CONNECTIONS = 10; +# FETCH/STORE methods for tied-hash compatibility +# In real Perl DBI, handles are tied hashes. DBIx::Class calls +# $dbh->FETCH('Active') explicitly, so we need method wrappers. +sub FETCH { + my ($self, $key) = @_; + return $self->{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + $self->{$key} = $value; +} + sub do { my ($dbh, $statement, $attr, @params) = @_; my $sth = $dbh->prepare($statement, $attr) or return undef; @@ -39,6 +130,37 @@ sub finish { $sth->{Active} = 0; } +# Batch execution: calls $fetch_tuple->() repeatedly to get parameter arrays, +# executes the prepared statement for each, and tracks results in $tuple_status. +sub execute_for_fetch { + my ($sth, $fetch_tuple, $tuple_status) = @_; + $tuple_status ||= []; + @$tuple_status = (); + + my $total_rows = 0; + while (my $tuple = $fetch_tuple->()) { + my $rv; + eval { + $rv = $sth->execute(@$tuple); + }; + if ($@) { + push @$tuple_status, [$@]; + next; + } + push @$tuple_status, $rv; + $total_rows += $rv if defined $rv && $rv >= 0; + } + return $total_rows; +} + +sub bind_param { + my ($sth, $param_num, $value, $attr) = @_; + # Store bind parameter for later use + $sth->{_bind_params} ||= {}; + $sth->{_bind_params}{$param_num} = $value; + return 1; +} + sub clone { my ($dbh) = @_; my %new_dbh = %{$dbh}; # Shallow copy diff --git a/src/main/perl/lib/DBI/Const/GetInfoReturn.pm b/src/main/perl/lib/DBI/Const/GetInfoReturn.pm new file mode 100644 index 000000000..4d372f8e6 --- /dev/null +++ b/src/main/perl/lib/DBI/Const/GetInfoReturn.pm @@ -0,0 +1,18 @@ +package DBI::Const::GetInfoReturn; +use strict; +use warnings; + +# Minimal stub for PerlOnJava - provides human-readable descriptions +# of DBI get_info() return values. Used by DBIx::Class for diagnostics. + +sub Explain { + my ($info_type, $value) = @_; + return ''; +} + +sub Format { + my ($info_type, $value) = @_; + return defined $value ? "$value" : ''; +} + +1; diff --git a/src/main/perl/lib/ExtUtils/MM_Unix.pm b/src/main/perl/lib/ExtUtils/MM_Unix.pm index 229565c2e..034f3fdbd 100644 --- a/src/main/perl/lib/ExtUtils/MM_Unix.pm +++ b/src/main/perl/lib/ExtUtils/MM_Unix.pm @@ -80,6 +80,50 @@ sub get_version { return; } +# parse_abstract - extract ABSTRACT from a Perl module's POD +sub parse_abstract { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + binmode $fh; + my $inpod = 0; + my $pod_encoding; + my $package = $self->{DISTNAME}; + $package =~ s/-/::/g; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if !$inpod; + s#\r*\n\z##; # handle CRLF input + + if ( /^=encoding\s*(.*)$/i ) { + $pod_encoding = $1; + } + + if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) { + $result = $2; + next; + } + next unless $result; + + if ( $result && ( /^\s*$/ || /^\=/ ) ) { + last; + } + $result = join ' ', $result, $_; + } + close $fh; + + if ( $pod_encoding ) { + eval { + require Encode; + $result = Encode::decode($pod_encoding, $result); + } + } + + return $result; +} + # maybe_command - check if a file is an executable command (Unix version) sub maybe_command { my($self,$file) = @_; diff --git a/src/main/perl/lib/ExtUtils/MakeMaker.pm b/src/main/perl/lib/ExtUtils/MakeMaker.pm index 7b964f2b6..f02f52ba6 100644 --- a/src/main/perl/lib/ExtUtils/MakeMaker.pm +++ b/src/main/perl/lib/ExtUtils/MakeMaker.pm @@ -516,7 +516,7 @@ sub _shell_cp { my ($src, $dest) = @_; $src =~ s/'/'\\''/g; $dest =~ s/'/'\\''/g; - return "\t\@cp '$src' '$dest'"; + return "\t\@rm -f '$dest' && cp '$src' '$dest'"; } sub _create_mymeta { diff --git a/src/test/resources/unit/string_interpolation.t b/src/test/resources/unit/string_interpolation.t index 543b3edab..104cd93fe 100644 --- a/src/test/resources/unit/string_interpolation.t +++ b/src/test/resources/unit/string_interpolation.t @@ -334,5 +334,27 @@ EOT ok(defined($result) || $@, "Here-doc in array ref interpolation handled"); }; +# Test @${$v} interpolation - array dereference of scalar dereference in strings +{ + my @a = (10, 20, 30); + my $r = \@a; + my $v = \$r; + is("@${$v}", "10 20 30", '@${$v} interpolates array via double dereference'); +} + +# Test @${$v} with array ref directly +{ + my $v = [4, 5, 6]; + my $rv = \$v; + is("@${$rv}", "4 5 6", '@${$rv} interpolates array ref via scalar deref'); +} + +# Test @$r still works (simple array deref in string) +{ + my @a = (7, 8, 9); + my $r = \@a; + is("@$r", "7 8 9", '@$r simple array dereference in string'); +} + done_testing(); diff --git a/src/test/resources/unit/subroutine.t b/src/test/resources/unit/subroutine.t index 77b9f455e..abb7ee007 100644 --- a/src/test/resources/unit/subroutine.t +++ b/src/test/resources/unit/subroutine.t @@ -177,4 +177,57 @@ sub hoisted_with_prototype($) { } } +############################ +# &func (no parens) shares caller's @_ by alias +# shift() in the callee should modify the caller's @_ + +{ + sub _get_first { shift } + + sub caller_of_get_first { + my $first = &_get_first; + return ($first, scalar @_); + } + + my ($result, $remaining) = caller_of_get_first("a", "b", "c"); + is($result, "a", '&func shares @_ - shift returns first element'); + is($remaining, 2, '&func shares @_ - shift modifies caller @_'); +} + +# _get_obj pattern (used by Hash::Merge and other CPAN modules) +{ + use Scalar::Util "blessed"; + + package TestGetObj; + sub new { bless {val => $_[1]}, $_[0] } + + package main; + my $fallback; + + sub _test_get_obj { + if (my $type = ref $_[0]) { + return shift() + if $type eq "TestGetObj" + || (blessed $_[0] && $_[0]->isa("TestGetObj")); + } + defined $fallback or $fallback = TestGetObj->new("default"); + return $fallback; + } + + sub do_merge { + my $self = &_test_get_obj; + my ($left, $right) = @_; + return "$self->{val}:$left:$right"; + } + + # OO call - object is shifted from @_, remaining are args + my $obj = TestGetObj->new("custom"); + is(do_merge($obj, "L", "R"), "custom:L:R", + '&_get_obj pattern - OO call shifts object from @_'); + + # Functional call - no object, uses fallback + is(do_merge("L", "R"), "default:L:R", + '&_get_obj pattern - functional call uses fallback'); +} + done_testing();