diff --git a/.cognition/skills/debug-exiftool/SKILL.md b/.cognition/skills/debug-exiftool/SKILL.md index 49bc9d4e3..c26796118 100644 --- a/.cognition/skills/debug-exiftool/SKILL.md +++ b/.cognition/skills/debug-exiftool/SKILL.md @@ -7,6 +7,14 @@ triggers: - model --- +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + # Debugging Image::ExifTool Tests in PerlOnJava You are debugging failures in the Image::ExifTool test suite running under PerlOnJava (a Perl-to-JVM compiler/interpreter). Failures typically stem from missing Perl features or subtle behavior differences in PerlOnJava, not bugs in ExifTool itself. @@ -15,6 +23,8 @@ You are debugging failures in the Image::ExifTool test suite running under PerlO **IMPORTANT: Never push directly to master. Always use feature branches and PRs.** +**IMPORTANT: Always commit or stash changes BEFORE switching branches.** If `git stash pop` has conflicts, uncommitted changes may be lost. + ```bash git checkout -b fix/exiftool-issue-name # ... make changes ... @@ -30,24 +40,23 @@ gh pr create --title "Fix: description" --body "Details" - **ExifTool test lib**: `Image-ExifTool-13.44/t/TestLib.pm` (exports `check`, `writeCheck`, `writeInfo`, `testCompare`, `binaryCompare`, `testVerbose`, `notOK`, `done`) - **ExifTool test data**: `Image-ExifTool-13.44/t/images/` (reference images) - **ExifTool reference output**: `Image-ExifTool-13.44/t/_N.out` (expected tag output per sub-test) -- **PerlOnJava unit tests**: `src/test/resources/unit/*.t` (mvn test suite, 154 tests) +- **PerlOnJava unit tests**: `src/test/resources/unit/*.t` (make suite, 154 tests) - **Perl5 core tests**: `perl5_t/t/` (Perl 5 compatibility suite, run via `make test-gradle`) - **Fat JAR**: `target/perlonjava-3.0.0.jar` - **Launcher script**: `./jperl` (resolves JAR path, sets `$^X`) ## Building PerlOnJava -```bash -# Build JAR (required after any Java source change) -mvn package -q -DskipTests +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** -# Run PerlOnJava's own unit test suite (154 tests, must all pass) -mvn test +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | -# Run Perl5 core compatibility tests (perl5_t/t/*.t) -make test-gradle -# Or manually: -perl dev/tools/perl_test_runner.pl --jobs 8 --timeout 60 --output test_results.json perl5_t/t +```bash +make # Standard build - compiles and runs tests +make dev # Quick build - compiles only, NO tests ``` ## Running ExifTool Tests @@ -232,9 +241,9 @@ The `check()` function compares extracted tags against reference files `t/ backup.patch` +- This warning exists because completed work was lost during debugging + ## Git Workflow **IMPORTANT: Never push directly to master. Always use feature branches and PRs.** @@ -25,16 +33,23 @@ gh pr create --title "Fix: description" --body "Details" ## Project Layout - **PerlOnJava source**: `src/main/java/org/perlonjava/` (compiler, bytecode interpreter, runtime) -- **Unit tests**: `src/test/resources/unit/*.t` (156 tests, run via `mvn test`) +- **Unit tests**: `src/test/resources/unit/*.t` (run via `make`) - **Perl5 core tests**: `perl5_t/t/` (Perl 5 compatibility suite) - **Fat JAR**: `target/perlonjava-3.0.0.jar` - **Launcher script**: `./jperl` ## Building +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | + ```bash -mvn package -q -DskipTests # Build JAR (required after any Java change) -mvn test # Run unit tests (156 tests, must all pass) +make # Standard build - compiles and runs tests +make dev # Quick build - compiles only, NO tests ``` ## Running Tests @@ -142,10 +157,10 @@ JPERL_INTERPRETER=1 ./jperl -e 'code' # Interpreter backend ### 1. Identify the regression ```bash # Compare branch vs master -git checkout master && mvn package -q -DskipTests +git checkout master && make dev ./jperl -e 'failing code' -git checkout branch && mvn package -q -DskipTests +git checkout branch && make dev ./jperl -e 'failing code' ``` @@ -190,14 +205,14 @@ In Java source, add: ```java System.err.println("DEBUG: var=" + var); ``` -Then rebuild with `mvn package -q -DskipTests`. +Then rebuild with `make dev`. ### 8. Fix and verify ```bash # After fixing -mvn package -q -DskipTests +make dev ./jperl -e 'test code' # Verify fix -mvn test # No regressions in unit tests +make # Build + run unit tests (no regressions) ``` ## Git Workflow @@ -380,11 +395,13 @@ The JVM's `setFromList()` → `addToArray()` chain already handles `PerlRange` c ## Quick Reference Commands ```bash -# Build -mvn package -q -DskipTests +# Build + test +make + +# Build only (no tests) +make dev -# Test -mvn test +# Run specific Perl5 test perl dev/tools/perl_test_runner.pl perl5_t/t/op/bop.t # Debug parsing diff --git a/.cognition/skills/debug-windows-ci/SKILL.md b/.cognition/skills/debug-windows-ci/SKILL.md index e9c8fa9c5..db59dba2c 100644 --- a/.cognition/skills/debug-windows-ci/SKILL.md +++ b/.cognition/skills/debug-windows-ci/SKILL.md @@ -1,5 +1,13 @@ # Debug PerlOnJava Windows CI Failures +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + ## Overview This skill helps debug test failures that occur specifically in the Windows CI/CD environment but pass locally on macOS/Linux. diff --git a/.cognition/skills/debugger/SKILL.md b/.cognition/skills/debugger/SKILL.md index e76443d71..55e611163 100644 --- a/.cognition/skills/debugger/SKILL.md +++ b/.cognition/skills/debugger/SKILL.md @@ -1,5 +1,13 @@ # Perl Debugger Implementation Skill +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + ## Overview Continue implementing the Perl debugger (`-d` flag) for PerlOnJava. The debugger uses DEBUG opcodes injected at statement boundaries in the bytecode interpreter. @@ -8,6 +16,8 @@ Continue implementing the Perl debugger (`-d` flag) for PerlOnJava. The debugger **IMPORTANT: Never push directly to master. Always use feature branches and PRs.** +**IMPORTANT: Always commit or stash changes BEFORE switching branches.** If `git stash pop` has conflicts, uncommitted changes may be lost. + ```bash git checkout -b feature/debugger-improvement # ... make changes ... @@ -128,10 +138,16 @@ Tested side-by-side with `perl -d`: ## Tips for Development +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | + ### Testing the debugger ```bash -# Build after changes -mvn package -q -DskipTests +make dev # Quick build after changes (no tests) # Test basic stepping echo 'n diff --git a/.cognition/skills/fix-pat-sprintf/SKILL.md b/.cognition/skills/fix-pat-sprintf/SKILL.md index afaf76269..8ecb25316 100644 --- a/.cognition/skills/fix-pat-sprintf/SKILL.md +++ b/.cognition/skills/fix-pat-sprintf/SKILL.md @@ -7,6 +7,14 @@ triggers: - model --- +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + # Fix pat.t and sprintf2.t Regressions You are fixing test regressions in `re/pat.t` (-17 tests) and `op/sprintf2.t` (-3 tests) on the `fix-exiftool-cli` branch of PerlOnJava. @@ -50,11 +58,20 @@ For each failing test: ## Running the Tests +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | + ```bash -# Build -make build +make # Standard build - compiles and runs tests +make dev # Quick build - compiles only, NO tests +``` -# Run individual tests via test runner (sets correct ENV vars) +Run individual tests via test runner (sets correct ENV vars): +```bash perl dev/tools/perl_test_runner.pl perl5_t/t/re/pat.t perl dev/tools/perl_test_runner.pl perl5_t/t/op/sprintf2.t diff --git a/.cognition/skills/interpreter-parity/SKILL.md b/.cognition/skills/interpreter-parity/SKILL.md index f13d35162..95e688b19 100644 --- a/.cognition/skills/interpreter-parity/SKILL.md +++ b/.cognition/skills/interpreter-parity/SKILL.md @@ -7,6 +7,14 @@ triggers: - model --- +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + # Interpreter/JVM Backend Parity Debugging You are fixing cases where PerlOnJava's bytecode interpreter produces different results than the JVM compiler backend. The interpreter should be a drop-in replacement — same parsing, same runtime APIs, different execution engine. @@ -15,6 +23,8 @@ You are fixing cases where PerlOnJava's bytecode interpreter produces different **IMPORTANT: Never push directly to master. Always use feature branches and PRs.** +**IMPORTANT: Always commit changes BEFORE switching branches.** Use `git diff > backup.patch` to save uncommitted work, or commit to a WIP branch. Never use `git stash` — changes can be silently lost. + ```bash git checkout -b fix/interpreter-issue-name # ... make changes ... @@ -25,16 +35,24 @@ gh pr create --title "Fix interpreter: description" --body "Details" ## Project Layout - **PerlOnJava source**: `src/main/java/org/perlonjava/` (compiler, bytecode interpreter, runtime) -- **Unit tests**: `src/test/resources/unit/*.t` (155 tests, run via `mvn test`) +- **Unit tests**: `src/test/resources/unit/*.t` (155 tests, run via `make`) - **Fat JAR**: `target/perlonjava-3.0.0.jar` - **Launcher script**: `./jperl` ## Building +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | +| `make test-interpreter` | Run unit tests with interpreter backend | + ```bash -mvn package -q -DskipTests # Build JAR (after any Java change) -mvn test # Run unit tests (JVM backend, must all pass) -make test-interpreter # Run unit tests with interpreter backend +make # Standard build - compiles and runs tests +make dev # Quick build - compiles only, NO tests +make test-interpreter # Test interpreter backend specifically ``` ## Running in Interpreter Mode @@ -170,9 +188,13 @@ All paths relative to `src/main/java/org/perlonjava/`. **Save master baseline to files FIRST** (do this once per debugging session): ```bash +# Save your current work first (NEVER use git stash!) +git diff > /tmp/my-changes.patch # Save uncommitted changes +git add -A && git commit -m "WIP: save work before baseline check" # Or commit to WIP + # Switch to master and build -git stash && git checkout master -mvn package -q -DskipTests +git checkout master +make dev # Save master test output for JVM backend cd perl5_t/t && ../../jperl re/subst.t 2>&1 > /tmp/master_subst.log @@ -182,12 +204,14 @@ grep "^not ok" /tmp/master_subst.log > /tmp/master_subst_fails.txt cd perl5_t/t && ../../jperl --interpreter re/subst.t 2>&1 > /tmp/master_subst_interp.log # Switch back to feature branch -git checkout feature-branch && git stash pop +git checkout feature-branch +# Restore uncommitted changes if you used patch: +# git apply /tmp/my-changes.patch ``` **After making changes**, compare against saved baselines: ```bash -mvn package -q -DskipTests +make dev # Test JVM backend cd perl5_t/t && ../../jperl re/subst.t 2>&1 > /tmp/feature_subst.log @@ -224,13 +248,13 @@ JPERL_INTERPRETER=1 ./jperl -e 'failing code' **CRITICAL: Save baselines to files!** When comparing test suites across branches: ```bash # On master - save results so you don't have to rebuild later -git checkout master && mvn package -q -DskipTests +git checkout master && make dev cd perl5_t/t && JPERL_INTERPRETER=1 ../../jperl test.t 2>&1 | tee /tmp/test_master.log JPERL_INTERPRETER=1 ../../jperl test.t 2>&1 | grep "^ok\|^not ok" > /tmp/test_master_results.txt grep "^ok" /tmp/test_master_results.txt | wc -l # Save this number! # Return to feature branch - now you can compare without rebuilding master -git checkout feature-branch && mvn package -q -DskipTests +git checkout feature-branch && make dev ``` ### 2. Use --disassemble to see interpreter bytecode diff --git a/.cognition/skills/migrate-jna/SKILL.md b/.cognition/skills/migrate-jna/SKILL.md index 8d63e09aa..ceeec2f84 100644 --- a/.cognition/skills/migrate-jna/SKILL.md +++ b/.cognition/skills/migrate-jna/SKILL.md @@ -81,10 +81,18 @@ Migrate in this order (least to most complex): ## Testing +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration) | +| `make test-all` | Run extended test suite | + After each file migration: ```bash -make # Must pass -make test-all # Check for regressions +make # Build + unit tests (must pass) +make test-all # Check for regressions in extended tests ``` Key tests that exercise native operations: diff --git a/.cognition/skills/port-cpan-module/SKILL.md b/.cognition/skills/port-cpan-module/SKILL.md index d89c04581..0640fec92 100644 --- a/.cognition/skills/port-cpan-module/SKILL.md +++ b/.cognition/skills/port-cpan-module/SKILL.md @@ -1,5 +1,13 @@ # Port CPAN Module to PerlOnJava +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + This skill guides you through porting a CPAN module with XS/C components to PerlOnJava using Java implementations. ## When to Use This Skill @@ -165,6 +173,13 @@ as Perl itself. ### Phase 4: Testing +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during development) | + 1. **Create test file:** `src/test/resources/module_name.t` 2. **Compare with system Perl:** @@ -182,8 +197,9 @@ as Perl itself. 3. **Build and verify:** ```bash - ./gradlew build -x test + make dev # Quick build (no tests) ./jperl -e 'use Module::Name; ...' + make # Full build with tests before committing ``` ## Common Patterns @@ -341,7 +357,7 @@ public static RuntimeList myMethod(RuntimeArray args, int ctx) { - [ ] Register all methods in `initialize()` ### Testing -- [ ] Build compiles without errors: `./gradlew build -x test` +- [ ] Build compiles without errors: `make dev` (NEVER use raw mvn/gradlew) - [ ] Basic functionality works: `./jperl -e 'use Module::Name; ...'` - [ ] Compare output with system Perl - [ ] Test edge cases identified in XS code diff --git a/.cognition/skills/profile-perlonjava/SKILL.md b/.cognition/skills/profile-perlonjava/SKILL.md index 3fd9a2e24..4f532afff 100644 --- a/.cognition/skills/profile-perlonjava/SKILL.md +++ b/.cognition/skills/profile-perlonjava/SKILL.md @@ -1,11 +1,21 @@ # Profile PerlOnJava +## ⚠️⚠️⚠️ CRITICAL: NEVER USE `git stash` ⚠️⚠️⚠️ + +**DANGER: Changes are SILENTLY LOST when using git stash/stash pop!** + +- NEVER use `git stash` to temporarily revert changes +- INSTEAD: Commit to a WIP branch or use `git diff > backup.patch` +- This warning exists because completed work was lost during debugging + Profile and optimize PerlOnJava runtime performance using Java Flight Recorder. ## Git Workflow **IMPORTANT: Never push directly to master. Always use feature branches and PRs.** +**IMPORTANT: Always commit or stash changes BEFORE switching branches.** If `git stash pop` has conflicts, uncommitted changes may be lost. + ```bash git checkout -b perf/optimization-name # ... make changes ... @@ -113,12 +123,16 @@ done ### 7. Build and Test -```bash -# Rebuild after changes -mvn package -q -DskipTests +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during profiling) | -# Run tests to verify correctness -mvn test -q +```bash +make # Standard build - compiles and runs tests +make dev # Quick build - compiles only, NO tests ``` ## Example Session diff --git a/AGENTS.md b/AGENTS.md index 2033688a3..ee7ce103a 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -1,5 +1,25 @@ # PerlOnJava Agent Guidelines +## ⚠️⚠️⚠️ CRITICAL WARNING: NEVER USE `git stash` ⚠️⚠️⚠️ + +``` +╔══════════════════════════════════════════════════════════════════════════════╗ +║ ║ +║ DANGER: DO NOT USE `git stash` DURING ACTIVE WORK! ║ +║ ║ +║ Changes can be SILENTLY LOST when using git stash/stash pop. ║ +║ This has caused loss of completed work during debugging sessions. ║ +║ ║ +║ INSTEAD: ║ +║ - Commit your changes to a WIP branch before testing alternatives ║ +║ - Use `git diff > backup.patch` to save uncommitted changes ║ +║ - Never stash to "temporarily" revert - you WILL lose work ║ +║ ║ +╚══════════════════════════════════════════════════════════════════════════════╝ +``` + +--- + ## Project Rules ### Progress Tracking for Multi-Phase Work @@ -42,11 +62,17 @@ Example format at the end of a design doc: ### Testing -- Run `./gradlew test` before committing +**ALWAYS use `make` commands. NEVER use raw mvn/gradlew commands.** + +| Command | What it does | +|---------|--------------| +| `make` | Build + run all unit tests (use before committing) | +| `make dev` | Build only, skip tests (for quick iteration during debugging) | + - For interpreter changes, test with both backends: ```bash - java -jar target/perlonjava.jar -e 'code' # JVM backend - java -jar target/perlonjava.jar --int -e 'code' # Interpreter + ./jperl -e 'code' # JVM backend + ./jperl --int -e 'code' # Interpreter ``` ### Git Workflow diff --git a/dev/design/moo_support.md b/dev/design/moo_support.md index dd3c97eb3..a6b4c46ef 100644 --- a/dev/design/moo_support.md +++ b/dev/design/moo_support.md @@ -314,20 +314,76 @@ All tests meet or exceed the baseline (20260312T075000): ## Success Criteria -1. `jcpan -t Moo` runs Moo tests ❌ (tests skipped) -2. **All Moo tests pass** ❌ (needs verification with extends fix) +1. `jcpan -t Moo` runs Moo tests ✓ (tests now run with Test::Harness) +2. **All Moo tests pass** ❌ (685/774 passing = 88%, see Known Issues below) 3. `jperl -e 'use Moo; print "OK\n"'` works ✓ 4. `has x => (is => "ro")` syntax parses correctly ✓ 5. Moo class with attributes works ✓ 6. `croak` and `carp` work with proper stack traces ✓ -7. `extends 'Parent'` inheritance works ✓ (NEW - fixed in Phase 7) +7. `extends 'Parent'` inheritance works ✓ (fixed in Phase 7) 8. No regressions in baseline tests ✓ +## Known Issues (Remaining Moo Test Failures) + +### Issue: DEMOLISH Not Being Called (Expected - Not Supported) +**Tests affected**: t/demolish-basics.t (3 failures) +**Symptom**: Object destructors (DEMOLISH methods) are not called when objects go out of scope +**Root cause**: DESTROY/fork/threads are not supported in PerlOnJava (they compile but throw at runtime) +**Status**: Expected failure - these features are out of scope for PerlOnJava + +### Issue: SUPER::new Not Working in Extended Classes - FIXED (Phase 13) +**Tests affected**: t/extends-non-moo.t +**Symptom**: `Undefined subroutine &Package::SUPER::new called` +**Root cause**: Only `SUPER::method` was supported, not `Package::SUPER::method` +**Status**: ✅ FIXED - RuntimeCode.java now handles `::SUPER::` pattern + +### Issue: Regex Escaping in Error Messages (quotemeta) - FIXED (Phase 12) +**Tests affected**: t/accessor-coerce.t, t/accessor-isa.t (many failures) +**Symptom**: `plus\_three` vs `plus_three`, `less\_than\_three` vs `less_than_three` +**Root cause**: quotemeta was escaping `_` (underscore) which Perl doesn't escape +**Status**: ✅ FIXED - StringOperators.java now treats `_` as alphanumeric + +### Issue: Role Application Error Messages +**Tests affected**: t/compose-roles.t (4 failures) +**Symptom**: Missing error messages when required attributes are not provided +**Root cause**: Error throwing in role composition may not propagate correctly +**Status**: Needs investigation + +### Issue: Spurious "Odd number of elements in anonymous hash" Warnings +**Tests affected**: Various tests when run via TAP::Harness +**Symptom**: Warnings appear in TAP::Harness but not when running tests directly +**Root cause**: Unknown - standard Perl does NOT emit these warnings +**Status**: Needs investigation - add stack trace to RuntimeHash.java to identify source + +## Remaining jcpan Improvements + +### Completed in This Session +- [x] **Version parsing**: Handle "undef" version strings gracefully +- [x] **MM->parse_version**: ExtUtils::MakeMaker now loads ExtUtils::MM +- [x] **Sub::Util**: Java implementation with set_subname (required by Moo) +- [x] **Scalar/List::Util VERSION**: Added $VERSION for CPAN detection +- [x] **Test::Harness**: Added for `make test` support + +### Still Needed +- [ ] **Prototype checking**: `$$` prototype with `@array` argument should work (workaround: removed prototype) +- [ ] **CPAN.pm metadata caching**: Reduce repeated dependency checks +- [ ] **Better XS module detection**: Skip XS modules earlier in the process +- [ ] **CPAN::DistnameInfo**: Install to avoid "allow_installing_outdated_dists" warnings + ## Progress Tracking -### Current Status: 🟡 TESTING - Verify Moo extends works +### Current Status: 🟢 WORKING - Tests running, improvements in progress + +Moo tests run via `jcpan -t Moo`. Recent fixes (Phases 12-13) should improve pass rate. +**Previous baseline**: 685/774 subtests passed (89 failed), 40/71 test programs passed. + +**Fixed in this session**: +- t/extends-non-moo.t: 0/10 → 10/10 (Package::SUPER::method fix) +- t/accessor-coerce.t, t/accessor-isa.t: error message matching (quotemeta fix) -Parser fixes complete. Need to verify Moo's `extends` keyword now works. +**Remaining blockers**: +- DEMOLISH (destructors - not supported, expected) +- Spurious anonymous hash warnings in TAP::Harness ### Completed Phases - [x] Phase 1: Replace Carp.java with Carp.pm (2024-03-14) @@ -354,25 +410,160 @@ Parser fixes complete. Need to verify Moo's `extends` keyword now works. - [x] Phase 8: Implement Internals::stack_refcounted (2024-03-15) - Returns 1 for RC stack behavior - Fixed op/array.t: 116 → 175 passing tests +- [x] Phase 9: Fix goto &sub in use/import (2024-03-15) + - Added TAILCALL trampoline in StatementParser.parseUseDeclaration() + - Moo::Role now correctly exports has, with, requires + - Moo test pass rate: 591 → 687 tests (+96) +- [x] Phase 10: jcpan Test::Harness integration (2024-03-15) + - Added Test::Harness and TAP:: modules + - Fixed version parsing for "undef" strings + - Fixed MM->parse_version() via ExtUtils::MM loading + - Added Sub::Util Java implementation (set_subname) + - Added Scalar/List::Util $VERSION for CPAN detection + - XSLoader stubs for .pm file version detection + +- [x] Phase 11: Fix return @array in scalar context (2024-03-15) + - `return @array` now returns count in scalar context (was returning last element) + - Fixed TAP::Harness panic: "planned test count did not equal sum of passed and failed" + - JVM backend: emitRuntimeContextConversion() in EmitVariable.java + - Interpreter: SCALAR_IF_WANTARRAY opcode (388) + +- [x] Phase 12: Fix quotemeta underscore escaping (2024-03-15) + - Perl's `quotemeta` does NOT escape underscore (`_`) - it's part of `\w` + - Fixed StringOperators.java to treat `_` like alphanumeric characters + - Fixes Moo tests t/accessor-coerce.t, t/accessor-isa.t error message matching + +- [x] Phase 13: Fix Package::SUPER::method resolution (2024-03-15) + - Moo uses `$class->Package::SUPER::new(@_)` to explicitly specify parent + - Previously only `SUPER::method` (no package prefix) was supported + - Added handling in RuntimeCode.java to detect `::SUPER::` pattern + - Extracts package name and method, resolves from that package's parent + - Fixes t/extends-non-moo.t (10/10 tests now pass) + +- [x] Phase 14: Fix print { func() } filehandle block parsing (2024-03-15) + - Root cause: `print { get_fh() } "text"` was parsed as anonymous hash, not block + - The `{...}` was being miscompiled as `CREATE_HASH` instead of evaluating the expression + - **Parser fix (FileHandle.java)**: + - When identifier is followed by `(`, parse as function call expression + - Added fallback to parse any bracketed expression as filehandle block + - **JVM codegen fix (EmitOperator.java)**: + - handleSayOperator now uses register spilling for arguments + - Fixes ASM frame compute crash when filehandle is complex expression + - This fixed the majority of "Odd number of elements in anonymous hash" warnings + - Test: `print { get_fh() } "text\n"` now works correctly + +- [x] Phase 15: Fix print { $var->method } filehandle blocks (2026-03-15) + - Root cause: `print { $self->stdout }` and `print { shift->stdout }` were being miscompiled + - The `{ ... }` was treated as anonymous hash instead of filehandle block + - **FileHandle.java fixes**: + - When `hasBracket` is true and token is `$`, parse as full expression (not just primary) + - This captures method chains like `$self->stdout` + - When identifier is followed by `->`, parse as expression (for `shift->stdout`) + - Added early detection of hash patterns: `{ identifier => }` or `{ identifier , }` returns null immediately + - **Result**: All "Odd number of elements in anonymous hash" warnings eliminated from Moo tests + - Test: `print { $self->stdout } @_` now works correctly + +- [x] Phase 16: Fix local @_ in string eval context (2026-03-15) + - Root cause: `local @_` inside string eval was throwing "Can't localize lexical variable @_" + - The issue: @_ is registered as "reserved" in the symbol table (register 1), but the + localization check only excluded "our" variables + - **BytecodeCompiler.java fixes**: + - Added `isReservedVariable()` method to check for "reserved" declaration type + - Updated 7 occurrences of the localization check to also exclude reserved variables + - **CompileAssignment.java**: Updated 1 occurrence + - This fixes Sub::Quote generated code that uses `local @_` + +- [x] Phase 17: Extend print { hash } detection for string keys and whitespace (2026-03-15) + - Root cause: `print { "a", 2 }` was incorrectly parsed as filehandle block + - The parser wasn't skipping WHITESPACE tokens when scanning ahead after `{` + - **FileHandle.java fixes**: + - Added whitespace skipping when looking for hash patterns + - Added detection for string literal keys (`"..."` or `'...'`) followed by `,` or `=>` + - Added detection for numeric keys followed by `,` + - Now correctly recognizes `{ "key", value }`, `{ "key" => value }`, `{ 123, value }` + - Test: `print { "a", 2 }` now prints `HASH(0x...)` as expected + +- [x] Phase 18: Fix subroutine redefinition to preserve old code references (2026-03-15) + - Root cause: When a subroutine is redefined via eval, saved code references (from `\&sub` + or `can()`) were being affected because the same RuntimeCode object was modified in place + - The `around` modifier in Class::Method::Modifiers calls `$into->can($name)` to get + the original method, then redefines it with a wrapper. The wrapper calls `$orig->(@_)` + expecting the original, but was getting the new wrapper (infinite recursion) + - **SubroutineParser.java fixes**: + - When redefining a sub that already has code (subroutine, methodHandle, codeObject, + or compilerSupplier set), create a NEW RuntimeCode instead of reusing the existing one + - Old references continue pointing to the old RuntimeCode + - **RuntimeCode.java fixes**: + - `createCodeReference()` now returns a snapshot RuntimeScalar (new RuntimeScalar with + same type/value) instead of the global entry directly + - This ensures `\&foo` captures the current RuntimeCode, not a mutable reference + - This matches Perl's behavior where: `my $orig = \&foo; sub foo {"new"}; $orig->()` returns "old" + - Moo tests improved from 20/71 to 16/71 failing test programs + +- [x] Phase 19: Fix glob assignment to properly alias arrays and hashes (2026-03-15) + - Root cause: `*INFO = \%Role::Tiny::INFO` was copying hash contents instead of aliasing + - Moo::Role uses `*INFO = \%Role::Tiny::INFO` to share the same %INFO hash + - But when Moo::Role later did `our %INFO`, PerlOnJava created a new hash instead of + using the aliased one + - **RuntimeGlob.java fixes**: + - For ARRAYREFERENCE type: `GlobalVariable.globalArrays.put(globName, arr)` (was setFromList) + - For HASHREFERENCE type: `GlobalVariable.globalHashes.put(globName, hash)` (was setFromList) + - This creates true aliases where both names refer to the same container + - compose-roles.t: 4 failing tests → all 25 passing + - Overall: 15 failing test programs → 12 failing test programs + +### Current Status + +**Test Results (after Phase 19):** +- 58/71 test programs passing (82%) +- ~770/816 subtests passing (94%) +- compose-roles.t fully passing (25/25) + +**Remaining Failures (categorized):** +1. **DEMOLISH tests** (6 failures) - Expected failures (DESTROY not supported) +2. **accessor-weaken tests** (20 failures) - Expected, weak references not supported in Java GC +3. **croak-locations tests** (29 failures) - Carp reports `(eval N)` instead of actual filename +4. **no-moo.t** (5 failures) - Cleanup of extends/has not working +5. **method-generate-accessor.t** (8 failures) - Various edge cases +6. **Other minor issues** - load_module_role_tiny.t, coerce-1.t, etc. + +- [x] Phase 20: Fix isa("main::ClassName") not matching class blessed as "ClassName" (2026-03-15) + - Root cause: `isa("main::Foo")` was comparing literally against linearized class list containing `"Foo"` + - In Perl, `main::Foo` and `Foo` are equivalent class names for the main package + - **Universal.java fixes**: + - Normalize the `argString` before comparing: strip `main::` or `::` prefix + - This allows `$obj->isa("main::Foo")` to match when blessed as `"Foo"` + - Fixes uni/universal.t tests 3 and 6 (and similar tests) + - Test: `bless({}, "Foo")->isa("main::Foo")` now returns true + +- [x] Phase 21: Fix `undef %hash` not clearing hashes in scalar context (2026-03-15) + - Root cause: Phase 11's `emitRuntimeContextConversion()` was being applied to `undef %hash` + - The `handleUndefOperator` used `RuntimeContextType.RUNTIME` to visit the operand + - When the containing subroutine was called in scalar context (e.g., `my $r = func()`), + the hash was converted to a scalar (key count) before `undefine()` was called + - This caused `undef %fetched` in ExifTool's PDF.pm to silently do nothing + - **EmitOperator.java fix**: + - Changed `handleUndefOperator` to use `RuntimeContextType.LIST` instead of `RUNTIME` + - This ensures the actual hash/array container is passed to `undefine()`, not a scalar + - ExifTool PDF.t now passes all 26 tests (was 7/26) ### Next Steps -1. **Test Moo extends** - Verify `extends 'Parent'` now works -2. **Run Moo test suite** - `jcpan -t Moo` to check test pass rate -3. **Fix remaining failures** - Debug any remaining test failures +1. **Fix no-moo.t cleanup** - `no Moo` should remove `extends`, `has`, etc. from namespace + +2. **Prototype checking** - `$$` prototype should accept `@array` argument (workaround: removed prototype) + +3. **DEMOLISH support** - Expected to remain unsupported (requires DESTROY/GC hooks) ### PR Information -- **Branch**: `feature/moo-support` -- **PR**: https://github.com/fglock/PerlOnJava/pull/319 -- **Commits**: - - `66bfe37a6` - Initial Moo support (Carp.pm, @; fix) - - `150bc23e8` - Fix x => autoquoting and goto &$coderef - - `9188c3d76` - Fix jcpan Unix wrapper - - `f4bc5594e` - Fix Storable YAML codePointLimit - - `42903b3cb` - Fix parser for @{*{expr}} glob dereference - - `75700c220` - Fix regressions in parser and string interpolation - - `2762e6d68` - Implement Internals::stack_refcounted - - `00c256b75` - Add detailed comments explaining fixes +- **Branch**: `feature/moo-support` (PR #319 - merged) +- **Branch**: `fix/goto-tailcall-import` (PR #320 - open) +- **Key commits**: + - `00c124167` - Fix print { func() } filehandle block parsing and JVM codegen + - `393bedf0f` - Fix quotemeta and Package::SUPER::method resolution + - `7a76739b8` - Fix goto &sub in use/import TAILCALL handling + - `053d91a95` - Add Sub::Util, fix Scalar/List::Util VERSION, add Test::Harness + - `7993ef74d` - Fix version parsing and MM->parse_version for CPAN.pm ## Related Documents diff --git a/dev/import-perl5/config.yaml b/dev/import-perl5/config.yaml index 9a3eaf5d9..8c367e7a2 100644 --- a/dev/import-perl5/config.yaml +++ b/dev/import-perl5/config.yaml @@ -391,6 +391,15 @@ imports: target: src/main/perl/lib type: directory + # Test::Harness - Test harness for running tests (needed by CPAN make test) + - source: perl5/cpan/Test-Harness/lib/Test/Harness.pm + target: src/main/perl/lib/Test/Harness.pm + + # TAP - Test Anything Protocol modules (required by Test::Harness) + - source: perl5/cpan/Test-Harness/lib/TAP + target: src/main/perl/lib/TAP + type: directory + # Tests for distribution - source: perl5/cpan/Test-Simple/t target: perl5_t/Test-Simple @@ -524,6 +533,28 @@ imports: target: src/main/perl/lib/CPAN/Meta/Requirements type: directory + # ExtUtils::MakeMaker - PerlOnJava custom implementations + # These are protected because they have PerlOnJava-specific logic + + # MakeMaker.pm - Custom implementation that directly installs pure-Perl modules + # and generates MYMETA.yml for CPAN.pm dependency resolution + - source: perl5/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm + target: src/main/perl/lib/ExtUtils/MakeMaker.pm + protected: true + + # MM.pm - Modified to detect PerlOnJava and load MM_PerlOnJava + - source: perl5/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm + target: src/main/perl/lib/ExtUtils/MM.pm + protected: true + + # MM_Unix.pm - Minimal stub with parse_version for CPAN.pm + - source: perl5/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm + target: src/main/perl/lib/ExtUtils/MM_Unix.pm + protected: true + + # MM_PerlOnJava.pm - PerlOnJava-specific MakeMaker subclass (no upstream source) + # This file is created by PerlOnJava, not imported from perl5 + # Add more imports below as needed # Example with minimal fields: # - source: perl5/lib/SomeModule.pm diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 972d1ad6a..03946e53f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -250,6 +250,11 @@ boolean isOurVariable(String name) { return entry != null && "our".equals(entry.decl()); } + boolean isReservedVariable(String name) { + SymbolTable.SymbolEntry entry = symbolTable.getSymbolEntry(name); + return entry != null && "reserved".equals(entry.decl()); + } + int getVariableRegister(String name) { return symbolTable.getVariableIndex(name); } @@ -3022,7 +3027,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { if (sigil.equals("$") && sigilOp.operand instanceof IdentifierNode) { String varName = "$" + ((IdentifierNode) sigilOp.operand).name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); return; } @@ -3055,7 +3060,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { if ((sigil.equals("@") || sigil.equals("%")) && sigilOp.operand instanceof IdentifierNode idNode) { String varName = sigil + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); return; } @@ -3106,7 +3111,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { String originalSigil = innerOp.operator; String varName = originalSigil + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); return; } @@ -3225,7 +3230,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { String varName = varNode.operator + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); } @@ -3275,7 +3280,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { nestedVarNode.operand instanceof IdentifierNode idNode) { String varName = nestedVarNode.operator + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); } @@ -3307,7 +3312,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { String originalSigil = varNode.operator; String varName = originalSigil + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); } @@ -3345,7 +3350,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { varRegs.add(rd); } else { String varName = sigil + idNode.name; - if (hasVariable(varName) && !isOurVariable(varName)) { + if (hasVariable(varName) && !isOurVariable(varName) && !isReservedVariable(varName)) { throwCompilerException("Can't localize lexical variable " + varName); } String globalVarName = NameNormalizer.normalizeVariableName(idNode.name, getCurrentPackage()); @@ -3593,6 +3598,15 @@ void compileVariableReference(OperatorNode node, String op) { emitReg(rd); emitReg(arrayReg); lastResultReg = rd; + } else if (currentCallContext == RuntimeContextType.RUNTIME) { + // In RUNTIME context (e.g., return @a), check wantarray at runtime + // and convert to scalar (count) if scalar context + int rd = allocateOutputRegister(); + emit(Opcodes.SCALAR_IF_WANTARRAY); + emitReg(rd); + emitReg(arrayReg); + emitReg(2); // wantarray is in register 2 + lastResultReg = rd; } else { lastResultReg = arrayReg; } diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 8b9590d33..e2cbb2620 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -1367,6 +1367,10 @@ public static RuntimeList execute(InterpretedCode code, RuntimeArray args, int c pc = InlineOpcodeHandler.executeCreateList(bytecode, pc, registers); } + case Opcodes.SCALAR_IF_WANTARRAY -> { + pc = InlineOpcodeHandler.executeScalarIfWantarray(bytecode, pc, registers, callContext); + } + // ================================================================= // STRING OPERATIONS // ================================================================= diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index f02dec02d..19fb3845d 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -34,7 +34,7 @@ private static boolean handleLocalAssignment(BytecodeCompiler bc, BinaryOperator if ((sigil.equals("$") || sigil.equals("@") || sigil.equals("%") || sigil.equals("*")) && sigilOp.operand instanceof IdentifierNode idNode) { String varName = sigil + idNode.name; - if (bc.hasVariable(varName) && !bc.isOurVariable(varName)) { + if (bc.hasVariable(varName) && !bc.isOurVariable(varName) && !bc.isReservedVariable(varName)) { bc.throwCompilerException("Can't localize lexical variable " + varName); return true; } diff --git a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java index 57088a622..3e385b0c5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java @@ -735,6 +735,29 @@ public static int executeCreateList(int[] bytecode, int pc, RuntimeBase[] regist return pc; } + /** + * Convert array/hash to scalar if wantarray indicates scalar context. + * Format: SCALAR_IF_WANTARRAY rd rs wantarray_reg + * This mirrors the JVM backend's emitRuntimeContextConversion() exactly. + */ + public static int executeScalarIfWantarray(int[] bytecode, int pc, RuntimeBase[] registers, int callContext) { + int rd = bytecode[pc++]; + int rs = bytecode[pc++]; + // wantarray_reg is not used - we use callContext directly (same as JVM's ILOAD 2) + pc++; // Skip wantarray_reg operand + + RuntimeBase val = registers[rs]; + + // If scalar context and value is array or hash, call .scalar() + if (callContext == RuntimeContextType.SCALAR && + (val instanceof RuntimeArray || val instanceof RuntimeHash)) { + registers[rd] = val.scalar(); + } else { + registers[rd] = val; + } + return pc; + } + /** * String join: rd = join(separator, list) * Format: JOIN rd separatorReg listReg diff --git a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java index 625f402c1..e84434cd3 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java @@ -1940,6 +1940,18 @@ public class Opcodes { */ public static final short DEFINED_GLOB = 386; + /** + * Convert array/hash to scalar if wantarray indicates scalar context. + * Format: SCALAR_IF_WANTARRAY rd rs wantarray_reg + * Effect: + * - If wantarray_reg == SCALAR (1): rd = rs.scalar() + * - Otherwise: rd = rs (unchanged) + * + * This mirrors the JVM backend's emitRuntimeContextConversion() exactly. + * Used for `return @array` to ensure arrays return count in scalar context. + */ + public static final short SCALAR_IF_WANTARRAY = 388; + private Opcodes() { } // Utility class - no instantiation } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitLiteral.java b/src/main/java/org/perlonjava/backend/jvm/EmitLiteral.java index 6072738a5..433bddaf0 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitLiteral.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitLiteral.java @@ -521,6 +521,10 @@ private static void addElementToList(MethodVisitor mv, Node element, int context if (contextType == RuntimeContextType.SCALAR) { // In scalar context, all elements are treated as scalars returnType = RuntimeDescriptorConstants.SCALAR_TYPE; + } else if (contextType == RuntimeContextType.RUNTIME) { + // In RUNTIME context, array/hash elements may have been converted to RuntimeBase + // via emitRuntimeContextConversion(), so we must use the generic add(RuntimeBase) + returnType = RuntimeDescriptorConstants.BASE_TYPE; } else { // Use static analysis to determine the element's return type returnType = ReturnTypeVisitor.getReturnType(element); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java index 8d62a6581..cb78c7d17 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java @@ -186,12 +186,31 @@ static void handleTruncateOperator(EmitterVisitor emitterVisitor, BinaryOperator // Handles the 'say' operator for outputting data. static void handleSayOperator(EmitterVisitor emitterVisitor, BinaryOperatorNode node) { String operator = node.operator; + MethodVisitor mv = emitterVisitor.ctx.mv; + // Emit the argument list in LIST context. node.right.accept(emitterVisitor.with(RuntimeContextType.LIST)); + // Spill the argument list to a local variable to avoid ASM frame issues + // when the filehandle is a complex expression (e.g., function call) + int argSlot = emitterVisitor.ctx.javaClassInfo.acquireSpillSlot(); + boolean pooledArg = argSlot >= 0; + if (!pooledArg) { + argSlot = emitterVisitor.ctx.symbolTable.allocateLocalVariable(); + } + mv.visitVarInsn(Opcodes.ASTORE, argSlot); + // Emit the File Handle emitFileHandle(emitterVisitor.with(RuntimeContextType.SCALAR), node.left); + // Reload the argument list and swap to get correct order for IOOperator.print + mv.visitVarInsn(Opcodes.ALOAD, argSlot); + mv.visitInsn(Opcodes.SWAP); + + if (pooledArg) { + emitterVisitor.ctx.javaClassInfo.releaseSpillSlot(); + } + // Call the operator, return Scalar emitterVisitor.ctx.mv.visitMethodInsn(Opcodes.INVOKESTATIC, "org/perlonjava/runtime/operators/IOOperator", operator, "(Lorg/perlonjava/runtime/runtimetypes/RuntimeList;Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); // If the context is VOID, pop the result from the stack. @@ -852,7 +871,10 @@ static void handleUndefOperator(EmitterVisitor emitterVisitor, OperatorNode node } return; } - node.operand.accept(emitterVisitor.with(RuntimeContextType.RUNTIME)); + // Use LIST context to avoid runtime context conversion that would convert + // hashes/arrays to scalars when the containing subroutine is called in scalar context. + // The undef operator needs the actual container to call undefine() on it. + node.operand.accept(emitterVisitor.with(RuntimeContextType.LIST)); emitterVisitor.ctx.mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeList", "undefine", diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index 9d0883d21..bbc9a2a5a 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -113,6 +113,72 @@ private static boolean isBuiltinSpecialContainerVar(String sigil, String name) { return false; } + /** + * Emits bytecode to handle RUNTIME context conversion for arrays and hashes. + * + *

When an array or hash is used in RUNTIME context (e.g., {@code return @a}), + * we need to check wantarray at runtime: + *

+ * + *

This is needed because in Perl: + *

+ * + * @param emitterVisitor The visitor handling the bytecode emission + * @param sigil The variable sigil (@ or %) + */ + private static void emitRuntimeContextConversion(EmitterVisitor emitterVisitor, String sigil) { + MethodVisitor mv = emitterVisitor.ctx.mv; + + // Stack has the array/hash. We need to check wantarray (slot 2) and decide: + // - If wantarray == SCALAR (1), call .scalar() and return the count + // - Otherwise, leave the array/hash as-is + // + // IMPORTANT: We must store the result to a register and reload it so that + // both branches converge with the same type on the stack (RuntimeBase). + // Direct stack manipulation causes VerifyError because the branches have + // different types (RuntimeScalar vs RuntimeArray/Hash). + + Label notScalarContext = new Label(); + Label done = new Label(); + + // Store the array/hash temporarily + int inputSlot = emitterVisitor.ctx.symbolTable.allocateLocalVariable(); + mv.visitVarInsn(Opcodes.ASTORE, inputSlot); + + // Allocate result slot - will hold RuntimeBase (common supertype) + int resultSlot = emitterVisitor.ctx.symbolTable.allocateLocalVariable(); + + // Load wantarray (slot 2 = callContext parameter) + mv.visitVarInsn(Opcodes.ILOAD, 2); + + // Check if wantarray == RuntimeContextType.SCALAR (1) + mv.visitInsn(Opcodes.ICONST_1); + mv.visitJumpInsn(Opcodes.IF_ICMPNE, notScalarContext); + + // Scalar context: load array/hash and call .scalar(), store to result + mv.visitVarInsn(Opcodes.ALOAD, inputSlot); + mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeBase", "scalar", + "()Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); + mv.visitVarInsn(Opcodes.ASTORE, resultSlot); + mv.visitJumpInsn(Opcodes.GOTO, done); + + // List/void context: store input as-is to result + mv.visitLabel(notScalarContext); + mv.visitVarInsn(Opcodes.ALOAD, inputSlot); + mv.visitVarInsn(Opcodes.ASTORE, resultSlot); + + // Both branches converge here - load result from register + mv.visitLabel(done); + mv.visitVarInsn(Opcodes.ALOAD, resultSlot); + } + /** * Emits bytecode to fetch a global (package) variable. * @@ -388,6 +454,10 @@ static void handleVariableOperator(EmitterVisitor emitterVisitor, OperatorNode n // In scalar context, convert array/hash to scalar (e.g., array length, hash key count) if (emitterVisitor.ctx.contextType == RuntimeContextType.SCALAR && !sigil.equals("$")) { mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeBase", "scalar", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); + } else if (emitterVisitor.ctx.contextType == RuntimeContextType.RUNTIME && !sigil.equals("$")) { + // In RUNTIME context (e.g., return @a), check wantarray at runtime + // If scalar context, return the count; otherwise return the array/hash as-is + emitRuntimeContextConversion(emitterVisitor, sigil); } if (CompilerOptions.DEBUG_ENABLED) emitterVisitor.ctx.logDebug("GETVAR end " + symbolEntry); @@ -408,6 +478,8 @@ static void handleVariableOperator(EmitterVisitor emitterVisitor, OperatorNode n } if (emitterVisitor.ctx.contextType == RuntimeContextType.SCALAR) { mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeArray", "scalar", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); + } else if (emitterVisitor.ctx.contextType == RuntimeContextType.RUNTIME) { + emitRuntimeContextConversion(emitterVisitor, sigil); } return; case "%": @@ -424,6 +496,8 @@ static void handleVariableOperator(EmitterVisitor emitterVisitor, OperatorNode n } if (emitterVisitor.ctx.contextType == RuntimeContextType.SCALAR) { mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeHash", "scalar", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); + } else if (emitterVisitor.ctx.contextType == RuntimeContextType.RUNTIME) { + emitRuntimeContextConversion(emitterVisitor, sigil); } return; case "$": diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 5829c7b14..a85fe0308 100644 --- a/src/main/java/org/perlonjava/core/Configuration.java +++ b/src/main/java/org/perlonjava/core/Configuration.java @@ -33,7 +33,7 @@ public final class Configuration { * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitId = "75700c220"; + public static final String gitCommitId = "e78cba6d4"; /** * Git commit date of the build (ISO format: YYYY-MM-DD). diff --git a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java index f61cae964..5d2fd49da 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java +++ b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java @@ -80,6 +80,88 @@ public static Node parseFileHandle(Parser parser) { // Check if the file handle is enclosed in curly braces // Perl allows {FILEHANDLE} syntax for disambiguation if (peek(parser).text.equals("{")) { + // Before consuming {, check if this looks like an anonymous hash + // Hash patterns include: + // { identifier => ... } or { identifier , ... } + // { "string" , ... } or { "string" => ... } + // { 'string' , ... } or { 'string' => ... } + // { number , ... } + int idx = parser.tokenIndex + 1; + + // Skip whitespace tokens + while (idx < parser.tokens.size() && + parser.tokens.get(idx).type == LexerTokenType.WHITESPACE) { + idx++; + } + + if (idx < parser.tokens.size()) { + LexerToken afterBrace = parser.tokens.get(idx); + + // Check for identifier followed by => or , + if (afterBrace.type == LexerTokenType.IDENTIFIER) { + int nextIdx = idx + 1; + // Skip whitespace + while (nextIdx < parser.tokens.size() && + parser.tokens.get(nextIdx).type == LexerTokenType.WHITESPACE) { + nextIdx++; + } + if (nextIdx < parser.tokens.size()) { + LexerToken afterIdent = parser.tokens.get(nextIdx); + if (afterIdent.text.equals("=>") || afterIdent.text.equals(",")) { + // This is { a => ... } or { a, ... } - it's a hash, not filehandle + return null; + } + } + } + + // Check for string literal followed by => or , + // Strings are lexed with the opening quote as OPERATOR + if (afterBrace.type == LexerTokenType.OPERATOR && + (afterBrace.text.equals("\"") || afterBrace.text.equals("'"))) { + // Scan forward to find the closing quote, then check for , or => + // For simplicity, look for the pattern: quote ... quote (comma or =>) + String quoteChar = afterBrace.text; + int scanIdx = idx + 1; + int depth = 1; + while (scanIdx < parser.tokens.size() && depth > 0) { + LexerToken scanToken = parser.tokens.get(scanIdx); + if (scanToken.type == LexerTokenType.OPERATOR && scanToken.text.equals(quoteChar)) { + depth--; + } + scanIdx++; + } + // Skip whitespace after the closing quote + while (scanIdx < parser.tokens.size() && + parser.tokens.get(scanIdx).type == LexerTokenType.WHITESPACE) { + scanIdx++; + } + // Check for , or => + if (scanIdx < parser.tokens.size()) { + LexerToken afterString = parser.tokens.get(scanIdx); + if (afterString.text.equals(",") || afterString.text.equals("=>")) { + // This is { "a", ... } or { "a" => ... } - it's a hash + return null; + } + } + } + + // Check for number followed by , + if (afterBrace.type == LexerTokenType.NUMBER) { + int nextIdx = idx + 1; + // Skip whitespace + while (nextIdx < parser.tokens.size() && + parser.tokens.get(nextIdx).type == LexerTokenType.WHITESPACE) { + nextIdx++; + } + if (nextIdx < parser.tokens.size()) { + LexerToken afterNum = parser.tokens.get(nextIdx); + if (afterNum.text.equals(",")) { + // This is { 1, ... } - it's a hash + return null; + } + } + } + } TokenUtils.consume(parser); hasBracket = true; } @@ -97,28 +179,42 @@ public static Node parseFileHandle(Parser parser) { // Handle bareword file handles (most common case) // Examples: STDOUT, STDERR, STDIN, or user-defined handles like LOG, FILE, etc. else if (token.type == LexerTokenType.IDENTIFIER) { - // Try to parse as a bareword identifier - // parseSubroutineIdentifier handles qualified names like Some::Package::HANDLE - String name = IdentifierParser.parseSubroutineIdentifier(parser); - if (name != null) { - fileHandle = parseBarewordHandle(parser, name); - if (fileHandle == null && name.matches("^[A-Z_][A-Z0-9_]*$")) { - GlobalVariable.getGlobalIO(normalizeBarewordHandle(parser, name)); + // Check if this is a function call or method chain + // In that case, we need to parse it as an expression, not a bareword + LexerToken nextToken = parser.tokens.get(parser.tokenIndex + 1); + if (hasBracket && (nextToken.text.equals("(") || nextToken.text.equals("->"))) { + // This is a function call like { get_fh() } or method chain like { shift->stdout } + // Parse as expression to capture the full call/chain + fileHandle = parser.parseExpression(0); + } else { + // Try to parse as a bareword identifier + // parseSubroutineIdentifier handles qualified names like Some::Package::HANDLE + String name = IdentifierParser.parseSubroutineIdentifier(parser); + if (name != null) { fileHandle = parseBarewordHandle(parser, name); + if (fileHandle == null && name.matches("^[A-Z_][A-Z0-9_]*$")) { + GlobalVariable.getGlobalIO(normalizeBarewordHandle(parser, name)); + fileHandle = parseBarewordHandle(parser, name); + } } } } // Handle scalar variable file handles // Modern Perl idiom: open my $fh, '<', 'filename'; print $fh "text"; else if (token.text.equals("$")) { - // Parse the scalar variable - fileHandle = ParsePrimary.parsePrimary(parser); + if (hasBracket) { + // When bracketed, parse as a full expression to capture method chains + // Example: print { $self->stdout } "text" + // This ensures $self->stdout is parsed as a complete expression + fileHandle = parser.parseExpression(0); + } else { + // Parse the scalar variable + fileHandle = ParsePrimary.parsePrimary(parser); - // When not bracketed, we need to disambiguate between: - // - print $fh "text"; # $fh is a file handle - // - print $fh + 2; # $fh is part of an expression - // - print $fh; # ambiguous case - if (!hasBracket) { + // When not bracketed, we need to disambiguate between: + // - print $fh "text"; # $fh is a file handle + // - print $fh + 2; # $fh is part of an expression + // - print $fh; # ambiguous case // Check if the next token is an infix operator // If so, this is likely an expression, not a file handle String nextText = peek(parser).text; @@ -143,6 +239,11 @@ else if (token.text.equals("$")) { } } } + // Handle expression in brackets (for any other case like method calls) + else if (hasBracket) { + // Parse as a general expression: { $obj->method } etc. + fileHandle = parser.parseExpression(0); + } // If we had an opening bracket, consume the closing bracket if (hasBracket) { diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index c10fe924a..2547d933c 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -819,7 +819,11 @@ static BinaryOperatorNode parseJoin(Parser parser, LexerToken token, String oper if (token.text.equals("push") || token.text.equals("unshift")) { var op = separator; - if (op instanceof OperatorNode operatorNode && operatorNode.operator.equals("my")) { + // Unwrap my/our/local declarations to get to the underlying array + if (op instanceof OperatorNode operatorNode && + (operatorNode.operator.equals("my") || + operatorNode.operator.equals("our") || + operatorNode.operator.equals("local"))) { op = operatorNode.operand; } if (!(op instanceof OperatorNode operatorNode && operatorNode.operator.equals("@"))) { diff --git a/src/main/java/org/perlonjava/frontend/parser/StatementParser.java b/src/main/java/org/perlonjava/frontend/parser/StatementParser.java index deed326f3..9122e25ed 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StatementParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StatementParser.java @@ -655,7 +655,20 @@ public static Node parseUseDeclaration(Parser parser, LexerToken token) { RuntimeArray importArgs = args.getArrayOfAlias(); RuntimeArray.unshift(importArgs, new RuntimeScalar(packageName)); setCurrentScope(parser.ctx.symbolTable); - RuntimeCode.apply(code, importArgs, RuntimeContextType.SCALAR); + RuntimeList res = RuntimeCode.apply(code, importArgs, RuntimeContextType.SCALAR); + + // Handle TAILCALL with trampoline loop (for goto &sub in import methods) + // This is needed for Moo::Role which does: goto &Role::Tiny::import + while (res.isNonLocalGoto()) { + RuntimeControlFlowList flow = (RuntimeControlFlowList) res; + if (flow.getControlFlowType() == ControlFlowType.TAILCALL) { + RuntimeScalar codeRef = flow.getTailCallCodeRef(); + RuntimeArray callArgs = flow.getTailCallArgs(); + res = RuntimeCode.apply(codeRef, "tailcall", callArgs, RuntimeContextType.SCALAR); + } else { + break; + } + } } } } diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index e8f830638..6bd4f4502 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -662,7 +662,23 @@ public static ListNode handleNamedSubWithFilter(Parser parser, String subName, S String fullName = NameNormalizer.normalizeVariableName(subName, packageToUse); RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(fullName); InheritanceResolver.invalidateCache(); - if (codeRef.value == null) { + + // Check if we're redefining an existing subroutine that already has code. + // In that case, create a NEW RuntimeCode so that saved code references + // (from \&sub or can()) continue pointing to the old implementation. + // This matches Perl's behavior where: + // my $orig = \&foo; sub foo { "new" }; $orig->() returns "old" + boolean isRedefinition = false; + if (codeRef.value instanceof RuntimeCode existingCode) { + // Check if the existing code has actual implementation OR pending compilation + // compilerSupplier != null means there's a lazy definition waiting to be compiled + isRedefinition = existingCode.subroutine != null + || existingCode.methodHandle != null + || existingCode.codeObject != null + || existingCode.compilerSupplier != null; + } + + if (codeRef.value == null || isRedefinition) { codeRef.type = RuntimeScalarType.CODE; codeRef.value = new RuntimeCode(subName, attributes); } diff --git a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java index 207781943..e34f40ef7 100644 --- a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java +++ b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java @@ -12,7 +12,7 @@ public class InheritanceResolver { // Cache for linearized class hierarchies static final Map> linearizedClassesCache = new HashMap<>(); - private static final boolean TRACE_METHOD_RESOLUTION = false; + private static final boolean TRACE_METHOD_RESOLUTION = false; // Set to true for debugging // Per-package MRO settings private static final Map packageMRO = new HashMap<>(); // Method resolution cache diff --git a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java index 487ffe256..510290542 100644 --- a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java @@ -65,8 +65,9 @@ public static RuntimeScalar quotemeta(RuntimeScalar runtimeScalar) { StringBuilder quoted = new StringBuilder(); // Iterate over each character in the string for (char c : runtimeScalar.toString().toCharArray()) { - // If the character is alphanumeric, append it as is - if (Character.isLetterOrDigit(c)) { + // If the character is alphanumeric or underscore, append it as is + // Perl's quotemeta does NOT escape underscore (it's part of \w) + if (Character.isLetterOrDigit(c) || c == '_') { quoted.append(c); } else { // Otherwise, escape it with a backslash diff --git a/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java b/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java index 8b809a469..2de094029 100644 --- a/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java +++ b/src/main/java/org/perlonjava/runtime/operators/VersionHelper.java @@ -205,6 +205,12 @@ public static RuntimeScalar compareVersion(RuntimeScalar hasVersion, RuntimeScal public static String normalizeVersion(RuntimeScalar wantVersion) { String normalizedVersion = wantVersion.toString(); + + // Handle special case: "undef" is returned by MM_Unix.parse_version when no version found + if (normalizedVersion.equals("undef") || normalizedVersion.isEmpty()) { + return "0.0.0"; + } + if (normalizedVersion.startsWith("v")) { normalizedVersion = normalizedVersion.substring(1); } @@ -223,9 +229,18 @@ public static String normalizeVersion(RuntimeScalar wantVersion) { if (patch.length() > 3) { patch = patch.substring(0, 3); } - int majorNumber = Integer.parseInt(major); - int minorNumber = Integer.parseInt(minor); - int patchNumber = Integer.parseInt(patch); + // Handle non-numeric version parts gracefully + int majorNumber; + int minorNumber; + int patchNumber; + try { + majorNumber = Integer.parseInt(major); + minorNumber = Integer.parseInt(minor); + patchNumber = Integer.parseInt(patch); + } catch (NumberFormatException e) { + // If version parts aren't numeric, return 0.0.0 + return "0.0.0"; + } normalizedVersion = String.format("%d.%d.%d", majorNumber, minorNumber, patchNumber); } } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ListUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/ListUtil.java index 295b82880..07b626b4f 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ListUtil.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ListUtil.java @@ -31,6 +31,8 @@ public ListUtil() { */ public static void initialize() { ListUtil listUtil = new ListUtil(); + // Set $VERSION so CPAN.pm can detect our bundled version + GlobalVariable.getGlobalVariable("List::Util::VERSION").set(new RuntimeScalar("1.63")); try { // List reduction functions listUtil.registerMethod("reduce", "reduce", "&@"); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java index b36c09e16..1b871ee33 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java @@ -25,6 +25,8 @@ public ScalarUtil() { public static void initialize() { ScalarUtil scalarUtil = new ScalarUtil(); scalarUtil.initializeExporter(); // Use the base class method to initialize the exporter + // Set $VERSION so CPAN.pm can detect our bundled version + GlobalVariable.getGlobalVariable("Scalar::Util::VERSION").set(new RuntimeScalar("1.63")); scalarUtil.defineExport("EXPORT_OK", "blessed", "refaddr", "reftype", "weaken", "unweaken", "isweak", "dualvar", "isdual", "isvstring", "looks_like_number", "openhandle", "readonly", "set_prototype", "tainted"); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/SubUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/SubUtil.java new file mode 100644 index 000000000..911ba6755 --- /dev/null +++ b/src/main/java/org/perlonjava/runtime/perlmodule/SubUtil.java @@ -0,0 +1,147 @@ +package org.perlonjava.runtime.perlmodule; + +import org.perlonjava.runtime.runtimetypes.*; + +import static org.perlonjava.runtime.runtimetypes.RuntimeScalarType.*; + +/** + * Sub::Util module implementation for PerlOnJava. + * Provides utility functions for working with subroutines. + */ +public class SubUtil extends PerlModuleBase { + + /** + * Constructor for SubUtil. + */ + public SubUtil() { + super("Sub::Util"); + } + + /** + * Static initializer to set up the Sub::Util module. + */ + public static void initialize() { + SubUtil subUtil = new SubUtil(); + subUtil.initializeExporter(); + // Set $VERSION so CPAN.pm can detect our bundled version + GlobalVariable.getGlobalVariable("Sub::Util::VERSION").set(new RuntimeScalar("1.63")); + subUtil.defineExport("EXPORT_OK", "prototype", "set_prototype", "subname", "set_subname"); + try { + subUtil.registerMethod("prototype", "$"); + subUtil.registerMethod("set_prototype", null); // No prototype to allow @_ passing + subUtil.registerMethod("subname", "$"); + subUtil.registerMethod("set_subname", null); // No prototype to allow @_ passing + } catch (NoSuchMethodException e) { + System.err.println("Warning: Missing Sub::Util method: " + e.getMessage()); + } + } + + /** + * Returns the prototype of a subroutine. + * + * @param args The arguments: a CODE reference + * @param ctx The context + * @return The prototype string or undef + */ + public static RuntimeList prototype(RuntimeArray args, int ctx) { + if (args.size() != 1) { + throw new IllegalStateException("Bad number of arguments for prototype()"); + } + RuntimeScalar codeRef = args.get(0); + if (codeRef.type != CODE) { + return new RuntimeScalar().getList(); // undef for non-CODE + } + RuntimeCode code = (RuntimeCode) codeRef.value; + String proto = code.prototype; + if (proto == null) { + return new RuntimeScalar().getList(); // undef + } + return new RuntimeScalar(proto).getList(); + } + + /** + * Sets the prototype of a subroutine. + * + * @param args The arguments: prototype string, CODE reference + * @param ctx The context + * @return The CODE reference + */ + public static RuntimeList set_prototype(RuntimeArray args, int ctx) { + if (args.size() != 2) { + throw new IllegalStateException("Bad number of arguments for set_prototype()"); + } + RuntimeScalar protoScalar = args.get(0); + RuntimeScalar codeRef = args.get(1); + + if (codeRef.type != CODE) { + throw new IllegalArgumentException("set_prototype requires a CODE reference"); + } + + RuntimeCode code = (RuntimeCode) codeRef.value; + if (protoScalar.type == UNDEF) { + code.prototype = null; + } else { + code.prototype = protoScalar.toString(); + } + return codeRef.getList(); + } + + /** + * Returns the name of a subroutine. + * + * @param args The arguments: a CODE reference + * @param ctx The context + * @return The name of the subroutine + */ + public static RuntimeList subname(RuntimeArray args, int ctx) { + if (args.size() != 1) { + throw new IllegalStateException("Bad number of arguments for subname()"); + } + RuntimeScalar codeRef = args.get(0); + if (codeRef.type != CODE) { + return new RuntimeScalar().getList(); // undef for non-CODE + } + RuntimeCode code = (RuntimeCode) codeRef.value; + String pkg = code.packageName; + String sub = code.subName; + if (sub == null || sub.isEmpty()) { + return new RuntimeScalar("__ANON__").getList(); + } + if (pkg != null && !pkg.isEmpty()) { + return new RuntimeScalar(pkg + "::" + sub).getList(); + } + return new RuntimeScalar(sub).getList(); + } + + /** + * Sets the name of a subroutine. + * + * @param args The arguments: name string, CODE reference + * @param ctx The context + * @return The CODE reference + */ + public static RuntimeList set_subname(RuntimeArray args, int ctx) { + if (args.size() != 2) { + throw new IllegalStateException("Bad number of arguments for set_subname()"); + } + RuntimeScalar nameScalar = args.get(0); + RuntimeScalar codeRef = args.get(1); + + if (codeRef.type != CODE) { + throw new IllegalArgumentException("set_subname requires a CODE reference"); + } + + RuntimeCode code = (RuntimeCode) codeRef.value; + String fullName = nameScalar.toString(); + + // Parse package::subname format + int lastColon = fullName.lastIndexOf("::"); + if (lastColon >= 0) { + code.packageName = fullName.substring(0, lastColon); + code.subName = fullName.substring(lastColon + 2); + } else { + code.subName = fullName; + } + return codeRef.getList(); + } +} diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java index 9313816c7..c20aa0fa5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java @@ -133,7 +133,10 @@ public static RuntimeList can(RuntimeArray args, int ctx) { String normalizedName = NameNormalizer.normalizeVariableName(methodName, perlClassName); if (GlobalVariable.existsGlobalCodeRef(normalizedName)) { RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(normalizedName); - return codeRef.getList(); + // Only return the code ref if it's actually defined (has a real subroutine) + if (codeRef.getDefinedBoolean()) { + return codeRef.getList(); + } } // Fallback: if either the class name or method name was stored as UTF-8 octets @@ -229,7 +232,16 @@ public static RuntimeList isa(RuntimeArray args, int ctx) { // Get the linearized inheritance hierarchy using C3 List linearizedClasses = InheritanceResolver.linearizeHierarchy(perlClassName); - return new RuntimeScalar(linearizedClasses.contains(argString)).getList(); + // Normalize the argument: main::Foo -> Foo, ::Foo -> Foo + // This is needed because isa("main::Foo") should match a class blessed as "Foo" + String normalizedArg = argString; + if (normalizedArg.startsWith("main::")) { + normalizedArg = normalizedArg.substring(6); + } else if (normalizedArg.startsWith("::")) { + normalizedArg = normalizedArg.substring(2); + } + + return new RuntimeScalar(linearizedClasses.contains(normalizedArg)).getList(); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 20a1bb2a4..a48c41a77 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -166,6 +166,17 @@ public static boolean existsGlobalVariable(String key) { || key.endsWith("::b"); } + /** + * Checks if a global variable exists AND has a defined value, without auto-creating. + * + * @param key The key of the global variable. + * @return True if the variable exists and is defined, false otherwise. + */ + public static boolean isGlobalVariableDefined(String key) { + RuntimeScalar var = globalVariables.get(key); + return var != null && var.getDefinedBoolean(); + } + /** * Removes a global variable by its key. * @@ -294,6 +305,21 @@ public static boolean existsGlobalCodeRef(String key) { return globalCodeRefs.containsKey(key); } + /** + * Checks if a global code reference exists AND is defined (has a real subroutine), + * without auto-creating an entry. + * + * @param key The key of the global code reference. + * @return True if the code reference exists and is defined, false otherwise. + */ + public static boolean isGlobalCodeRefDefined(String key) { + RuntimeScalar var = globalCodeRefs.get(key); + if (var != null && var.type == RuntimeScalarType.CODE && var.value instanceof RuntimeCode runtimeCode) { + return runtimeCode.defined(); + } + return false; + } + public static RuntimeScalar existsGlobalCodeRefAsScalar(String key) { RuntimeScalar var = globalCodeRefs.get(key); if (var != null && var.type == RuntimeScalarType.CODE && var.value instanceof RuntimeCode runtimeCode) { @@ -435,6 +461,21 @@ public static boolean existsGlobalIO(String key) { return globalIORefs.containsKey(key); } + /** + * Checks if a global IO reference exists AND has an actual IO handle (not just an empty glob), + * without auto-creating an entry. + * + * @param key The key of the global IO reference. + * @return True if the IO reference exists and has a real IO handle, false otherwise. + */ + public static boolean isGlobalIODefined(String key) { + RuntimeGlob glob = globalIORefs.get(key); + if (glob != null && glob.type == RuntimeScalarType.GLOB) { + return glob.value instanceof RuntimeIO; + } + return false; + } + /** * Checks if a glob is defined (has any slot initialized). * Used for `defined *$var` which should not throw strict refs and not auto-vivify. @@ -544,6 +585,17 @@ public static RuntimeScalar existsGlobalFormatAsScalar(RuntimeScalar key) { return existsGlobalFormatAsScalar(key.toString()); } + /** + * Checks if a global format reference exists AND is defined, without auto-creating an entry. + * + * @param key The key of the global format reference. + * @return True if the format reference exists and is defined, false otherwise. + */ + public static boolean isGlobalFormatDefined(String key) { + RuntimeFormat format = globalFormatRefs.get(key); + return format != null && format.isFormatDefined(); + } + public static RuntimeScalar definedGlobalFormatAsScalar(String key) { return globalFormatRefs.containsKey(key) ? (globalFormatRefs.get(key).isFormatDefined() ? scalarTrue : scalarFalse) : scalarFalse; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 434563d60..4ea578696 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -1426,6 +1426,19 @@ public static RuntimeList call(RuntimeScalar runtimeScalar, // Handle SUPER::method calls if (methodName.startsWith("SUPER::")) { method = NextMethod.superMethod(currentSub, methodName); + } else if (methodName.contains("::SUPER::")) { + // Handle Package::SUPER::method syntax + // This is used by Moo to explicitly specify which package's parent to use + // Example: $class->GrandChild::SUPER::new(@_) + int superIdx = methodName.indexOf("::SUPER::"); + String packageName = methodName.substring(0, superIdx); + String actualMethod = methodName.substring(superIdx + 9); // skip "::SUPER::" + method = InheritanceResolver.findMethodInHierarchy( + actualMethod, + packageName, + methodName, // cache key includes the full qualified name + 1 // start looking in the parent package + ); } else { // Fully qualified method name - call the exact subroutine method = GlobalVariable.getGlobalCodeRef(methodName); @@ -1525,18 +1538,60 @@ public static RuntimeList caller(RuntimeList args, int ctx) { } // Populate @DB::args when caller() is called from package DB - if (calledFromDB && DebugState.debugMode) { + // Carp.pm relies on this to get function arguments for stack traces + if (calledFromDB) { RuntimeArray dbArgs = GlobalVariable.getGlobalArray("DB::args"); - RuntimeArray frameArgs = DebugState.getArgsForFrame(frame); - if (frameArgs != null) { - dbArgs.setFromList(frameArgs.getList()); + if (DebugState.debugMode) { + RuntimeArray frameArgs = DebugState.getArgsForFrame(frame); + if (frameArgs != null) { + dbArgs.setFromList(frameArgs.getList()); + } else { + dbArgs.setFromList(new RuntimeList()); + } } else { + // Not in debug mode - set to empty array + // This tells Carp we don't have args but prevents the + // "Incomplete caller override detected" message dbArgs.setFromList(new RuntimeList()); } } - // TODO: Add more caller() return values: - // hasargs, wantarray, evaltext, is_require, hints, bitmask, hinthash + // Add hasargs (element 4): 1 if @_ was populated for this sub + // Subroutines always have @_ available, so this is 1 for subs + // Check the subroutine name to determine if this is a sub call + boolean hasArgs = subName != null && !subName.isEmpty() && + !subName.equals("(eval)") && !subName.endsWith("::(eval)"); + res.add(hasArgs ? RuntimeScalarCache.scalarTrue : RuntimeScalarCache.scalarUndef); + + // Add wantarray (element 5): undef for void, 0 for scalar, 1 for list + // We don't currently track this per-frame, so return undef + // TODO: Track call context per frame to return accurate wantarray + res.add(RuntimeScalarCache.scalarUndef); + + // Add evaltext (element 6): The eval text if inside eval STRING + // For eval {...}, this is undef; for eval "...", this is the string + // Check if filename looks like an eval (e.g., "(eval 123)") + String filename = frameInfo.get(1); + if (filename != null && filename.startsWith("(eval ") && filename.endsWith(")")) { + // This is an eval frame - we don't have the actual text, return empty string + // Perl uses "" for eval {} and actual text for eval "..." + res.add(RuntimeScalarCache.scalarUndef); + } else { + res.add(RuntimeScalarCache.scalarUndef); + } + + // Add is_require (element 7): 1 if inside require/use, undef otherwise + // We don't currently distinguish require from regular code + res.add(RuntimeScalarCache.scalarUndef); + + // Add hints (element 8): Compile-time $^H value + res.add(new RuntimeScalar(0)); + + // Add bitmask (element 9): Compile-time warnings bitmask + res.add(RuntimeScalarCache.scalarUndef); + + // Add hinthash (element 10): Compile-time %^H hash reference + res.add(RuntimeScalarCache.scalarUndef); } } return res; @@ -1884,7 +1939,15 @@ public static RuntimeScalar createCodeReference(RuntimeScalar runtimeScalar, Str } } - return codeRef; + // Return a snapshot of the current code reference, not the global entry itself. + // This ensures that saved code references (\&sub) point to the current RuntimeCode + // and won't be affected if the subroutine is later redefined. + // This matches Perl's behavior where $orig = \&foo; sub foo {...} leaves $orig + // pointing to the old version. + RuntimeScalar snapshot = new RuntimeScalar(); + snapshot.type = codeRef.type; + snapshot.value = codeRef.value; + return snapshot; } public static RuntimeScalar prototype(RuntimeScalar runtimeScalar, String packageName) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index 752feb64b..4b73866e5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java @@ -105,13 +105,15 @@ public RuntimeScalar set(RuntimeScalar value) { return value; case ARRAYREFERENCE: // Handle the case where a typeglob is assigned a reference to an array - if (value.value instanceof RuntimeArray) { - GlobalVariable.getGlobalArray(this.globName).setFromList(((RuntimeArray) value.value).getList()); + // `*foo = \@bar` creates an alias - both names refer to the same array + if (value.value instanceof RuntimeArray arr) { + GlobalVariable.globalArrays.put(this.globName, arr); } return value; case HASHREFERENCE: - if (value.value instanceof RuntimeHash) { - GlobalVariable.getGlobalHash(this.globName).setFromList(((RuntimeHash) value.value).getList()); + // `*foo = \%bar` creates an alias - both names refer to the same hash + if (value.value instanceof RuntimeHash hash) { + GlobalVariable.globalHashes.put(this.globName, hash); } return value; case REFERENCE: diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java index 6578e67a7..2135f09f5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java @@ -90,24 +90,23 @@ public void put(String key, RuntimeScalar value) { */ public RuntimeScalar get(String key) { if (!elements.containsKey(key)) { - // Check if any slots exist for this glob name + // Check if any slots exist for this glob name, without auto-creating entries String fullKey = namespace + key; - // Check if the variable exists by trying to get it and checking if it's defined - RuntimeScalar var = GlobalVariable.getGlobalVariable(fullKey); - boolean hasScalarSlot = var.getDefinedBoolean(); + // Check if the scalar slot exists AND is defined (don't auto-create) + boolean hasScalarSlot = GlobalVariable.isGlobalVariableDefined(fullKey); boolean hasArraySlot = GlobalVariable.existsGlobalArray(fullKey); boolean hasHashSlot = GlobalVariable.existsGlobalHash(fullKey); - RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(fullKey); - boolean hasCodeSlot = codeRef.type == RuntimeScalarType.CODE && codeRef.getDefinedBoolean(); + // Check if the code slot exists AND is defined (don't auto-create) + boolean hasCodeSlot = GlobalVariable.isGlobalCodeRefDefined(fullKey); - RuntimeScalar ioRef = GlobalVariable.getGlobalIO(fullKey); - boolean hasIOSlot = ioRef.type == RuntimeScalarType.GLOB && ioRef.value instanceof RuntimeIO; + // Check if the IO slot exists AND has a real handle (don't auto-create) + boolean hasIOSlot = GlobalVariable.isGlobalIODefined(fullKey); - RuntimeScalar formatRef = GlobalVariable.getGlobalFormatRef(fullKey); - boolean hasFormatSlot = formatRef.type == RuntimeScalarType.FORMAT && formatRef.getDefinedBoolean(); + // Check if the format slot exists AND is defined (don't auto-create) + boolean hasFormatSlot = GlobalVariable.isGlobalFormatDefined(fullKey); boolean hasSlots = hasScalarSlot || hasArraySlot || hasHashSlot || hasCodeSlot || hasIOSlot || hasFormatSlot; diff --git a/src/main/perl/lib/ExtUtils/MM.pm b/src/main/perl/lib/ExtUtils/MM.pm index 3cfa2bca1..29eb97b38 100644 --- a/src/main/perl/lib/ExtUtils/MM.pm +++ b/src/main/perl/lib/ExtUtils/MM.pm @@ -7,12 +7,20 @@ our @ISA; # MM is a compatibility shim that some modules expect. # In traditional MakeMaker, MM is the platform-specific Makefile generator. -# In PerlOnJava, we don't generate Makefiles, but we provide the methods -# needed by CPAN.pm (parse_version, maybe_command). +# In PerlOnJava, we use MM_PerlOnJava which handles the JVM-specific details. # Load platform-specific module and set up inheritance BEGIN { - if ($^O eq 'MSWin32') { + # Detect PerlOnJava environment - works on both Unix and Windows + # Check for PERLONJAVA_JAR env var or jperl in the interpreter path + my $Is_PerlOnJava = exists $ENV{PERLONJAVA_JAR} + || $^X =~ /jperl(?:\.bat|\.cmd)?$/i + || exists $ENV{PERLONJAVA_LIB}; + + if ($Is_PerlOnJava) { + require ExtUtils::MM_PerlOnJava; + push @ISA, 'ExtUtils::MM_PerlOnJava'; + } elsif ($^O eq 'MSWin32') { require ExtUtils::MM_Win32; push @ISA, 'ExtUtils::MM_Win32'; } else { diff --git a/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm b/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm new file mode 100644 index 000000000..8ef7b627c --- /dev/null +++ b/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm @@ -0,0 +1,136 @@ +package ExtUtils::MM_PerlOnJava; + +use strict; +use warnings; + +# MM_PerlOnJava - ExtUtils::MakeMaker subclass for PerlOnJava +# +# This module handles the specifics of building/installing Perl modules +# on the PerlOnJava platform (Perl compiled to JVM bytecode). +# +# Key differences from MM_Unix: +# - No XS/C compilation (JVM can't load native libraries) +# - Simplified installation (direct copy to lib directory) +# - Tests run with jperl + +use ExtUtils::MakeMaker::Config; +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + +our $VERSION = '7.78'; +$VERSION =~ tr/_//d; + +# Installation base directory +sub _perlonjava_lib { + return $ENV{PERLONJAVA_LIB} + || File::Spec->catdir($ENV{HOME} || '.', '.perlonjava', 'lib'); +} + +# Override: We don't support XS +sub xs_c { + my $self = shift; + return ''; # No XS compilation +} + +sub xs_cpp { + my $self = shift; + return ''; +} + +sub xs_o { + my $self = shift; + return ''; +} + +# Override: Skip dynamic library creation +sub dynamic_lib { + my $self = shift; + return ''; +} + +sub dynamic_bs { + my $self = shift; + return ''; +} + +# Override: No static library either +sub static_lib { + my $self = shift; + return ''; +} + +# Override: Check for XS and warn +sub init_xs { + my $self = shift; + + if ($self->{XS} && %{$self->{XS}}) { + warn "\n"; + warn "=" x 60, "\n"; + warn "WARNING: This module contains XS code\n"; + warn "XS modules cannot be used directly with PerlOnJava.\n"; + warn "Consider:\n"; + warn " 1. Using a pure-Perl alternative\n"; + warn " 2. Porting the XS code to Java\n"; + warn "=" x 60, "\n\n"; + } + + return $self->SUPER::init_xs(@_); +} + +# Override: Simplified test target +sub test { + my($self, %attribs) = @_; + + my $tests = $attribs{TESTS} || ''; + if (!$tests && -d 't') { + $tests = 't/*.t'; + } + + return '' unless $tests; + + my $perl = $self->{FULLPERL} || $self->{PERL} || '$(PERL)'; + + return <<"MAKE_FRAG"; +test :: pure_all + $perl -e 'use Test::Harness; runtests(glob(q{$tests}))' + +test_dynamic :: pure_all + $perl -e 'use Test::Harness; runtests(glob(q{$tests}))' + +test_static :: + \@echo "No static tests for PerlOnJava" +MAKE_FRAG +} + +1; + +__END__ + +=head1 NAME + +ExtUtils::MM_PerlOnJava - MakeMaker methods for PerlOnJava + +=head1 SYNOPSIS + + # In ExtUtils/MM.pm, PerlOnJava is detected and this module is used + +=head1 DESCRIPTION + +This module provides ExtUtils::MakeMaker overrides specific to the +PerlOnJava platform. PerlOnJava compiles Perl to JVM bytecode, so: + +=over 4 + +=item * XS/C code cannot be compiled (no native libraries on JVM) + +=item * Installation is simplified (pure Perl only) + +=item * Tests run under jperl + +=back + +=head1 SEE ALSO + +L, L + +=cut diff --git a/src/main/perl/lib/ExtUtils/MakeMaker.pm b/src/main/perl/lib/ExtUtils/MakeMaker.pm index 6d4f3a8f4..482532793 100644 --- a/src/main/perl/lib/ExtUtils/MakeMaker.pm +++ b/src/main/perl/lib/ExtUtils/MakeMaker.pm @@ -15,6 +15,10 @@ use File::Spec; use File::Basename; use Cwd qw(getcwd abs_path); +# Load ExtUtils::MM to set up the MM package with parse_version, etc. +# CPAN.pm and other tools expect MM->parse_version() to work after loading MakeMaker +require ExtUtils::MM; + # Installation directory (configurable via environment) our $INSTALL_BASE = $ENV{PERLONJAVA_LIB}; @@ -236,6 +240,9 @@ sub _install_pure_perl { # Create a stub Makefile to satisfy CPAN.pm's check _create_stub_makefile($name, $version, $args); + # Create MYMETA.yml for CPAN.pm dependency resolution + _create_mymeta($name, $version, $args); + return PerlOnJava::MM::Installed->new($args); } @@ -271,6 +278,18 @@ sub _create_stub_makefile { return; }; + # Get the Perl interpreter path + my $perl = $^X; + + # Build test command - run all t/*.t files using Perl for cross-platform compatibility + my $test_cmd; + if (-d 't') { + # Use Perl one-liner with Test::Harness for cross-platform test running + $test_cmd = qq{$perl -MTest::Harness -e "runtests(glob(q{t/*.t}))"}; + } else { + $test_cmd = qq{$perl -e "print qq{PerlOnJava: No tests found (no t/ directory)\\n}"}; + } + # Minimal Makefile that works with CPAN.pm print $fh <<"MAKEFILE"; # Stub Makefile for PerlOnJava @@ -278,7 +297,7 @@ sub _create_stub_makefile { NAME = $name VERSION = $version -PERL = $^X +PERL = $perl INSTALLDIRS = site # PerlOnJava installs modules directly - these are no-ops @@ -286,7 +305,7 @@ all: \t\@echo "PerlOnJava: Module already installed" test: -\t\@echo "PerlOnJava: Tests skipped (module already installed)" +\t$test_cmd install: \t\@echo "PerlOnJava: Module already installed to $INSTALL_BASE" @@ -304,6 +323,80 @@ MAKEFILE close $fh; } +sub _create_mymeta { + my ($name, $version, $args) = @_; + + # Create MYMETA.yml for CPAN.pm dependency resolution + # This allows CPAN.pm to detect and install prerequisites + + my $mymeta = 'MYMETA.yml'; + + open my $fh, '>', $mymeta or do { + warn "Note: Could not create MYMETA.yml: $!\n"; + return; + }; + + # Build prerequisites section + my $prereqs = ''; + if ($args->{PREREQ_PM} && %{$args->{PREREQ_PM}}) { + $prereqs .= "requires:\n"; + for my $mod (sort keys %{$args->{PREREQ_PM}}) { + my $ver = $args->{PREREQ_PM}{$mod} || 0; + $prereqs .= " $mod: '$ver'\n"; + } + } + + if ($args->{BUILD_REQUIRES} && %{$args->{BUILD_REQUIRES}}) { + $prereqs .= "build_requires:\n"; + for my $mod (sort keys %{$args->{BUILD_REQUIRES}}) { + my $ver = $args->{BUILD_REQUIRES}{$mod} || 0; + $prereqs .= " $mod: '$ver'\n"; + } + } + + if ($args->{TEST_REQUIRES} && %{$args->{TEST_REQUIRES}}) { + $prereqs .= "test_requires:\n"; + for my $mod (sort keys %{$args->{TEST_REQUIRES}}) { + my $ver = $args->{TEST_REQUIRES}{$mod} || 0; + $prereqs .= " $mod: '$ver'\n"; + } + } + + if ($args->{CONFIGURE_REQUIRES} && %{$args->{CONFIGURE_REQUIRES}}) { + $prereqs .= "configure_requires:\n"; + for my $mod (sort keys %{$args->{CONFIGURE_REQUIRES}}) { + my $ver = $args->{CONFIGURE_REQUIRES}{$mod} || 0; + $prereqs .= " $mod: '$ver'\n"; + } + } + + # Convert NAME to abstract (guess from module name) + my $abstract = $args->{ABSTRACT} || "$name module"; + + print $fh <<"MYMETA"; +--- +abstract: '$abstract' +author: + - 'Unknown' +build_requires: {} +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker (PerlOnJava)' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: $name +no_index: + directory: + - t + - inc +$prereqs +version: '$version' +MYMETA + + close $fh; +} + sub prompt { my ($msg, $default) = @_; $default //= ''; diff --git a/src/main/perl/lib/List/Util.pm b/src/main/perl/lib/List/Util.pm index 6cb623e42..b83f1dce5 100644 --- a/src/main/perl/lib/List/Util.pm +++ b/src/main/perl/lib/List/Util.pm @@ -1,173 +1,20 @@ -# Copyright (c) 1997-2009 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Maintained since 2013 by Paul Evans - package List::Util; - use strict; use warnings; -require Exporter; +our $VERSION = '1.63'; -our @ISA = qw(Exporter); -our @EXPORT_OK = qw( - all any first min max minstr maxstr none notall product reduce reductions sum sum0 - sample shuffle uniq uniqint uniqnum uniqstr zip zip_longest zip_shortest mesh mesh_longest mesh_shortest - head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst +require Exporter; +our @ISA = qw(Exporter); + +our @EXPORT_OK = qw( + all any first min max minstr maxstr none notall + product reduce reductions sum sum0 sample shuffle + uniq uniqint uniqnum uniqstr + zip zip_longest zip_shortest mesh mesh_longest mesh_shortest + head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst ); -our $VERSION = "1.68_01"; -$VERSION =~ tr/_//d; - -require XSLoader; -XSLoader::load('List::Util'); - -# Used by shuffle() -our $RAND; - -# For objects returned by pairs() -sub List::Util::_Pair::key { shift->[0] } -sub List::Util::_Pair::value { shift->[1] } -sub List::Util::_Pair::TO_JSON { [ @{+shift} ] } - -# Functions implemented in Perl (not performance-critical or complex logic) -sub zip { - my @arrays = @_; - my @result; - my $max_length = 0; - - # Find the maximum array length - for my $array_ref (@arrays) { - my $len = @$array_ref; - $max_length = $len if $len > $max_length; - } - - # Build result arrays - for my $i (0 .. $max_length - 1) { - my @tuple; - for my $array_ref (@arrays) { - push @tuple, $i < @$array_ref ? $array_ref->[$i] : undef; - } - push @result, \@tuple; - } - - return @result; -} - -sub zip_longest { goto &zip } - -sub zip_shortest { - my @arrays = @_; - my @result; - my $min_length; - - # Find the minimum array length - for my $array_ref (@arrays) { - my $len = @$array_ref; - $min_length = $len if !defined($min_length) || $len < $min_length; - } - - return () unless defined($min_length) && $min_length > 0; - - # Build result arrays - for my $i (0 .. $min_length - 1) { - my @tuple; - for my $array_ref (@arrays) { - push @tuple, $array_ref->[$i]; - } - push @result, \@tuple; - } - - return @result; -} - -sub mesh { - my @arrays = @_; - my @result; - my $max_length = 0; - - # Find the maximum array length - for my $array_ref (@arrays) { - my $len = @$array_ref; - $max_length = $len if $len > $max_length; - } - - # Build result by interleaving elements - for my $i (0 .. $max_length - 1) { - for my $array_ref (@arrays) { - push @result, $i < @$array_ref ? $array_ref->[$i] : undef; - } - } - - return @result; -} - -sub mesh_longest { goto &mesh } - -sub mesh_shortest { - my @arrays = @_; - my @result; - my $min_length; - - # Find the minimum array length - for my $array_ref (@arrays) { - my $len = @$array_ref; - $min_length = $len if !defined($min_length) || $len < $min_length; - } - - return () unless defined($min_length) && $min_length > 0; - - # Build result by interleaving elements - for my $i (0 .. $min_length - 1) { - for my $array_ref (@arrays) { - push @result, $array_ref->[$i]; - } - } - - return @result; -} +use XSLoader; +XSLoader::load('List::Util', $VERSION); 1; - -__END__ - -=head1 NAME - -List::Util - A selection of general-utility list subroutines - -=head1 SYNOPSIS - - use List::Util qw( - reduce any all none notall first reductions - - max maxstr min minstr product sum sum0 - - pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap - - shuffle uniq uniqint uniqnum uniqstr head tail zip mesh - ); - -=head1 DESCRIPTION - -C contains a selection of subroutines that people have expressed -would be nice to have in the perl core, but the usage would not really be high -enough to warrant the use of a keyword, and the size so small such that being -individual extensions would be wasteful. - -By default C does not export any subroutines. - -This implementation uses Java for performance-critical functions while -maintaining full compatibility with the original Perl List::Util module. - -=head1 COPYRIGHT - -Copyright (c) 1997-2007 Graham Barr . All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -Recent additions and current maintenance by -Paul Evans, . - -=cut - diff --git a/src/main/perl/lib/Scalar/Util.pm b/src/main/perl/lib/Scalar/Util.pm new file mode 100644 index 000000000..eadb9ed17 --- /dev/null +++ b/src/main/perl/lib/Scalar/Util.pm @@ -0,0 +1,9 @@ +package Scalar::Util; +use strict; +use warnings; +our $VERSION = '1.63'; + +use XSLoader; +XSLoader::load('Scalar::Util', $VERSION); + +1; diff --git a/src/main/perl/lib/Sub/Util.pm b/src/main/perl/lib/Sub/Util.pm new file mode 100644 index 000000000..3f5aea44a --- /dev/null +++ b/src/main/perl/lib/Sub/Util.pm @@ -0,0 +1,9 @@ +package Sub::Util; +use strict; +use warnings; +our $VERSION = '1.63'; + +use XSLoader; +XSLoader::load('Sub::Util', $VERSION); + +1; diff --git a/src/main/perl/lib/TAP/Base.pm b/src/main/perl/lib/TAP/Base.pm new file mode 100644 index 000000000..38a65bd7e --- /dev/null +++ b/src/main/perl/lib/TAP/Base.pm @@ -0,0 +1,133 @@ +package TAP::Base; + +use strict; +use warnings; + +use base 'TAP::Object'; + +=head1 NAME + +TAP::Base - Base class that provides common functionality to L +and L + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +use constant GOT_TIME_HIRES => do { + eval 'use Time::HiRes qw(time);'; + $@ ? 0 : 1; +}; + +=head1 SYNOPSIS + + package TAP::Whatever; + + use base 'TAP::Base'; + + # ... later ... + + my $thing = TAP::Whatever->new(); + + $thing->callback( event => sub { + # do something interesting + } ); + +=head1 DESCRIPTION + +C provides callback management. + +=head1 METHODS + +=head2 Class Methods + +=cut + +sub _initialize { + my ( $self, $arg_for, $ok_callback ) = @_; + + my %ok_map = map { $_ => 1 } @$ok_callback; + + $self->{ok_callbacks} = \%ok_map; + + if ( my $cb = delete $arg_for->{callbacks} ) { + while ( my ( $event, $callback ) = each %$cb ) { + $self->callback( $event, $callback ); + } + } + + return $self; +} + +=head3 C + +Install a callback for a named event. + +=cut + +sub callback { + my ( $self, $event, $callback ) = @_; + + my %ok_map = %{ $self->{ok_callbacks} }; + + $self->_croak('No callbacks may be installed') + unless %ok_map; + + $self->_croak( "Callback $event is not supported. Valid callbacks are " + . join( ', ', sort keys %ok_map ) ) + unless exists $ok_map{$event}; + + push @{ $self->{code_for}{$event} }, $callback; + + return; +} + +sub _has_callbacks { + my $self = shift; + return keys %{ $self->{code_for} } != 0; +} + +sub _callback_for { + my ( $self, $event ) = @_; + return $self->{code_for}{$event}; +} + +sub _make_callback { + my $self = shift; + my $event = shift; + + my $cb = $self->_callback_for($event); + return unless defined $cb; + return map { $_->(@_) } @$cb; +} + +=head3 C + +Return the current time using Time::HiRes if available. + +=cut + +sub get_time { return time() } + +=head3 C + +Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available). + +=cut + +sub time_is_hires { return GOT_TIME_HIRES } + +=head3 C + +Return array reference of the four-element list of CPU seconds, +as with L. + +=cut + +sub get_times { return [ times() ] } + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Base.pm b/src/main/perl/lib/TAP/Formatter/Base.pm new file mode 100644 index 000000000..ddc8dd665 --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Base.pm @@ -0,0 +1,488 @@ +package TAP::Formatter::Base; + +use strict; +use warnings; +use base 'TAP::Base'; +use POSIX qw(strftime); + +my $MAX_ERRORS = 5; +my %VALIDATION_FOR; + +BEGIN { + %VALIDATION_FOR = ( + directives => sub { shift; shift }, + verbosity => sub { shift; shift }, + normalize => sub { shift; shift }, + timer => sub { shift; shift }, + failures => sub { shift; shift }, + comments => sub { shift; shift }, + errors => sub { shift; shift }, + color => sub { shift; shift }, + jobs => sub { shift; shift }, + show_count => sub { shift; shift }, + stdout => sub { + my ( $self, $ref ) = @_; + + $self->_croak("option 'stdout' needs a filehandle") + unless $self->_is_filehandle($ref); + + return $ref; + }, + ); + + sub _is_filehandle { + my ( $self, $ref ) = @_; + + return 0 if !defined $ref; + + return 1 if ref $ref eq 'GLOB'; # lexical filehandle + return 1 if !ref $ref && ref \$ref eq 'GLOB'; # bare glob like *STDOUT + + return 1 if eval { $ref->can('print') }; + + return 0; + } + + my @getter_setters = qw( + _longest + _printed_summary_header + _colorizer + ); + + __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR ); +} + +=head1 NAME + +TAP::Formatter::Base - Base class for harness output delegates + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + $self->verbosity(0); + + for my $name ( keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + $self->$name( $self->$validate($property) ); + } + } + + if ( my @props = keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + $self->stdout( \*STDOUT ) unless $self->stdout; + + if ( $self->color ) { + require TAP::Formatter::Color; + $self->_colorizer( TAP::Formatter::Color->new ); + } + + return $self; +} + +sub verbose { shift->verbosity >= 1 } +sub quiet { shift->verbosity <= -1 } +sub really_quiet { shift->verbosity <= -2 } +sub silent { shift->verbosity <= -3 } + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + verbose => 1, + ) + my $harness = TAP::Formatter::Console->new( \%args ); + +The constructor returns a new C object. If +a L is created with no C a +C is automatically created. If any of the +following options were given to TAP::Harness->new they well be passed to +this constructor which accepts an optional hashref whose allowed keys are: + +=over 4 + +=item * C + +Set the verbosity level. + +=item * C + +Printing individual test results to STDOUT. + +=item * C + +Append run time for each test to output. Uses L if available. + +=item * C + +Show test failures (this is a no-op if C is selected). + +=item * C + +Show test comments (this is a no-op if C is selected). + +=item * C + +Suppressing some test output (mostly failures while tests are running). + +=item * C + +Suppressing everything but the tests summary. + +=item * C + +Suppressing all output. + +=item * C + +If parse errors are found in the TAP output, a note of this will be made +in the summary report. To see all of the parse errors, set this argument to +true: + + errors => 1 + +=item * C + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C, C, or C. + +=item * C + +A filehandle for catching standard output. + +=item * C + +If defined specifies whether color output is desired. If C is not +defined it will default to color output if color support is available on +the current platform and output is not being redirected. + +=item * C + +The number of concurrent jobs this formatter will handle. + +=item * C + +Boolean value. If false, disables the C test count which shows up while +tests are running. + +=back + +Any keys for which the value is C will be ignored. + +=cut + +# new supplied by TAP::Base + +=head3 C + +Called by Test::Harness before any test output is generated. + +This is an advisory and may not be called in the case where tests are +being supplied to Test::Harness by an iterator. + +=cut + +sub prepare { + my ( $self, @tests ) = @_; + + my $longest = 0; + + for my $test (@tests) { + $longest = length $test if length $test > $longest; + } + + $self->_longest($longest); +} + +sub _format_now { strftime "[%H:%M:%S]", localtime } + +sub _format_name { + my ( $self, $test ) = @_; + my $name = $test; + my $periods = '.' x ( $self->_longest + 2 - length $test ); + $periods = " $periods "; + + if ( $self->timer ) { + my $stamp = $self->_format_now(); + return "$stamp $name$periods"; + } + else { + return "$name$periods"; + } + +} + +=head3 C + +Called to create a new test session. A test session looks like this: + + my $session = $formatter->open_test( $test, $parser ); + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + $session->close_test; + +=cut + +sub open_test { + die "Unimplemented."; +} + +sub _output_success { + my ( $self, $msg ) = @_; + $self->_output($msg); +} + +=head3 C + + $harness->summary( $aggregate ); + +C prints the summary report after all tests are run. The first +argument is an aggregate to summarise. An optional second argument may +be set to a true value to indicate that the summary is being output as a +result of an interrupted test run. + +=cut + +sub summary { + my ( $self, $aggregate, $interrupted ) = @_; + + return if $self->silent; + + my @t = $aggregate->descriptions; + my $tests = \@t; + + my $runtime = $aggregate->elapsed_timestr; + + my $total = $aggregate->total; + my $passed = $aggregate->passed; + + if ( $self->timer ) { + $self->_output( $self->_format_now(), "\n" ); + } + + $self->_failure_output("Test run interrupted!\n") + if $interrupted; + + # TODO: Check this condition still works when all subtests pass but + # the exit status is nonzero + + if ( $aggregate->all_passed ) { + $self->_output_success("All tests successful.\n"); + } + + # ~TODO option where $aggregate->skipped generates reports + if ( $total != $passed or $aggregate->has_problems ) { + $self->_output("\nTest Summary Report"); + $self->_output("\n-------------------\n"); + for my $test (@$tests) { + $self->_printed_summary_header(0); + my ($parser) = $aggregate->parsers($test); + $self->_output_summary_failure( + 'failed', + [ ' Failed test: ', ' Failed tests: ' ], + $test, $parser + ); + $self->_output_summary_failure( + 'todo_passed', + " TODO passed: ", $test, $parser + ); + + # ~TODO this cannot be the default + #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); + + if ( my $exit = $parser->exit ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero exit status: $exit\n"); + } + elsif ( my $wait = $parser->wait ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero wait status: $wait\n"); + } + + if ( my @errors = $parser->parse_errors ) { + my $explain; + if ( @errors > $MAX_ERRORS && !$self->errors ) { + $explain + = "Displayed the first $MAX_ERRORS of " + . scalar(@errors) + . " TAP syntax errors.\n" + . "Re-run prove with the -p option to see them all.\n"; + splice @errors, $MAX_ERRORS; + } + $self->_summary_test_header( $test, $parser ); + $self->_failure_output( + sprintf " Parse errors: %s\n", + shift @errors + ); + for my $error (@errors) { + my $spaces = ' ' x 16; + $self->_failure_output("$spaces$error\n"); + } + $self->_failure_output($explain) if $explain; + } + } + } + my $files = @$tests; + $self->_output("Files=$files, Tests=$total, $runtime\n"); + my $status = $aggregate->get_status; + $self->_output("Result: $status\n"); +} + +sub _output_summary_failure { + my ( $self, $method, $name, $test, $parser ) = @_; + + # ugly hack. Must rethink this :( + my $output = $method eq 'failed' ? '_failure_output' : '_output'; + + if ( my @r = $parser->$method() ) { + $self->_summary_test_header( $test, $parser ); + my ( $singular, $plural ) + = 'ARRAY' eq ref $name ? @$name : ( $name, $name ); + $self->$output( @r == 1 ? $singular : $plural ); + my @results = $self->_balanced_range( 40, @r ); + $self->$output( sprintf "%s\n" => shift @results ); + my $spaces = ' ' x 16; + while (@results) { + $self->$output( sprintf "$spaces%s\n" => shift @results ); + } + } +} + +sub _summary_test_header { + my ( $self, $test, $parser ) = @_; + return if $self->_printed_summary_header; + my $spaces = ' ' x ( $self->_longest - length $test ); + $spaces = ' ' unless $spaces; + my $output = $self->_get_output_method($parser); + my $wait = $parser->wait; + + if (defined $wait) { + my $signum = $wait & 0x7f; + + my $description; + + if ($signum) { + require Config; + my @names = split ' ', $Config::Config{'sig_name'}; + $description = "Signal: $names[$signum]"; + + my $dumped = $wait & 0x80; + $description .= ', dumped core' if $dumped; + } + elsif ($wait != 0) { + $description = sprintf 'exited %d', ($wait >> 8); + } + + $wait .= " ($description)" if $wait != 0; + } + else { + $wait = '(none)'; + } + + $self->$output( + sprintf "$test$spaces(Wstat: %s Tests: %d Failed: %d)\n", + $wait, $parser->tests_run, scalar $parser->failed + ); + $self->_printed_summary_header(1); +} + +sub _output { + print { shift->stdout } @_; +} + +sub _failure_output { + my $self = shift; + + $self->_output(@_); +} + +sub _balanced_range { + my ( $self, $limit, @range ) = @_; + @range = $self->_range(@range); + my $line = ""; + my @lines; + my $curr = 0; + while (@range) { + if ( $curr < $limit ) { + my $range = ( shift @range ) . ", "; + $line .= $range; + $curr += length $range; + } + elsif (@range) { + $line =~ s/, $//; + push @lines => $line; + $line = ''; + $curr = 0; + } + } + if ($line) { + $line =~ s/, $//; + push @lines => $line; + } + return @lines; +} + +sub _range { + my ( $self, @numbers ) = @_; + + # shouldn't be needed, but subclasses might call this + @numbers = sort { $a <=> $b } @numbers; + my ( $min, @range ); + + for my $i ( 0 .. $#numbers ) { + my $num = $numbers[$i]; + my $next = $numbers[ $i + 1 ]; + if ( defined $next && $next == $num + 1 ) { + if ( !defined $min ) { + $min = $num; + } + } + elsif ( defined $min ) { + push @range => "$min-$num"; + undef $min; + } + else { + push @range => $num; + } + } + return @range; +} + +sub _get_output_method { + my ( $self, $parser ) = @_; + return $parser->has_problems ? '_failure_output' : '_output'; +} + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Color.pm b/src/main/perl/lib/TAP/Formatter/Color.pm new file mode 100644 index 000000000..da06a7da6 --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Color.pm @@ -0,0 +1,116 @@ +package TAP::Formatter::Color; + +use strict; +use warnings; + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); + +use base 'TAP::Object'; + +my $NO_COLOR; + +BEGIN { + $NO_COLOR = 0; + + eval 'require Term::ANSIColor'; + if ($@) { + $NO_COLOR = $@; + }; + if (IS_WIN32) { + eval 'use Win32::Console::ANSI'; + if ($@) { + $NO_COLOR = $@; + } + }; + + if ($NO_COLOR) { + *set_color = sub { }; + } else { + *set_color = sub { + my ( $self, $output, $color ) = @_; + $output->( Term::ANSIColor::color($color) ); + }; + } +} + +=head1 NAME + +TAP::Formatter::Color - Run Perl test scripts with color + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +Note that this harness is I. You may not like the colors I've +chosen and I haven't yet provided an easy way to override them. + +This test harness is the same as L, but test results are output +in color. Passing tests are printed in green. Failing tests are in red. +Skipped tests are blue on a white background and TODO tests are printed in +white. + +If L cannot be found (and L if running +under Windows) tests will be run without color. + +=head1 SYNOPSIS + + use TAP::Formatter::Color; + my $harness = TAP::Formatter::Color->new( \%args ); + $harness->runtests(@tests); + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +The constructor returns a new C object. If +L is not installed, returns undef. + +=cut + +# new() implementation supplied by TAP::Object + +sub _initialize { + my $self = shift; + + if ($NO_COLOR) { + + # shorten that message a bit + ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; + warn "Note: Cannot run tests in color: $error\n"; + return; # abort object construction + } + + return $self; +} + +############################################################################## + +=head3 C + + Test::Formatter::Color->can_color() + +Returns a boolean indicating whether or not this module can actually +generate colored output. This will be false if it could not load the +modules needed for the current platform. + +=cut + +sub can_color { + return !$NO_COLOR; +} + +=head3 C + +Set the output color. + +=cut + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Console.pm b/src/main/perl/lib/TAP/Formatter/Console.pm new file mode 100644 index 000000000..1e0ffbff8 --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Console.pm @@ -0,0 +1,100 @@ +package TAP::Formatter::Console; + +use strict; +use warnings; +use base 'TAP::Formatter::Base'; +use POSIX qw(strftime); + +=head1 NAME + +TAP::Formatter::Console - Harness output delegate for default console output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=head2 C<< open_test >> + +See L + +=cut + +sub open_test { + my ( $self, $test, $parser ) = @_; + + my $class + = $self->jobs > 1 + ? 'TAP::Formatter::Console::ParallelSession' + : 'TAP::Formatter::Console::Session'; + + eval "require $class"; + $self->_croak($@) if $@; + + my $session = $class->new( + { name => $test, + formatter => $self, + parser => $parser, + show_count => $self->show_count, + } + ); + + $session->header; + + return $session; +} + +# Use _colorizer delegate to set output color. NOP if we have no delegate +sub _set_colors { + my ( $self, @colors ) = @_; + if ( my $colorizer = $self->_colorizer ) { + my $output_func = $self->{_output_func} ||= sub { + $self->_output(@_); + }; + $colorizer->set_color( $output_func, $_ ) for @colors; + } +} + +sub _failure_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_FAIL'} || 'red'; +} + +sub _success_color { + my ($self) = @_; + + return $ENV{'HARNESS_SUMMARY_COLOR_SUCCESS'} || 'green'; +} + +sub _output_success { + my ( $self, $msg ) = @_; + $self->_set_colors( $self->_success_color() ); + $self->_output($msg); + $self->_set_colors('reset'); +} + +sub _failure_output { + my $self = shift; + $self->_set_colors( $self->_failure_color() ); + my $out = join '', @_; + my $has_newline = chomp $out; + $self->_output($out); + $self->_set_colors('reset'); + $self->_output($/) + if $has_newline; +} + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Console/ParallelSession.pm b/src/main/perl/lib/TAP/Formatter/Console/ParallelSession.pm new file mode 100644 index 000000000..574b075cb --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Console/ParallelSession.pm @@ -0,0 +1,201 @@ +package TAP::Formatter::Console::ParallelSession; + +use strict; +use warnings; +use File::Spec; +use File::Path; +use Carp; + +use base 'TAP::Formatter::Console::Session'; + +use constant WIDTH => 72; # Because Eric says + +my %shared; + +sub _initialize { + my ( $self, $arg_for ) = @_; + + $self->SUPER::_initialize($arg_for); + my $formatter = $self->formatter; + + # Horrid bodge. This creates our shared context per harness. Maybe + # TAP::Harness should give us this? + my $context = $shared{$formatter} ||= $self->_create_shared_context; + push @{ $context->{active} }, $self; + + return $self; +} + +sub _create_shared_context { + my $self = shift; + return { + active => [], + tests => 0, + fails => 0, + }; +} + +=head1 NAME + +TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for L +when run with multiple L. + +=head1 SYNOPSIS + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C
+ +Output test preamble + +=cut + +sub header { +} + +sub _clear_ruler { + my $self = shift; + $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); +} + +my $now = 0; +my $start; + +my $trailer = '... )==='; +my $chop_length = WIDTH - length $trailer; + +sub _output_ruler { + my ( $self, $refresh ) = @_; + my $new_now = time; + return if $new_now == $now and !$refresh; + $now = $new_now; + $start ||= $now; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $context = $shared{$formatter}; + + my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; + + for my $active ( @{ $context->{active} } ) { + my $parser = $active->parser; + my $tests = $parser->tests_run; + my $planned = $parser->tests_planned || '?'; + + $ruler .= sprintf '%' . length($planned) . "d/$planned ", $tests; + } + chop $ruler; # Remove a trailing space + $ruler .= ')==='; + + if ( length $ruler > WIDTH ) { + $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; + } + else { + $ruler .= '=' x ( WIDTH - length($ruler) ); + } + $formatter->_output("\r$ruler"); +} + +=head3 C + + Called by the harness for each line of TAP it receives . + +=cut + +sub result { + my ( $self, $result ) = @_; + my $formatter = $self->formatter; + + # my $really_quiet = $formatter->really_quiet; + # my $show_count = $self->_should_show_count; + + if ( $result->is_test ) { + my $context = $shared{$formatter}; + $context->{tests}++; + + my $active = $context->{active}; + if ( @$active == 1 ) { + + # There is only one test, so use the serial output format. + return $self->SUPER::result($result); + } + + $self->_output_ruler( $self->parser->tests_run == 1 ); + } + elsif ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } +} + +=head3 C + +=cut + +sub clear_for_close { + my $self = shift; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + my $context = $shared{$formatter}; + if ( @{ $context->{active} } == 1 ) { + $self->SUPER::clear_for_close; + } + else { + $self->_clear_ruler; + } +} + +=head3 C + +=cut + +sub close_test { + my $self = shift; + my $name = $self->name; + my $parser = $self->parser; + my $formatter = $self->formatter; + my $context = $shared{$formatter}; + + $self->SUPER::close_test; + + my $active = $context->{active}; + + my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; + + die "Can't find myself" unless @pos; + splice @$active, $pos[0], 1; + + if ( @$active > 1 ) { + $self->_output_ruler(1); + } + elsif ( @$active == 1 ) { + + # Print out "test/name.t ...." + $active->[0]->SUPER::header; + } + else { + + # $self->formatter->_output("\n"); + delete $shared{$formatter}; + } +} + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Console/Session.pm b/src/main/perl/lib/TAP/Formatter/Console/Session.pm new file mode 100644 index 000000000..26b708bfc --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Console/Session.pm @@ -0,0 +1,205 @@ +package TAP::Formatter::Console::Session; + +use strict; +use warnings; + +use base 'TAP::Formatter::Session'; + +my @ACCESSOR; + +BEGIN { + my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); + + for my $method (@CLOSURE_BINDING) { + no strict 'refs'; + *$method = sub { + my $self = shift; + return ( $self->{_closures} ||= $self->_closures )->{$method} + ->(@_); + }; + } +} + +=head1 NAME + +TAP::Formatter::Console::Session - Harness output delegate for default console output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=cut + +sub _get_output_result { + my $self = shift; + + my @color_map = ( + { test => sub { $_->is_test && !$_->is_ok }, + colors => ['red'], + }, + { test => sub { $_->is_test && $_->has_skip }, + colors => [ + 'white', + 'on_blue' + ], + }, + { test => sub { $_->is_test && $_->has_todo }, + colors => ['yellow'], + }, + ); + + my $formatter = $self->formatter; + my $parser = $self->parser; + + return $formatter->_colorizer + ? sub { + my $result = shift; + for my $col (@color_map) { + local $_ = $result; + if ( $col->{test}->() ) { + $formatter->_set_colors( @{ $col->{colors} } ); + last; + } + } + $formatter->_output( $self->_format_for_output($result) ); + $formatter->_set_colors('reset'); + } + : sub { + $formatter->_output( $self->_format_for_output(shift) ); + }; +} + +sub _closures { + my $self = shift; + + my $parser = $self->parser; + my $formatter = $self->formatter; + my $pretty = $formatter->_format_name( $self->name ); + my $show_count = $self->show_count; + + my $really_quiet = $formatter->really_quiet; + my $quiet = $formatter->quiet; + my $verbose = $formatter->verbose; + my $directives = $formatter->directives; + my $failures = $formatter->failures; + my $comments = $formatter->comments; + + my $output_result = $self->_get_output_result; + + my $output = '_output'; + my $plan = ''; + my $newline_printed = 0; + + my $last_status_printed = 0; + + return { + header => sub { + $formatter->_output($pretty) + unless $really_quiet; + }, + + result => sub { + my $result = shift; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } + + return if $really_quiet; + + my $is_test = $result->is_test; + + # These are used in close_test - but only if $really_quiet + # is false - so it's safe to only set them here unless that + # relationship changes. + + if ( !$plan ) { + my $planned = $parser->tests_planned || '?'; + $plan = "/$planned "; + } + + if ( $show_count and $is_test ) { + my $now = CORE::time; + + # Print status roughly once per second. + # We will always get the first number as a side effect of + # $last_status_printed starting with the value 0, which $now + # will never be. (Unless someone sets their clock to 1970) + if ( $last_status_printed != $now ) { + my $number = $result->number; + $output = $formatter->_get_output_method($parser); + $formatter->$output("\r$pretty$number$plan"); + $last_status_printed = $now; + } + } + + if (!$quiet + && ( $verbose + || ( $is_test && $failures && !$result->is_ok ) + || ( $comments && $result->is_comment ) + || ( $directives && $result->has_directive ) ) + ) + { + unless ($newline_printed) { + $formatter->_output("\n"); + $newline_printed = 1; + } + $output_result->($result); + $formatter->_output("\n"); + } + }, + + clear_for_close => sub { + my $spaces + = ' ' x length( '.' . $pretty . $plan . $parser->tests_run ); + $formatter->$output("\r$spaces"); + }, + + close_test => sub { + if ( $show_count && !$really_quiet ) { + $self->clear_for_close; + $formatter->$output("\r$pretty"); + } + + # Avoid circular references + $self->parser(undef); + $self->{_closures} = {}; + + return if $really_quiet; + + if ( my $skip_all = $parser->skip_all ) { + $formatter->_output("skipped: $skip_all\n"); + } + elsif ( $parser->has_problems ) { + $self->_output_test_failure($parser); + } + else { + my $time_report = $self->time_report($formatter, $parser); + $formatter->_output_success( $self->_make_ok_line($time_report) ); + } + }, + }; +} + +=head2 C<< clear_for_close >> + +=head2 C<< close_test >> + +=head2 C<< header >> + +=head2 C<< result >> + +=cut + +1; diff --git a/src/main/perl/lib/TAP/Formatter/File.pm b/src/main/perl/lib/TAP/Formatter/File.pm new file mode 100644 index 000000000..6acec8ed6 --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/File.pm @@ -0,0 +1,56 @@ +package TAP::Formatter::File; + +use strict; +use warnings; +use TAP::Formatter::File::Session; +use POSIX qw(strftime); + +use base 'TAP::Formatter::Base'; + +=head1 NAME + +TAP::Formatter::File - Harness output delegate for file output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides file orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::File; + my $harness = TAP::Formatter::File->new( \%args ); + +=head2 C<< open_test >> + +See L + +=cut + +sub open_test { + my ( $self, $test, $parser ) = @_; + + my $session = TAP::Formatter::File::Session->new( + { name => $test, + formatter => $self, + parser => $parser, + } + ); + + $session->header; + + return $session; +} + +sub _should_show_count { + return 0; +} + +1; diff --git a/src/main/perl/lib/TAP/Formatter/File/Session.pm b/src/main/perl/lib/TAP/Formatter/File/Session.pm new file mode 100644 index 000000000..cad3b98bf --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/File/Session.pm @@ -0,0 +1,95 @@ +package TAP::Formatter::File::Session; + +use strict; +use warnings; +use base 'TAP::Formatter::Session'; + +=head1 NAME + +TAP::Formatter::File::Session - Harness output delegate for file output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 DESCRIPTION + +This provides file orientated output formatting for L. +It is particularly important when running with parallel tests, as it +ensures that test results are not interleaved, even when run +verbosely. + +=cut + +=head1 METHODS + +=head2 result + +Stores results for later output, all together. + +=cut + +sub result { + my $self = shift; + my $result = shift; + + my $parser = $self->parser; + my $formatter = $self->formatter; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + return; + } + + if (!$formatter->quiet + && ( $formatter->verbose + || ( $result->is_test && $formatter->failures && !$result->is_ok ) + || ( $formatter->comments && $result->is_comment ) + || ( $result->has_directive && $formatter->directives ) ) + ) + { + $self->{results} .= $self->_format_for_output($result) . "\n"; + } +} + +=head2 close_test + +When the test file finishes, outputs the summary, together. + +=cut + +sub close_test { + my $self = shift; + + # Avoid circular references + $self->parser(undef); + + my $parser = $self->parser; + my $formatter = $self->formatter; + my $pretty = $formatter->_format_name( $self->name ); + + return if $formatter->really_quiet; + if ( my $skip_all = $parser->skip_all ) { + $formatter->_output( $pretty . "skipped: $skip_all\n" ); + } + elsif ( $parser->has_problems ) { + $formatter->_output( + $pretty . ( $self->{results} ? "\n" . $self->{results} : "\n" ) ); + $self->_output_test_failure($parser); + } + else { + my $time_report = $self->time_report( $formatter, $parser ); + $formatter->_output( + $pretty . ( $self->{results} ? "\n" . $self->{results} : "" ) ); + $formatter->_output_success( $self->_make_ok_line($time_report) ); + } +} + +1; diff --git a/src/main/perl/lib/TAP/Formatter/Session.pm b/src/main/perl/lib/TAP/Formatter/Session.pm new file mode 100644 index 000000000..2b74c9a5b --- /dev/null +++ b/src/main/perl/lib/TAP/Formatter/Session.pm @@ -0,0 +1,220 @@ +package TAP::Formatter::Session; + +use strict; +use warnings; + +use base 'TAP::Base'; + +my @ACCESSOR; + +BEGIN { + + @ACCESSOR = qw( name formatter parser show_count ); + + for my $method (@ACCESSOR) { + no strict 'refs'; + *$method = sub { shift->{$method} }; + } +} + +=head1 NAME + +TAP::Formatter::Session - Abstract base class for harness output delegate + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + formatter => $self, + ) + my $harness = TAP::Formatter::Console::Session->new( \%args ); + +The constructor returns a new C object. + +=over 4 + +=item * C + +=item * C + +=item * C + +=item * C + +=back + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + for my $name (@ACCESSOR) { + $self->{$name} = delete $arg_for{$name}; + } + + if ( !defined $self->show_count ) { + $self->{show_count} = 1; # defaults to true + } + if ( $self->show_count ) { # but may be a damned lie! + $self->{show_count} = $self->_should_show_count; + } + + if ( my @props = sort keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + return $self; +} + +=head3 C
+ +Output test preamble + +=head3 C + +Called by the harness for each line of TAP it receives. + +=head3 C + +Called to close a test session. + +=head3 C + +Called by C to clear the line showing test progress, or the parallel +test ruler, prior to printing the final test result. + +=head3 C + +Return a formatted string about the elapsed (wall-clock) time +and about the consumed CPU time. + +=cut + +sub header { } + +sub result { } + +sub close_test { } + +sub clear_for_close { } + +sub _should_show_count { + my $self = shift; + return + !$self->formatter->verbose + && -t $self->formatter->stdout + && !$ENV{HARNESS_NOTTY}; +} + +sub _format_for_output { + my ( $self, $result ) = @_; + return $self->formatter->normalize ? $result->as_string : $result->raw; +} + +sub _output_test_failure { + my ( $self, $parser ) = @_; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $tests_run = $parser->tests_run; + my $tests_planned = $parser->tests_planned; + + my $total + = defined $tests_planned + ? $tests_planned + : $tests_run; + + my $passed = $parser->passed; + + # The total number of fails includes any tests that were planned but + # didn't run + my $failed = $parser->failed + $total - $tests_run; + my $exit = $parser->exit; + + if ( my $exit = $parser->exit ) { + my $wstat = $parser->wait; + my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); + $formatter->_failure_output("Dubious, test returned $status\n"); + } + + if ( $failed == 0 ) { + $formatter->_failure_output( + $total + ? "All $total subtests passed " + : 'No subtests run ' + ); + } + else { + $formatter->_failure_output("Failed $failed/$total subtests "); + if ( !$total ) { + $formatter->_failure_output("\nNo tests run!"); + } + } + + if ( my $skipped = $parser->skipped ) { + $passed -= $skipped; + my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); + $formatter->_output( + "\n\t(less $skipped skipped $test: $passed okay)"); + } + + if ( my $failed = $parser->todo_passed ) { + my $test = $failed > 1 ? 'tests' : 'test'; + $formatter->_output( + "\n\t($failed TODO $test unexpectedly succeeded)"); + } + + $formatter->_output("\n"); +} + +sub _make_ok_line { + my ( $self, $suffix ) = @_; + return "ok$suffix\n"; +} + +sub time_report { + my ( $self, $formatter, $parser ) = @_; + + my @time_report; + if ( $formatter->timer ) { + my $start_time = $parser->start_time; + my $end_time = $parser->end_time; + if ( defined $start_time and defined $end_time ) { + my $elapsed = $end_time - $start_time; + push @time_report, + $self->time_is_hires + ? sprintf( ' %8d ms', $elapsed * 1000 ) + : sprintf( ' %8s s', $elapsed || '<1' ); + } + my $start_times = $parser->start_times(); + my $end_times = $parser->end_times(); + my $usr = $end_times->[0] - $start_times->[0]; + my $sys = $end_times->[1] - $start_times->[1]; + my $cusr = $end_times->[2] - $start_times->[2]; + my $csys = $end_times->[3] - $start_times->[3]; + push @time_report, + sprintf('(%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)', + $usr, $sys, $cusr, $csys, + $usr + $sys + $cusr + $csys); + } + + return "@time_report"; +} + +1; diff --git a/src/main/perl/lib/TAP/Harness.pm b/src/main/perl/lib/TAP/Harness.pm new file mode 100644 index 000000000..f7d2115ac --- /dev/null +++ b/src/main/perl/lib/TAP/Harness.pm @@ -0,0 +1,1072 @@ +package TAP::Harness; + +use strict; +use warnings; +use Carp; + +use File::Spec; +use File::Path; +use IO::Handle; + +use base 'TAP::Base'; + +=head1 NAME + +TAP::Harness - Run test scripts with statistics + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +$ENV{HARNESS_ACTIVE} = 1; +$ENV{HARNESS_VERSION} = $VERSION; + +END { + + # For VMS. + delete $ENV{HARNESS_ACTIVE}; + delete $ENV{HARNESS_VERSION}; +} + +=head1 DESCRIPTION + +This is a simple test harness which allows tests to be run and results +automatically aggregated and output to STDOUT. + +=head1 SYNOPSIS + + use TAP::Harness; + my $harness = TAP::Harness->new( \%args ); + $harness->runtests(@tests); + +=cut + +my %VALIDATION_FOR; +my @FORMATTER_ARGS; + +sub _error { + my $self = shift; + return $self->{error} unless @_; + $self->{error} = shift; +} + +BEGIN { + + @FORMATTER_ARGS = qw( + directives verbosity timer failures comments errors stdout color + show_count normalize + ); + + %VALIDATION_FOR = ( + lib => sub { + my ( $self, $libs ) = @_; + $libs = [$libs] unless 'ARRAY' eq ref $libs; + + return [ map {"-I$_"} @$libs ]; + }, + switches => sub { shift; shift }, + exec => sub { shift; shift }, + merge => sub { shift; shift }, + aggregator_class => sub { shift; shift }, + formatter_class => sub { shift; shift }, + multiplexer_class => sub { shift; shift }, + parser_class => sub { shift; shift }, + scheduler_class => sub { shift; shift }, + formatter => sub { shift; shift }, + jobs => sub { shift; shift }, + test_args => sub { shift; shift }, + ignore_exit => sub { shift; shift }, + rules => sub { shift; shift }, + rulesfile => sub { shift; shift }, + sources => sub { shift; shift }, + version => sub { shift; shift }, + trap => sub { shift; shift }, + ); + + for my $method ( keys %VALIDATION_FOR ) { + no strict 'refs'; + if ( $method eq 'lib' || $method eq 'switches' ) { + *{$method} = sub { + my $self = shift; + unless (@_) { + $self->{$method} ||= []; + return wantarray + ? @{ $self->{$method} } + : $self->{$method}; + } + $self->_croak("Too many arguments to method '$method'") + if @_ > 1; + my $args = shift; + $args = [$args] unless ref $args; + $self->{$method} = $args; + return $self; + }; + } + else { + *{$method} = sub { + my $self = shift; + return $self->{$method} unless @_; + $self->{$method} = shift; + }; + } + } + + for my $method (@FORMATTER_ARGS) { + no strict 'refs'; + *{$method} = sub { + my $self = shift; + return $self->formatter->$method(@_); + }; + } +} + +############################################################################## + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + verbosity => 1, + lib => [ 'lib', 'blib/lib', 'blib/arch' ], + ) + my $harness = TAP::Harness->new( \%args ); + +The constructor returns a new C object. It accepts an +optional hashref whose allowed keys are: + +=over 4 + +=item * C + +Set the verbosity level: + + 1 verbose Print individual test results to STDOUT. + 0 normal + -1 quiet Suppress some test output (mostly failures + while tests are running). + -2 really quiet Suppress everything but the tests summary. + -3 silent Suppress everything. + +=item * C + +Append run time for each test to output. Uses L if +available. + +=item * C + +Show test failures (this is a no-op if C is selected). + +=item * C + +Show test comments (this is a no-op if C is selected). + +=item * C + +Update the running test count during testing. + +=item * C + +Set to a true value to normalize the TAP that is emitted in verbose modes. + +=item * C + +Accepts a scalar value or array ref of scalar values indicating which +paths to allowed libraries should be included if Perl tests are +executed. Naturally, this only makes sense in the context of tests +written in Perl. + +=item * C + +Accepts a scalar value or array ref of scalar values indicating which +switches should be included if Perl tests are executed. Naturally, this +only makes sense in the context of tests written in Perl. + +=item * C + +A reference to an C<@INC> style array of arguments to be passed to each +test program. + + test_args => ['foo', 'bar'], + +if you want to pass different arguments to each test then you should +pass a hash of arrays, keyed by the alias for each test: + + test_args => { + my_test => ['foo', 'bar'], + other_test => ['baz'], + } + +=item * C + +Attempt to produce color output. + +=item * C + +Typically, Perl tests are run through this. However, anything which +spits out TAP is fine. You can use this argument to specify the name of +the program (and optional switches) to run your tests with: + + exec => ['/usr/bin/ruby', '-w'] + +You can also pass a subroutine reference in order to determine and +return the proper program to run based on a given test script. The +subroutine reference should expect the TAP::Harness object itself as the +first argument, and the file name as the second argument. It should +return an array reference containing the command to be run and including +the test file name. It can also simply return C, in which case +TAP::Harness will fall back on executing the test script in Perl: + + exec => sub { + my ( $harness, $test_file ) = @_; + + # Let Perl tests run. + return undef if $test_file =~ /[.]t$/; + return [ qw( /usr/bin/ruby -w ), $test_file ] + if $test_file =~ /[.]rb$/; + } + +If the subroutine returns a scalar with a newline or a filehandle, it +will be interpreted as raw TAP or as a TAP stream, respectively. + +=item * C + +If C is true the harness will create parsers that merge STDOUT +and STDERR together for any processes they start. + +=item * C + +I. + +If set, C must be a hashref containing the names of the +Ls to load and/or configure. The values are a +hash of configuration that will be accessible to the source handlers via +L. + +For example: + + sources => { + Perl => { exec => '/path/to/custom/perl' }, + File => { extensions => [ '.tap', '.txt' ] }, + MyCustom => { some => 'config' }, + } + +The C parameter affects how C, C and C parameters +are handled. + +For more details, see the C parameter in L, +L, and L. + +=item * C + +The name of the class to use to aggregate test results. The default is +L. + +=item * C + +I. + +Assume this TAP version for L instead of default TAP +version 12. + +=item * C + +The name of the class to use to format output. The default is +L, or L if the output +isn't a TTY. + +=item * C + +The name of the class to use to multiplex tests during parallel testing. +The default is L. + +=item * C + +The name of the class to use to parse TAP. The default is +L. + +=item * C + +The name of the class to use to schedule test execution. The default is +L. + +=item * C + +If set C must be an object that is capable of formatting the +TAP output. See L for an example. + +=item * C + +If parse errors are found in the TAP output, a note of this will be +made in the summary report. To see all of the parse errors, set this +argument to true: + + errors => 1 + +=item * C + +If set to a true value, only test results with directives will be +displayed. This overrides other settings such as C or +C. + +=item * C + +If set to a true value instruct C to ignore exit and wait +status from test scripts. + +=item * C + +The maximum number of parallel tests to run at any time. Which tests +can be run in parallel is controlled by C. The default is to +run only one test at a time. + +=item * C + +A reference to a hash of rules that control which tests may be executed in +parallel. If no rules are declared and L is available, +C attempts to load rules from a YAML file specified by the +C parameter. If no rules file exists, the default is for all +tests to be eligible to be run in parallel. + +Here some simple examples. For the full details of the data structure +and the related glob-style pattern matching, see +L. + + # Run all tests in sequence, except those starting with "p" + $harness->rules({ + par => 't/p*.t' + }); + + # Equivalent YAML file + --- + par: t/p*.t + + # Run all tests in parallel, except those starting with "p" + $harness->rules({ + seq => [ + { seq => 't/p*.t' }, + { par => '**' }, + ], + }); + + # Equivalent YAML file + --- + seq: + - seq: t/p*.t + - par: ** + + # Run some startup tests in sequence, then some parallel tests than some + # teardown tests in sequence. + $harness->rules({ + seq => [ + { seq => 't/startup/*.t' }, + { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } + { seq => 't/shutdown/*.t' }, + ], + + }); + + # Equivalent YAML file + --- + seq: + - seq: t/startup/*.t + - par: + - t/a/*.t + - t/b/*.t + - t/c/*.t + - seq: t/shutdown/*.t + +This is an experimental feature and the interface may change. + +=item * C + +This specifies where to find a YAML file of test scheduling rules. If not +provided, it looks for a default file to use. It first checks for a file given +in the C environment variable, then it checks for +F and then F. + +=item * C + +A filehandle for catching standard output. + +=item * C + +Attempt to print summary information if run is interrupted by +SIGINT (Ctrl-C). + +=back + +Any keys for which the value is C will be ignored. + +=cut + +# new supplied by TAP::Base + +{ + my @legal_callback = qw( + parser_args + made_parser + before_runtests + after_runtests + after_test + ); + + my %default_class = ( + aggregator_class => 'TAP::Parser::Aggregator', + formatter_class => 'TAP::Formatter::Console', + multiplexer_class => 'TAP::Parser::Multiplexer', + parser_class => 'TAP::Parser', + scheduler_class => 'TAP::Parser::Scheduler', + ); + + sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize( $arg_for, \@legal_callback ); + my %arg_for = %$arg_for; # force a shallow copy + + for my $name ( keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + + my $value = $self->$validate($property); + if ( $self->_error ) { + $self->_croak; + } + $self->$name($value); + } + } + + $self->jobs(1) unless defined $self->jobs; + + if ( ! defined $self->rules ) { + $self->_maybe_load_rulesfile; + } + + local $default_class{formatter_class} = 'TAP::Formatter::File' + unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY}; + + while ( my ( $attr, $class ) = each %default_class ) { + $self->$attr( $self->$attr() || $class ); + } + + unless ( $self->formatter ) { + + # This is a little bodge to preserve legacy behaviour. It's + # pretty horrible that we know which args are destined for + # the formatter. + my %formatter_args = ( jobs => $self->jobs ); + for my $name (@FORMATTER_ARGS) { + if ( defined( my $property = delete $arg_for{$name} ) ) { + $formatter_args{$name} = $property; + } + } + + $self->formatter( + $self->_construct( $self->formatter_class, \%formatter_args ) + ); + } + + if ( my @props = keys %arg_for ) { + $self->_croak('Unknown arguments to TAP::Harness::new ('.join(' ',sort @props).')'); + } + + return $self; + } + + sub _maybe_load_rulesfile { + my ($self) = @_; + + my ($rulesfile) = defined $self->rulesfile ? $self->rulesfile : + defined($ENV{HARNESS_RULESFILE}) ? $ENV{HARNESS_RULESFILE} : + grep { -r } qw(./testrules.yml t/testrules.yml); + + if ( defined $rulesfile && -r $rulesfile ) { + if ( ! eval { require CPAN::Meta::YAML; 1} ) { + warn "CPAN::Meta::YAML required to process $rulesfile" ; + return; + } + my $layer = "$]" < "5.008" ? "" : ":encoding(UTF-8)"; + open my $fh, "<$layer", $rulesfile + or die "Couldn't open $rulesfile: $!"; + my $yaml_text = do { local $/; <$fh> }; + my $yaml = CPAN::Meta::YAML->read_string($yaml_text) + or die CPAN::Meta::YAML->errstr; + $self->rules( $yaml->[0] ); + } + return; + } +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + $harness->runtests(@tests); + +Accepts an array of C<@tests> to be run. This should generally be the +names of test files, but this is not required. Each element in C<@tests> +will be passed to C as a C. See +L for more information. + +It is possible to provide aliases that will be displayed in place of the +test name by supplying the test as a reference to an array containing +C<< [ $test, $alias ] >>: + + $harness->runtests( [ 't/foo.t', 'Foo Once' ], + [ 't/foo.t', 'Foo Twice' ] ); + +Normally it is an error to attempt to run the same test twice. Aliases +allow you to overcome this limitation by giving each run of the test a +unique name. + +Tests will be run in the order found. + +If the environment variable C is defined it +should name a directory into which a copy of the raw TAP for each test +will be written. TAP is written to files named for each test. +Subdirectories will be created as needed. + +Returns a L containing the test results. + +=cut + +sub runtests { + my ( $self, @tests ) = @_; + + my $aggregate = $self->_construct( $self->aggregator_class ); + + $self->_make_callback( 'before_runtests', $aggregate ); + $aggregate->start; + my $finish = sub { + my $interrupted = shift; + $aggregate->stop; + $self->summary( $aggregate, $interrupted ); + $self->_make_callback( 'after_runtests', $aggregate ); + }; + my $run = sub { + my $bailout; + eval { $self->aggregate_tests( $aggregate, @tests ); 1 } + or do { $bailout = $@ || 'unknown_error' }; + die $bailout if defined $bailout; + $finish->(); + }; + $self->{bail_summary} = sub{ + print "\n"; + $finish->(1); + }; + + if ( $self->trap ) { + local $SIG{INT} = sub { + print "\n"; + $finish->(1); + exit; + }; + $run->(); + } + else { + $run->(); + } + + return $aggregate; +} + +=head3 C + + $harness->summary( $aggregator ); + +Output the summary for a L. + +=cut + +sub summary { + my ( $self, @args ) = @_; + $self->formatter->summary(@args); +} + +sub _after_test { + my ( $self, $aggregate, $job, $parser ) = @_; + + $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); + $aggregate->add( $job->description, $parser ); +} + +sub _bailout { + my ( $self, $result, $parser, $session, $aggregate, $job ) = @_; + + $self->finish_parser( $parser, $session ); + $self->_after_test( $aggregate, $job, $parser ); + $job->finish; + + my $explanation = $result->explanation; + $self->{bail_summary}() if $self->{bail_summary}; + die "FAILED--Further testing stopped" + . ( $explanation ? ": $explanation\n" : ".\n" ); +} + +sub _aggregate_parallel { + my ( $self, $aggregate, $scheduler ) = @_; + + my $jobs = $self->jobs; + my $mux = $self->_construct( $self->multiplexer_class ); + + RESULT: { + + # Keep multiplexer topped up + FILL: + while ( $mux->parsers < $jobs ) { + my $job = $scheduler->get_job; + + # If we hit a spinner stop filling and start running. + last FILL if !defined $job || $job->is_spinner; + + my ( $parser, $session ) = $self->make_parser($job); + $mux->add( $parser, [ $session, $job ] ); + + # The job has started: begin the timers + $parser->start_time( $parser->get_time ); + $parser->start_times( $parser->get_times ); + } + + if ( my ( $parser, $stash, $result ) = $mux->next ) { + my ( $session, $job ) = @$stash; + if ( defined $result ) { + $session->result($result); + $self->_bailout($result, $parser, $session, $aggregate, $job ) + if $result->is_bailout; + } + else { + + # End of parser. Automatically removed from the mux. + $self->finish_parser( $parser, $session ); + $self->_after_test( $aggregate, $job, $parser ); + $job->finish; + } + redo RESULT; + } + } + + return; +} + +sub _aggregate_single { + my ( $self, $aggregate, $scheduler ) = @_; + + JOB: + while ( my $job = $scheduler->get_job ) { + next JOB if $job->is_spinner; + + my ( $parser, $session ) = $self->make_parser($job); + + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + if ( $result->is_bailout ) { + + # Keep reading until input is exhausted in the hope + # of allowing any pending diagnostics to show up. + 1 while $parser->next; + $self->_bailout($result, $parser, $session, $aggregate, $job ); + } + } + + $self->finish_parser( $parser, $session ); + $self->_after_test( $aggregate, $job, $parser ); + $job->finish; + } + + return; +} + +=head3 C + + $harness->aggregate_tests( $aggregate, @tests ); + +Run the named tests and display a summary of result. Tests will be run +in the order found. + +Test results will be added to the supplied L. +C may be called multiple times to run several sets of +tests. Multiple C instances may be used to pass results +to a single aggregator so that different parts of a complex test suite +may be run using different C settings. This is useful, for +example, in the case where some tests should run in parallel but others +are unsuitable for parallel execution. + + my $formatter = TAP::Formatter::Console->new; + my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); + my $par_harness = TAP::Harness->new( + { formatter => $formatter, + jobs => 9 + } + ); + my $aggregator = TAP::Parser::Aggregator->new; + + $aggregator->start(); + $ser_harness->aggregate_tests( $aggregator, @ser_tests ); + $par_harness->aggregate_tests( $aggregator, @par_tests ); + $aggregator->stop(); + $formatter->summary($aggregator); + +Note that for simpler testing requirements it will often be possible to +replace the above code with a single call to C. + +Each element of the C<@tests> array is either: + +=over + +=item * the source name of a test to run + +=item * a reference to a [ source name, display name ] array + +=back + +In the case of a perl test suite, typically I are simply the file +names of the test scripts to run. + +When you supply a separate display name it becomes possible to run a +test more than once; the display name is effectively the alias by which +the test is known inside the harness. The harness doesn't care if it +runs the same test more than once when each invocation uses a +different name. + +=cut + +sub aggregate_tests { + my ( $self, $aggregate, @tests ) = @_; + + my $jobs = $self->jobs; + my $scheduler = $self->make_scheduler(@tests); + + # #12458 + local $ENV{HARNESS_IS_VERBOSE} = 1 + if $self->formatter->verbosity > 0; + + # Formatter gets only names. + $self->formatter->prepare( map { $_->description } $scheduler->get_all ); + + if ( $self->jobs > 1 ) { + $self->_aggregate_parallel( $aggregate, $scheduler ); + } + else { + $self->_aggregate_single( $aggregate, $scheduler ); + } + + return; +} + +sub _add_descriptions { + my $self = shift; + + # Turn unwrapped scalars into anonymous arrays and copy the name as + # the description for tests that have only a name. + return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } + map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; +} + +=head3 C + +Called by the harness when it needs to create a +L. Override in a subclass to provide an +alternative scheduler. C is passed the list of tests +that was passed to C. + +=cut + +sub make_scheduler { + my ( $self, @tests ) = @_; + return $self->_construct( + $self->scheduler_class, + tests => [ $self->_add_descriptions(@tests) ], + rules => $self->rules + ); +} + +=head3 C + +Gets or sets the number of concurrent test runs the harness is +handling. By default, this value is 1 -- for parallel testing, this +should be set higher. + +=cut + +############################################################################## + +sub _get_parser_args { + my ( $self, $job ) = @_; + my $test_prog = $job->filename; + my %args = (); + + $args{sources} = $self->sources if $self->sources; + + my @switches; + @switches = $self->lib if $self->lib; + push @switches => $self->switches if $self->switches; + $args{switches} = \@switches; + $args{spool} = $self->_open_spool($test_prog); + $args{merge} = $self->merge; + $args{ignore_exit} = $self->ignore_exit; + $args{version} = $self->version if $self->version; + + if ( my $exec = $self->exec ) { + $args{exec} + = ref $exec eq 'CODE' + ? $exec->( $self, $test_prog ) + : [ @$exec, $test_prog ]; + if ( not defined $args{exec} ) { + $args{source} = $test_prog; + } + elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) { + $args{source} = delete $args{exec}; + } + } + else { + $args{source} = $test_prog; + } + + if ( defined( my $test_args = $self->test_args ) ) { + + if ( ref($test_args) eq 'HASH' ) { + + # different args for each test + if ( exists( $test_args->{ $job->description } ) ) { + $test_args = $test_args->{ $job->description }; + } + else { + $self->_croak( "TAP::Harness Can't find test_args for " + . $job->description ); + } + } + + $args{test_args} = $test_args; + } + + return \%args; +} + +=head3 C + +Make a new parser and display formatter session. Typically used and/or +overridden in subclasses. + + my ( $parser, $session ) = $harness->make_parser; + +=cut + +sub make_parser { + my ( $self, $job ) = @_; + + my $args = $self->_get_parser_args($job); + $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); + my $parser = $self->_construct( $self->parser_class, $args ); + + $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); + my $session = $self->formatter->open_test( $job->description, $parser ); + + return ( $parser, $session ); +} + +=head3 C + +Terminate use of a parser. Typically used and/or overridden in +subclasses. The parser isn't destroyed as a result of this. + +=cut + +sub finish_parser { + my ( $self, $parser, $session ) = @_; + + $session->close_test; + $self->_close_spool($parser); + + return $parser; +} + +sub _open_spool { + my $self = shift; + my $test = shift; + + if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { + + my $spool = File::Spec->catfile( $spool_dir, $test ); + + # Make the directory + my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); + my $path = File::Spec->catpath( $vol, $dir, '' ); + eval { mkpath($path) }; + $self->_croak($@) if $@; + + my $spool_handle = IO::Handle->new; + open( $spool_handle, ">$spool" ) + or $self->_croak(" Can't write $spool ( $! ) "); + + return $spool_handle; + } + + return; +} + +sub _close_spool { + my $self = shift; + my ($parser) = @_; + + if ( my $spool_handle = $parser->delete_spool ) { + close($spool_handle) + or $self->_croak(" Error closing TAP spool file( $! ) \n "); + } + + return; +} + +sub _croak { + my ( $self, $message ) = @_; + unless ($message) { + $message = $self->_error; + } + $self->SUPER::_croak($message); + + return; +} + +1; + +__END__ + +############################################################################## + +=head1 CONFIGURING + +C is designed to be easy to configure. + +=head2 Plugins + +C plugins let you change the way TAP is I to and I +from the parser. + +Ls handle TAP I. You can configure them +and load custom handlers using the C parameter to L. + +Ls handle TAP I. You can load custom formatters by +using the C parameter to L. To configure a formatter, +you currently need to instantiate it outside of L and pass it in +with the C parameter to L. This I be addressed by adding +a I parameter to L in the future. + +=head2 C + +L version C<0.30> supports C. + +To load C plugins, you'll need to use the C +parameter to C, typically from your C. For example: + + Module::Build->new( + module_name => 'MyApp', + test_file_exts => [qw(.t .tap .txt)], + use_tap_harness => 1, + tap_harness_args => { + sources => { + MyCustom => {}, + File => { + extensions => ['.tap', '.txt'], + }, + }, + formatter_class => 'TAP::Formatter::HTML', + }, + build_requires => { + 'Module::Build' => '0.30', + 'TAP::Harness' => '3.18', + }, + )->create_build_script; + +See L + +=head2 C + +L does not support L out-of-the-box. + +=head2 C + +L supports C plugins, and has a plugin system of its +own. See L, L and L +for more details. + +=head1 WRITING PLUGINS + +If you can't configure C to do what you want, and you can't find +an existing plugin, consider writing one. + +The two primary use cases supported by L for plugins are I +and I: + +=over 2 + +=item Customize how TAP gets into the parser + +To do this, you can either extend an existing L, +or write your own. It's a pretty simple API, and they can be loaded and +configured using the C parameter to L. + +=item Customize how TAP results are output from the parser + +To do this, you can either extend an existing L, or write your +own. Writing formatters are a bit more involved than writing a +I, as you'll need to understand the L API. A +good place to start is by understanding how L works. + +Custom formatters can be loaded configured using the C +parameter to L. + +=back + +=head1 SUBCLASSING + +If you can't configure C to do exactly what you want, and writing +a plugin isn't an option, consider extending it. It is designed to be (mostly) +easy to subclass, though the cases when sub-classing is necessary should be few +and far between. + +=head2 Methods + +The following methods are ones you may wish to override if you want to +subclass C. + +=over 4 + +=item L + +=item L + +=item L + +=back + +=cut + +=head1 REPLACING + +If you like the C utility and L but you want your +own harness, all you need to do is write one and provide C and +C methods. Then you can use the C utility like so: + + prove --harness My::Test::Harness + +Note that while C accepts a list of tests (or things to be +tested), C has a fairly rich set of arguments. You'll probably want +to read over this code carefully to see how all of them are being used. + +=head1 SEE ALSO + +L + +=cut + +# vim:ts=4:sw=4:et:sta diff --git a/src/main/perl/lib/TAP/Harness/Beyond.pod b/src/main/perl/lib/TAP/Harness/Beyond.pod new file mode 100644 index 000000000..989e2efc1 --- /dev/null +++ b/src/main/perl/lib/TAP/Harness/Beyond.pod @@ -0,0 +1,426 @@ +=head1 NAME + +Test::Harness::Beyond - Beyond make test + +=head1 Beyond make test + +Test::Harness is responsible for running test scripts, analysing +their output and reporting success or failure. When I type +F (or F<./Build test>) for a module, Test::Harness is usually +used to run the tests (not all modules use Test::Harness but the +majority do). + +To start exploring some of the features of Test::Harness I need to +switch from F to the F command (which ships with +Test::Harness). For the following examples I'll also need a recent +version of Test::Harness installed; 3.14 is current as I write. + +For the examples I'm going to assume that we're working with a +'normal' Perl module distribution. Specifically I'll assume that +typing F or F<./Build> causes the built, ready-to-install module +code to be available below ./blib/lib and ./blib/arch and that +there's a directory called 't' that contains our tests. Test::Harness +isn't hardwired to that configuration but it saves me from explaining +which files live where for each example. + +Back to F; like F it runs a test suite - but it +provides far more control over which tests are executed, in what +order and how their results are reported. Typically F +runs all the test scripts below the 't' directory. To do the same +thing with prove I type: + + prove -rb t + +The switches here are -r to recurse into any directories below 't' +and -b which adds ./blib/lib and ./blib/arch to Perl's include path +so that the tests can find the code they will be testing. If I'm +testing a module of which an earlier version is already installed +I need to be careful about the include path to make sure I'm not +running my tests against the installed version rather than the new +one that I'm working on. + +Unlike F, typing F doesn't automatically rebuild +my module. If I forget to make before prove I will be testing against +older versions of those files - which inevitably leads to confusion. +I either get into the habit of typing + + make && prove -rb t + +or - if I have no XS code that needs to be built I use the modules +below F instead + + prove -Ilib -r t + +So far I've shown you nothing that F doesn't do. Let's +fix that. + +=head2 Saved State + +If I have failing tests in a test suite that consists of more than +a handful of scripts and takes more than a few seconds to run it +rapidly becomes tedious to run the whole test suite repeatedly as +I track down the problems. + +I can tell prove just to run the tests that are failing like this: + + prove -b t/this_fails.t t/so_does_this.t + +That speeds things up but I have to make a note of which tests are +failing and make sure that I run those tests. Instead I can use +prove's --state switch and have it keep track of failing tests for +me. First I do a complete run of the test suite and tell prove to +save the results: + + prove -rb --state=save t + +That stores a machine readable summary of the test run in a file +called '.prove' in the current directory. If I have failures I can +then run just the failing scripts like this: + + prove -b --state=failed + +I can also tell prove to save the results again so that it updates +its idea of which tests failed: + + prove -b --state=failed,save + +As soon as one of my failing tests passes it will be removed from +the list of failed tests. Eventually I fix them all and prove can +find no failing tests to run: + + Files=0, Tests=0, 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) + Result: NOTESTS + +As I work on a particular part of my module it's most likely that +the tests that cover that code will fail. I'd like to run the whole +test suite but have it prioritize these 'hot' tests. I can tell +prove to do this: + + prove -rb --state=hot,save t + +All the tests will run but those that failed most recently will be +run first. If no tests have failed since I started saving state all +tests will run in their normal order. This combines full test +coverage with early notification of failures. + +The --state switch supports a number of options; for example to run +failed tests first followed by all remaining tests ordered by the +timestamps of the test scripts - and save the results - I can use + + prove -rb --state=failed,new,save t + +See the prove documentation (type prove --man) for the full list +of state options. + +When I tell prove to save state it writes a file called '.prove' +('_prove' on Windows) in the current directory. It's a YAML document +so it's quite easy to write tools of your own that work on the saved +test state - but the format isn't officially documented so it might +change without (much) warning in the future. + +=head2 Parallel Testing + +If my tests take too long to run I may be able to speed them up by +running multiple test scripts in parallel. This is particularly +effective if the tests are I/O bound or if I have multiple CPU +cores. I tell prove to run my tests in parallel like this: + + prove -rb -j 9 t + +The -j switch enables parallel testing; the number that follows it +is the maximum number of tests to run in parallel. Sometimes tests +that pass when run sequentially will fail when run in parallel. For +example if two different test scripts use the same temporary file +or attempt to listen on the same socket I'll have problems running +them in parallel. If I see unexpected failures I need to check my +tests to work out which of them are trampling on the same resource +and rename temporary files or add locks as appropriate. + +To get the most performance benefit I want to have the test scripts +that take the longest to run start first - otherwise I'll be waiting +for the one test that takes nearly a minute to complete after all +the others are done. I can use the --state switch to run the tests +in slowest to fastest order: + + prove -rb -j 9 --state=slow,save t + +=head2 Non-Perl Tests + +The Test Anything Protocol (http://testanything.org/) isn't just +for Perl. Just about any language can be used to write tests that +output TAP. There are TAP based testing libraries for C, C++, PHP, +Python and many others. If I can't find a TAP library for my language +of choice it's easy to generate valid TAP. It looks like this: + + 1..3 + ok 1 - init OK + ok 2 - opened file + not ok 3 - appended to file + +The first line is the plan - it specifies the number of tests I'm +going to run so that it's easy to check that the test script didn't +exit before running all the expected tests. The following lines are +the test results - 'ok' for pass, 'not ok' for fail. Each test has +a number and, optionally, a description. And that's it. Any language +that can produce output like that on STDOUT can be used to write +tests. + +Recently I've been rekindling a two-decades-old interest in Forth. +Evidently I have a masochistic streak that even Perl can't satisfy. +I want to write tests in Forth and run them using prove (you can +find my gforth TAP experiments at +https://svn.hexten.net/andy/Forth/Testing/). I can use the --exec +switch to tell prove to run the tests using gforth like this: + + prove -r --exec gforth t + +Alternately, if the language used to write my tests allows a shebang +line I can use that to specify the interpreter. Here's a test written +in PHP: + + #!/usr/bin/php + + +If I save that as t/phptest.t the shebang line will ensure that it +runs correctly along with all my other tests. + +=head2 Mixing it up + +Subtle interdependencies between test programs can mask problems - +for example an earlier test may neglect to remove a temporary file +that affects the behaviour of a later test. To find this kind of +problem I use the --shuffle and --reverse options to run my tests +in random or reversed order. + +=head2 Rolling My Own + +If I need a feature that prove doesn't provide I can easily write my own. + +Typically you'll want to change how TAP gets I into and I +from the parser. L supports arbitrary plugins, and L +supports custom I and I that you can load using +either L or L; there are many examples to base mine on. +For more details see L, L, and +L. + +If writing a plugin is not enough, you can write your own test harness; one of +the motives for the 3.00 rewrite of Test::Harness was to make it easier to +subclass and extend. + +The Test::Harness module is a compatibility wrapper around TAP::Harness. +For new applications I should use TAP::Harness directly. As we'll +see, prove uses TAP::Harness. + +When I run prove it processes its arguments, figures out which test +scripts to run and then passes control to TAP::Harness to run the +tests, parse, analyse and present the results. By subclassing +TAP::Harness I can customise many aspects of the test run. + +I want to log my test results in a database so I can track them +over time. To do this I override the summary method in TAP::Harness. +I start with a simple prototype that dumps the results as a YAML +document: + + package My::TAP::Harness; + + use base 'TAP::Harness'; + use YAML; + + sub summary { + my ( $self, $aggregate ) = @_; + print Dump( $aggregate ); + $self->SUPER::summary( $aggregate ); + } + + 1; + +I need to tell prove to use my My::TAP::Harness. If My::TAP::Harness +is on Perl's @INC include path I can + + prove --harness=My::TAP::Harness -rb t + +If I don't have My::TAP::Harness installed on @INC I need to provide +the correct path to perl when I run prove: + + perl -Ilib `which prove` --harness=My::TAP::Harness -rb t + +I can incorporate these options into my own version of prove. It's +pretty simple. Most of the work of prove is handled by App::Prove. +The important code in prove is just: + + use App::Prove; + + my $app = App::Prove->new; + $app->process_args(@ARGV); + exit( $app->run ? 0 : 1 ); + +If I write a subclass of App::Prove I can customise any aspect of +the test runner while inheriting all of prove's behaviour. Here's +myprove: + + #!/usr/bin/env perl use lib qw( lib ); # Add ./lib to @INC + use App::Prove; + + my $app = App::Prove->new; + + # Use custom TAP::Harness subclass + $app->harness( 'My::TAP::Harness' ); + + $app->process_args( @ARGV ); exit( $app->run ? 0 : 1 ); + +Now I can run my tests like this + + ./myprove -rb t + +=head2 Deeper Customisation + +Now that I know how to subclass and replace TAP::Harness I can +replace any other part of the harness. To do that I need to know +which classes are responsible for which functionality. Here's a +brief guided tour; the default class for each component is shown +in parentheses. Normally any replacements I write will be subclasses +of these default classes. + +When I run my tests TAP::Harness creates a scheduler +(TAP::Parser::Scheduler) to work out the running order for the +tests, an aggregator (TAP::Parser::Aggregator) to collect and analyse +the test results and a formatter (TAP::Formatter::Console) to display +those results. + +If I'm running my tests in parallel there may also be a multiplexer +(TAP::Parser::Multiplexer) - the component that allows multiple +tests to run simultaneously. + +Once it has created those helpers TAP::Harness starts running the +tests. For each test it creates a new parser (TAP::Parser) which +is responsible for running the test script and parsing its output. + +To replace any of these components I call one of these harness +methods with the name of the replacement class: + + aggregator_class + formatter_class + multiplexer_class + parser_class + scheduler_class + +For example, to replace the aggregator I would + + $harness->aggregator_class( 'My::Aggregator' ); + +Alternately I can supply the names of my substitute classes to the +TAP::Harness constructor: + + my $harness = TAP::Harness->new( + { aggregator_class => 'My::Aggregator' } + ); + +If I need to reach even deeper into the internals of the harness I +can replace the classes that TAP::Parser uses to execute test scripts +and tokenise their output. Before running a test script TAP::Parser +creates a grammar (TAP::Parser::Grammar) to decode the raw TAP into +tokens, a result factory (TAP::Parser::ResultFactory) to turn the +decoded TAP results into objects and, depending on whether it's +running a test script or reading TAP from a file, scalar or array +a source or an iterator (TAP::Parser::IteratorFactory). + +Each of these objects may be replaced by calling one of these parser +methods: + + source_class + perl_source_class + grammar_class + iterator_factory_class + result_factory_class + +=head2 Callbacks + +As an alternative to subclassing the components I need to change I +can attach callbacks to the default classes. TAP::Harness exposes +these callbacks: + + parser_args Tweak the parameters used to create the parser + made_parser Just made a new parser + before_runtests About to run tests + after_runtests Have run all tests + after_test Have run an individual test script + +TAP::Parser also supports callbacks; bailout, comment, plan, test, +unknown, version and yaml are called for the corresponding TAP +result types, ALL is called for all results, ELSE is called for all +results for which a named callback is not installed and EOF is +called once at the end of each TAP stream. + +To install a callback I pass the name of the callback and a subroutine +reference to TAP::Harness or TAP::Parser's callback method: + + $harness->callback( after_test => sub { + my ( $script, $desc, $parser ) = @_; + } ); + +I can also pass callbacks to the constructor: + + my $harness = TAP::Harness->new({ + callbacks => { + after_test => sub { + my ( $script, $desc, $parser ) = @_; + # Do something interesting here + } + } + }); + +When it comes to altering the behaviour of the test harness there's +more than one way to do it. Which way is best depends on my +requirements. In general if I only want to observe test execution +without changing the harness' behaviour (for example to log test +results to a database) I choose callbacks. If I want to make the +harness behave differently subclassing gives me more control. + +=head2 Parsing TAP + +Perhaps I don't need a complete test harness. If I already have a +TAP test log that I need to parse all I need is TAP::Parser and the +various classes it depends upon. Here's the code I need to run a +test and parse its TAP output + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => 't/simple.t' } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +Alternately I can pass an open filehandle as source and have the +parser read from that rather than attempting to run a test script: + + open my $tap, '<', 'tests.tap' + or die "Can't read TAP transcript ($!)\n"; + my $parser = TAP::Parser->new( { source => $tap } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This approach is useful if I need to convert my TAP based test +results into some other representation. See TAP::Convert::TET +(http://search.cpan.org/dist/TAP-Convert-TET/) for an example of +this approach. + +=head2 Getting Support + +The Test::Harness developers hang out on the tapx-dev mailing +list[1]. For discussion of general, language independent TAP issues +there's the tap-l[2] list. Finally there's a wiki dedicated to the +Test Anything Protocol[3]. Contributions to the wiki, patches and +suggestions are all welcome. + +=for comment + The URLs in [1] and [2] point to 404 pages. What are currently the + correct URLs? + +[1] L +[2] L +[3] L diff --git a/src/main/perl/lib/TAP/Harness/Env.pm b/src/main/perl/lib/TAP/Harness/Env.pm new file mode 100644 index 000000000..ff4d9c8b2 --- /dev/null +++ b/src/main/perl/lib/TAP/Harness/Env.pm @@ -0,0 +1,215 @@ +package TAP::Harness::Env; + +use strict; +use warnings; + +use constant IS_VMS => ( $^O eq 'VMS' ); +use TAP::Object; +use Text::ParseWords qw/shellwords/; + +our $VERSION = '3.52'; + +# Get the parts of @INC which are changed from the stock list AND +# preserve reordering of stock directories. +sub _filtered_inc_vms { + my @inc = grep { !ref } @INC; #28567 + + # VMS has a 255-byte limit on the length of %ENV entries, so + # toss the ones that involve perl_root, the install location + @inc = grep { !/perl_root/i } @inc; + + my @default_inc = _default_inc(); + + my @new_inc; + my %seen; + for my $dir (@inc) { + next if $seen{$dir}++; + + if ( $dir eq ( $default_inc[0] || '' ) ) { + shift @default_inc; + } + else { + push @new_inc, $dir; + } + + shift @default_inc while @default_inc and $seen{ $default_inc[0] }; + } + return @new_inc; +} + +# Cache this to avoid repeatedly shelling out to Perl. +my @inc; + +sub _default_inc { + return @inc if @inc; + + local $ENV{PERL5LIB}; + local $ENV{PERLLIB}; + + my $perl = $ENV{HARNESS_PERL} || $^X; + + # Avoid using -l for the benefit of Perl 6 + chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` ); + return @inc; +} + +sub create { + my $package = shift; + my %input = %{ shift || {} }; + + my @libs = @{ delete $input{lib} || [] }; + my @raw_switches = @{ delete $input{switches} || [] }; + my @opt + = ( @raw_switches, shellwords( $ENV{HARNESS_PERL_SWITCHES} || '' ) ); + my @switches; + while ( my $opt = shift @opt ) { + if ( $opt =~ /^ -I (.*) $ /x ) { + push @libs, length($1) ? $1 : shift @opt; + } + else { + push @switches, $opt; + } + } + + # Do things the old way on VMS... + push @libs, _filtered_inc_vms() if IS_VMS; + + # If $Verbose isn't numeric default to 1. This helps core. + my $verbose + = $ENV{HARNESS_VERBOSE} + ? $ENV{HARNESS_VERBOSE} !~ /\d/ + ? 1 + : $ENV{HARNESS_VERBOSE} + : 0; + + my %args = ( + lib => \@libs, + timer => $ENV{HARNESS_TIMER} || 0, + switches => \@switches, + color => $ENV{HARNESS_COLOR} || 0, + verbosity => $verbose, + ignore_exit => $ENV{HARNESS_IGNORE_EXIT} || 0, + ); + + my $class = delete $input{harness_class} || $ENV{HARNESS_SUBCLASS} || 'TAP::Harness'; + if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { + for my $opt ( split /:/, $env_opt ) { + if ( $opt =~ /^j(\d*)$/ ) { + $args{jobs} = $1 || 9; + } + elsif ( $opt eq 'c' ) { + $args{color} = 1; + } + elsif ( $opt =~ m/^f(.*)$/ ) { + my $fmt = $1; + $fmt =~ s/-/::/g; + $args{formatter_class} = $fmt; + } + elsif ( $opt =~ m/^a(.*)$/ ) { + my $archive = $1; + $class = 'TAP::Harness::Archive'; + $args{archive} = $archive; + } + else { + die "Unknown HARNESS_OPTIONS item: $opt\n"; + } + } + } + return TAP::Object->_construct($class, { %args, %input }); +} + +1; + +=head1 NAME + +TAP::Harness::Env - Parsing harness related environmental variables where appropriate + +=head1 VERSION + +Version 3.52 + +=head1 SYNOPSIS + + my $harness = TAP::Harness::Env->create(\%extra_args) + +=head1 DESCRIPTION + +This module implements the environmental variables that L uses with TAP::Harness, and instantiates the appropriate class with the appropriate arguments. + +=head1 METHODS + +=over 4 + +=item * create( \%args ) + +This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C (which defaults to C), and any argument the harness class accepts. + +=back + +=head1 ENVIRONMENTAL VARIABLES + +=over 4 + +=item C + +Setting this adds perl command line switches to each test file run. + +For example, C will turn on taint mode. +C will run C for +each test. + +=item C + +If true, C will output the verbose results of running +its tests. + +=item C + +Specifies a TAP::Harness subclass to be used in place of TAP::Harness. + +=item C + +Provide additional options to the harness. Currently supported options are: + +=over + +=item C<< j >> + +Run (default 9) parallel jobs. + +=item C<< c >> + +Try to color output. See L. + +=item C<< a >> + +Will use L as the harness class, and save the TAP to +C + +=item C<< fPackage-With-Dashes >> + +Set the formatter_class of the harness being run. Since the C +is separated by C<:>, we use C<-> instead. + +=back + +Multiple options may be separated by colons: + + HARNESS_OPTIONS=j9:c make test + +=item C + +Setting this to true will make the harness display the number of +milliseconds each test took. You can also use F's C<--timer> +switch. + +=item C + +Attempt to produce color output. + +=item C + +If set to a true value instruct C to ignore exit and wait +status from test scripts. + +=back diff --git a/src/main/perl/lib/TAP/Object.pm b/src/main/perl/lib/TAP/Object.pm new file mode 100644 index 000000000..7f8e82075 --- /dev/null +++ b/src/main/perl/lib/TAP/Object.pm @@ -0,0 +1,153 @@ +package TAP::Object; + +use strict; +use warnings; + +=head1 NAME + +TAP::Object - Base class that provides common functionality to all C modules + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +=head1 SYNOPSIS + + package TAP::Whatever; + + use strict; + + use base 'TAP::Object'; + + # new() implementation by TAP::Object + sub _initialize { + my ( $self, @args) = @_; + # initialize your object + return $self; + } + + # ... later ... + my $obj = TAP::Whatever->new(@args); + +=head1 DESCRIPTION + +C provides a default constructor and exception model for all +C classes. Exceptions are raised using L. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +Create a new object. Any arguments passed to C will be passed on to the +L method. Returns a new object. + +=cut + +sub new { + return bless({}, shift)->_initialize(@_); +} + +=head2 Instance Methods + +=head3 C<_initialize> + +Initializes a new object. This method is a stub by default, you should override +it as appropriate. + +I L expects you to return C<$self> or raise an exception. See +L, and L. + +=cut + +sub _initialize { + return $_[0]; +} + +=head3 C<_croak> + +Raise an exception using C from L, eg: + + $self->_croak( 'why me?', 'aaarrgh!' ); + +May also be called as a I method. + + $class->_croak( 'this works too' ); + +=cut + +sub _croak { + my $proto = shift; + require Carp; + Carp::croak(@_); + return; +} + +=head3 C<_confess> + +Raise an exception using C from L, eg: + + $self->_confess( 'why me?', 'aaarrgh!' ); + +May also be called as a I method. + + $class->_confess( 'this works too' ); + +=cut + +sub _confess { + my $proto = shift; + require Carp; + Carp::confess(@_); + return; +} + +=head3 C<_construct> + +Create a new instance of the specified class. + +=cut + +sub _construct { + my ( $self, $class, @args ) = @_; + + $self->_croak("Bad module name $class") + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + unless ( $class->can('new') ) { + local $@; + eval "require $class"; + $self->_croak("Can't load $class: $@") if $@; + } + + return $class->new(@args); +} + +=head3 C + +Create simple getter/setters. + + __PACKAGE__->mk_methods(@method_names); + +=cut + +sub mk_methods { + my ( $class, @methods ) = @_; + for my $method_name (@methods) { + my $method = "${class}::$method_name"; + no strict 'refs'; + *$method = sub { + my $self = shift; + $self->{$method_name} = shift if @_; + return $self->{$method_name}; + }; + } +} + +1; + diff --git a/src/main/perl/lib/TAP/Parser.pm b/src/main/perl/lib/TAP/Parser.pm new file mode 100644 index 000000000..780905ba2 --- /dev/null +++ b/src/main/perl/lib/TAP/Parser.pm @@ -0,0 +1,1931 @@ +package TAP::Parser; + +use strict; +use warnings; + +use TAP::Parser::Grammar (); +use TAP::Parser::Result (); +use TAP::Parser::ResultFactory (); +use TAP::Parser::Source (); +use TAP::Parser::Iterator (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::SourceHandler::Perl (); +use TAP::Parser::SourceHandler::File (); +use TAP::Parser::SourceHandler::RawTAP (); +use TAP::Parser::SourceHandler::Handle (); + +use Carp qw( confess ); + +use base 'TAP::Base'; + +=encoding utf8 + +=head1 NAME + +TAP::Parser - Parse L output + +=head1 VERSION + +Version 3.52 + +=cut + +our $VERSION = '3.52'; + +my $DEFAULT_TAP_VERSION = 12; +my $MAX_TAP_VERSION = 14; + +$ENV{TAP_VERSION} = $MAX_TAP_VERSION; + +END { + + # For VMS. + delete $ENV{TAP_VERSION}; +} + +BEGIN { # making accessors + __PACKAGE__->mk_methods( + qw( + _iterator + _spool + exec + exit + is_good_plan + plan + tests_planned + tests_run + wait + version + in_todo + start_time + end_time + start_times + end_times + skip_all + grammar_class + result_factory_class + iterator_factory_class + ) + ); + + sub _stream { # deprecated + my $self = shift; + $self->_iterator(@_); + } +} # done making accessors + +=head1 SYNOPSIS + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => $source } ); + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +=head1 DESCRIPTION + +C is designed to produce a proper parse of TAP output. For +an example of how to run tests through this module, see the simple +harnesses C. + +There's a wiki dedicated to the Test Anything Protocol: + +L + +It includes the TAP::Parser Cookbook: + +L + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $parser = TAP::Parser->new(\%args); + +Returns a new C object. + +The arguments should be a hashref with I of the following keys: + +=over 4 + +=item * C + +I + +This is the preferred method of passing input to the constructor. + +The C is used to create a L that is passed to the +L which in turn figures out how to handle the source and +creates a for it. The iterator is used by the parser to +read in the TAP stream. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=item * C + +I + +The value should be the complete TAP output. + +The I is used to create a L that is passed to the +L which in turn figures out how to handle the source and +creates a for it. The iterator is used by the parser to +read in the TAP stream. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=item * C + +Must be passed an array reference. + +The I array ref is used to create a L that is passed +to the L which in turn figures out how to handle the +source and creates a for it. The iterator is used by +the parser to read in the TAP stream. + +By default the L class will create a +L object to handle the source. This passes the +array reference strings as command arguments to L: + + exec => [ '/usr/bin/ruby', 't/my_test.rb' ] + +If any C are given they will be appended to the end of the command +argument list. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=back + +The following keys are optional. + +=over 4 + +=item * C + +I. + +If set, C must be a hashref containing the names of the +Ls to load and/or configure. The values are a +hash of configuration that will be accessible to the source handlers via +L. + +For example: + + sources => { + Perl => { exec => '/path/to/custom/perl' }, + File => { extensions => [ '.tap', '.txt' ] }, + MyCustom => { some => 'config' }, + } + +This will cause C to pass custom configuration to two of the built- +in source handlers - L, +L - and attempt to load the C +class. See L for more detail. + +The C parameter affects how C, C and C parameters +are handled. + +See L, L and subclasses for +more details. + +=item * C + +If present, each callback corresponding to a given result type will be called +with the result as the argument if the C method is used: + + my %callbacks = ( + test => \&test_callback, + plan => \&plan_callback, + comment => \&comment_callback, + bailout => \&bailout_callback, + unknown => \&unknown_callback, + ); + + my $aggregator = TAP::Parser::Aggregator->new; + for my $file ( @test_files ) { + my $parser = TAP::Parser->new( + { + source => $file, + callbacks => \%callbacks, + } + ); + $parser->run; + $aggregator->add( $file, $parser ); + } + +=item * C + +If using a Perl file as a source, optional switches may be passed which will +be used when invoking the perl executable. + + my $parser = TAP::Parser->new( { + source => $test_file, + switches => [ '-Ilib' ], + } ); + +=item * C + +Used in conjunction with the C and C option to supply a reference +to an C<@ARGV> style array of arguments to pass to the test program. + +=item * C + +If passed a filehandle will write a copy of all parsed TAP to that handle. + +=item * C + +If false, STDERR is not captured (though it is 'relayed' to keep it +somewhat synchronized with STDOUT.) + +If true, STDERR and STDOUT are the same filehandle. This may cause +breakage if STDERR contains anything resembling TAP format, but does +allow exact synchronization. + +Subtleties of this behavior may be platform-dependent and may change in +the future. + +=item * C + +This option was introduced to let you easily customize which I class +the parser should use. It defaults to L. + +See also L. + +=item * C + +This option was introduced to let you easily customize which I +factory class the parser should use. It defaults to +L. + +See also L. + +=item * C + +I + +This option was introduced to let you easily customize which I +factory class the parser should use. It defaults to +L. + +=back + +=cut + +# new() implementation supplied by TAP::Base + +# This should make overriding behaviour of the Parser in subclasses easier: +sub _default_grammar_class {'TAP::Parser::Grammar'} +sub _default_result_factory_class {'TAP::Parser::ResultFactory'} +sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + my $parser = TAP::Parser->new( { source => $file } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This method returns the results of the parsing, one result at a time. Note +that it is destructive. You can't rewind and examine previous results. + +If callbacks are used, they will be issued before this call returns. + +Each result returned is a subclass of L. See that +module and related classes for more information on how to use them. + +=cut + +sub next { + my $self = shift; + return ( $self->{_iter} ||= $self->_iter )->(); +} + +############################################################################## + +=head3 C + + $parser->run; + +This method merely runs the parser and parses all of the TAP. + +=cut + +sub run { + my $self = shift; + while ( defined( my $result = $self->next ) ) { + + # do nothing + } +} + +############################################################################## + +=head3 C + +Make a new L object and return it. Passes through any +arguments given. + +The C can be customized, as described in L. + +=head3 C + +Make a new L object using the parser's +L, and return it. Passes through any arguments +given. + +The C can be customized, as described in L. + +=head3 C + +I. + +Make a new L object and return it. Passes through +any arguments given. + +C can be customized, as described in L. + +=cut + +# This should make overriding behaviour of the Parser in subclasses easier: +sub make_iterator_factory { shift->iterator_factory_class->new(@_); } +sub make_grammar { shift->grammar_class->new(@_); } +sub make_result { shift->result_factory_class->make_result(@_); } + +{ + + # of the following, anything beginning with an underscore is strictly + # internal and should not be exposed. + my %initialize = ( + version => $DEFAULT_TAP_VERSION, + plan => '', # the test plan (e.g., 1..3) + tests_run => 0, # actual current test numbers + skipped => [], # + todo => [], # + passed => [], # + failed => [], # + actual_failed => [], # how many tests really failed + actual_passed => [], # how many tests really passed + todo_passed => [], # tests which unexpectedly succeed + parse_errors => [], # perfect TAP should have none + ); + + # We seem to have this list hanging around all over the place. We could + # probably get it from somewhere else to avoid the repetition. + my @legal_callback = qw( + test + version + plan + comment + bailout + unknown + yaml + ALL + ELSE + EOF + ); + + my @class_overrides = qw( + grammar_class + result_factory_class + iterator_factory_class + ); + + sub _initialize { + my ( $self, $arg_for ) = @_; + + # everything here is basically designed to convert any TAP source to a + # TAP::Parser::Iterator. + + # Shallow copy + my %args = %{ $arg_for || {} }; + + $self->SUPER::_initialize( \%args, \@legal_callback ); + + # get any class overrides out first: + for my $key (@class_overrides) { + my $default_method = "_default_$key"; + my $val = delete $args{$key} || $self->$default_method(); + $self->$key($val); + } + + my $iterator = delete $args{iterator}; + $iterator ||= delete $args{stream}; # deprecated + my $tap = delete $args{tap}; + my $version = delete $args{version}; + my $raw_source = delete $args{source}; + my $sources = delete $args{sources}; + my $exec = delete $args{exec}; + my $merge = delete $args{merge}; + my $spool = delete $args{spool}; + my $switches = delete $args{switches}; + my $ignore_exit = delete $args{ignore_exit}; + my $test_args = delete $args{test_args} || []; + + if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) { + $self->_croak( + "You may only choose one of 'exec', 'tap', 'source' or 'iterator'" + ); + } + + if ( my @excess = sort keys %args ) { + $self->_croak("Unknown options: @excess"); + } + + # convert $tap & $exec to $raw_source equiv. + my $type = ''; + my $source = TAP::Parser::Source->new; + if ($tap) { + $type = 'raw TAP'; + $source->raw( \$tap ); + } + elsif ($exec) { + $type = 'exec ' . $exec->[0]; + $source->raw( { exec => $exec } ); + } + elsif ($raw_source) { + $type = 'source ' . ref($raw_source) || $raw_source; + $source->raw( ref($raw_source) ? $raw_source : \$raw_source ); + } + elsif ($iterator) { + $type = 'iterator ' . ref($iterator); + } + + if ( $source->raw ) { + my $src_factory = $self->make_iterator_factory($sources); + $source->merge($merge)->switches($switches) + ->test_args($test_args); + $iterator = $src_factory->make_iterator($source); + } + + unless ($iterator) { + $self->_croak( + "PANIC: could not determine iterator for input $type"); + } + + while ( my ( $k, $v ) = each %initialize ) { + $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; + } + + $self->version($version) if $version; + $self->_iterator($iterator); + $self->_spool($spool); + $self->ignore_exit($ignore_exit); + + return $self; + } +} + +=head1 INDIVIDUAL RESULTS + +If you've read this far in the docs, you've seen this: + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +Each result returned is a L subclass, referred to as +I. + +=head2 Result types + +Basically, you fetch individual results from the TAP. The six types, with +examples of each, are as follows: + +=over 4 + +=item * Version + + TAP version 12 + +=item * Plan + + 1..42 + +=item * Pragma + + pragma +strict + +=item * Test + + ok 3 - We should start with some foobar! + +=item * Comment + + # Hope we don't use up the foobar. + +=item * Bailout + + Bail out! We ran out of foobar! + +=item * Unknown + + ... yo, this ain't TAP! ... + +=back + +Each result fetched is a result object of a different type. There are common +methods to each result object and different types may have methods unique to +their type. Sometimes a type method may be overridden in a subclass, but its +use is guaranteed to be identical. + +=head2 Common type methods + +=head3 C + +Returns the type of result, such as C or C. + +=head3 C + +Prints a string representation of the token. This might not be the exact +output, however. Tests will have test numbers added if not present, TODO and +SKIP directives will be capitalized and, in general, things will be cleaned +up. If you need the original text for the token, see the C method. + +=head3 C + +Returns the original line of text which was parsed. + +=head3 C + +Indicates whether or not this is the test plan line. + +=head3 C + +Indicates whether or not this is a test line. + +=head3 C + +Indicates whether or not this is a comment. Comments will generally only +appear in the TAP stream if STDERR is merged to STDOUT. See the +C option. + +=head3 C + +Indicates whether or not this is bailout line. + +=head3 C + +Indicates whether or not the current item is a YAML block. + +=head3 C + +Indicates whether or not the current line could be parsed. + +=head3 C + + if ( $result->is_ok ) { ... } + +Reports whether or not a given result has passed. Anything which is B a +test result returns true. This is merely provided as a convenient shortcut +which allows you to do this: + + my $parser = TAP::Parser->new( { source => $source } ); + while ( my $result = $parser->next ) { + # only print failing results + print $result->as_string unless $result->is_ok; + } + +=head2 C methods + + if ( $result->is_plan ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_plan ) { + print $result->plan; + } + +This is merely a synonym for C. + +=head3 C + + my $directive = $result->directive; + +If a SKIP directive is included with the plan, this method will return it. + + 1..0 # SKIP: why bother? + +=head3 C + + my $explanation = $result->explanation; + +If a SKIP directive was included with the plan, this method will return the +explanation, if any. + +=head2 C methods + + if ( $result->is_pragma ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + +Returns a list of pragmas each of which is a + or - followed by the +pragma name. + +=head2 C methods + + if ( $result->is_comment ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_comment ) { + my $comment = $result->comment; + print "I have something to say: $comment"; + } + +=head2 C methods + + if ( $result->is_bailout ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_bailout ) { + my $explanation = $result->explanation; + print "We bailed out because ($explanation)"; + } + +If, and only if, a token is a bailout token, you can get an "explanation" via +this method. The explanation is the text after the mystical "Bail out!" words +which appear in the tap output. + +=head2 C methods + + if ( $result->is_unknown ) { ... } + +There are no unique methods for unknown results. + +=head2 C methods + + if ( $result->is_test ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + my $ok = $result->ok; + +Returns the literal text of the C or C status. + +=head3 C + + my $test_number = $result->number; + +Returns the number of the test, even if the original TAP output did not supply +that number. + +=head3 C + + my $description = $result->description; + +Returns the description of the test, if any. This is the portion after the +test number but before the directive. + +=head3 C + + my $directive = $result->directive; + +Returns either C or C if either directive was present for a test +line. + +=head3 C + + my $explanation = $result->explanation; + +If a test had either a C or C directive, this method will return +the accompanying explanation, if present. + + not ok 17 - 'Pigs can fly' # TODO not enough acid + +For the above line, the explanation is I. + +=head3 C + + if ( $result->is_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed. Remember +that for TODO tests, the test always passes. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +=head3 C + + if ( $result->is_actual_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed, regardless +of its TODO status. + +B this was formerly C. The latter method is deprecated +and will issue a warning. + +=head3 C + + if ( $test->is_unplanned ) { ... } + +If a test number is greater than the number of planned tests, this method will +return true. Unplanned tests will I return false for C, +regardless of whether or not the test C (see +L for more information about this). + +=head3 C + + if ( $result->has_skip ) { ... } + +Returns a boolean value indicating whether or not this test had a SKIP +directive. + +=head3 C + + if ( $result->has_todo ) { ... } + +Returns a boolean value indicating whether or not this test had a TODO +directive. + +Note that TODO tests I pass. If you need to know whether or not +they really passed, check the C method. + +=head3 C + + if ( $parser->in_todo ) { ... } + +True while the most recent result was a TODO. Becomes true before the +TODO result is returned and stays true until just before the next non- +TODO test is returned. + +=head1 TOTAL RESULTS + +After parsing the TAP, there are many methods available to let you dig through +the results and determine what is meaningful to you. + +=head2 Individual Results + +These results refer to individual tests which are run. + +=head3 C + + my @passed = $parser->passed; # the test numbers which passed + my $passed = $parser->passed; # the number of tests which passed + +This method lets you know which (or how many) tests passed. If a test failed +but had a TODO directive, it will be counted as a passed test. + +=cut + +sub passed { + return @{ $_[0]->{passed} } + if ref $_[0]->{passed}; + return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed}; +} + +=head3 C + + my @failed = $parser->failed; # the test numbers which failed + my $failed = $parser->failed; # the number of tests which failed + +This method lets you know which (or how many) tests failed. If a test passed +but had a TODO directive, it will B be counted as a failed test. + +=cut + +sub failed { @{ shift->{failed} } } + +=head3 C + + # the test numbers which actually passed + my @actual_passed = $parser->actual_passed; + + # the number of tests which actually passed + my $actual_passed = $parser->actual_passed; + +This method lets you know which (or how many) tests actually passed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_passed { + return @{ $_[0]->{actual_passed} } + if ref $_[0]->{actual_passed}; + return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed}; +} +*actual_ok = \&actual_passed; + +=head3 C + +This method is a synonym for C. + +=head3 C + + # the test numbers which actually failed + my @actual_failed = $parser->actual_failed; + + # the number of tests which actually failed + my $actual_failed = $parser->actual_failed; + +This method lets you know which (or how many) tests actually failed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_failed { @{ shift->{actual_failed} } } + +############################################################################## + +=head3 C + + my @todo = $parser->todo; # the test numbers with todo directives + my $todo = $parser->todo; # the number of tests with todo directives + +This method lets you know which (or how many) tests had TODO directives. + +=cut + +sub todo { @{ shift->{todo} } } + +=head3 C + + # the test numbers which unexpectedly succeeded + my @todo_passed = $parser->todo_passed; + + # the number of tests which unexpectedly succeeded + my $todo_passed = $parser->todo_passed; + +This method lets you know which (or how many) tests actually passed but were +declared as "TODO" tests. + +=cut + +sub todo_passed { @{ shift->{todo_passed} } } + +############################################################################## + +=head3 C + + # deprecated in favor of 'todo_passed'. This method was horribly misnamed. + +This was a badly misnamed method. It indicates which TODO tests unexpectedly +succeeded. Will now issue a warning and call C. + +=cut + +sub todo_failed { + warn + '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; + goto &todo_passed; +} + +=head3 C + + my @skipped = $parser->skipped; # the test numbers with SKIP directives + my $skipped = $parser->skipped; # the number of tests with SKIP directives + +This method lets you know which (or how many) tests had SKIP directives. + +=cut + +sub skipped { @{ shift->{skipped} } } + +=head2 Pragmas + +=head3 C + +Get or set a pragma. To get the state of a pragma: + + if ( $p->pragma('strict') ) { + # be strict + } + +To set the state of a pragma: + + $p->pragma('strict', 1); # enable strict mode + +=cut + +sub pragma { + my ( $self, $pragma ) = splice @_, 0, 2; + + return $self->{pragma}->{$pragma} unless @_; + + if ( my $state = shift ) { + $self->{pragma}->{$pragma} = 1; + } + else { + delete $self->{pragma}->{$pragma}; + } + + return; +} + +=head3 C + +Get a list of all the currently enabled pragmas: + + my @pragmas_enabled = $p->pragmas; + +=cut + +sub pragmas { sort keys %{ shift->{pragma} || {} } } + +=head2 Summary Results + +These results are "meta" information about the total results of an individual +test program. + +=head3 C + + my $plan = $parser->plan; + +Returns the test plan, if found. + +=head3 C + +Deprecated. Use C instead. + +=cut + +sub good_plan { + warn 'good_plan() is deprecated. Please use "is_good_plan()"'; + goto &is_good_plan; +} + +############################################################################## + +=head3 C + + if ( $parser->is_good_plan ) { ... } + +Returns a boolean value indicating whether or not the number of tests planned +matches the number of tests run. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +And since we're on that subject ... + +=head3 C + + print $parser->tests_planned; + +Returns the number of tests planned, according to the plan. For example, a +plan of '1..17' will mean that 17 tests were planned. + +=head3 C + + print $parser->tests_run; + +Returns the number of tests which actually were run. Hopefully this will +match the number of C<< $parser->tests_planned >>. + +=head3 C + +Returns a true value (actually the reason for skipping) if all tests +were skipped. + +=head3 C + +Returns the wall-clock time when the Parser was created. + +=head3 C + +Returns the wall-clock time when the end of TAP input was seen. + +=head3 C + +Returns the CPU times (like L when the Parser was created. + +=head3 C + +Returns the CPU times (like L when the end of TAP +input was seen. + +=head3 C + + if ( $parser->has_problems ) { + ... + } + +This is a 'catch-all' method which returns true if any tests have currently +failed, any TODO tests unexpectedly succeeded, or any parse errors occurred. + +=cut + +sub has_problems { + my $self = shift; + return + $self->failed + || $self->parse_errors + || ( !$self->ignore_exit && ( $self->wait || $self->exit ) ); +} + +=head3 C + + $parser->version; + +Once the parser is done, this will return the version number for the +parsed TAP. Version numbers were introduced with TAP version 13 so if no +version number is found version 12 is assumed. + +=head3 C + + $parser->exit; + +Once the parser is done, this will return the exit status. If the parser ran +an executable, it returns the exit status of the executable. + +=head3 C + + $parser->wait; + +Once the parser is done, this will return the wait status. If the parser ran +an executable, it returns the wait status of the executable. Otherwise, this +merely returns the C status. + +=head2 C + + $parser->ignore_exit(1); + +Tell the parser to ignore the exit status from the test when determining +whether the test passed. Normally tests with non-zero exit status are +considered to have failed even if all individual tests passed. In cases +where it is not possible to control the exit value of the test script +use this option to ignore it. + +=cut + +sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) } + +=head3 C + + my @errors = $parser->parse_errors; # the parser errors + my $errors = $parser->parse_errors; # the number of parser_errors + +Fortunately, all TAP output is perfect. In the event that it is not, this +method will return parser errors. Note that a junk line which the parser does +not recognize is C an error. This allows this parser to handle future +versions of TAP. The following are all TAP errors reported by the parser: + +=over 4 + +=item * Misplaced plan + +The plan (for example, '1..5'), must only come at the beginning or end of the +TAP output. + +=item * No plan + +Gotta have a plan! + +=item * More than one plan + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 3 read the rest of the file + 1..3 + +Right. Very funny. Don't do that. + +=item * Test numbers out of sequence + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 2 read the rest of the file + +That last test line above should have the number '3' instead of '2'. + +Note that it's perfectly acceptable for some lines to have test numbers and +others to not have them. However, when a test number is found, it must be in +sequence. The following is also an error: + + 1..3 + ok 1 - input file opened + not ok - first line of the input valid # todo some data + ok 2 read the rest of the file + +But this is not: + + 1..3 + ok - input file opened + not ok - first line of the input valid # todo some data + ok 3 read the rest of the file + +=back + +=cut + +sub parse_errors { @{ shift->{parse_errors} } } + +sub _add_error { + my ( $self, $error ) = @_; + push @{ $self->{parse_errors} } => $error; + return $self; +} + +sub _make_state_table { + my $self = shift; + my %states; + my %planned_todo = (); + + # These transitions are defaults for all states + my %state_globals = ( + comment => {}, + bailout => {}, + yaml => {}, + version => { + act => sub { + $self->_add_error( + 'If TAP version is present it must be the first line of output' + ); + }, + }, + unknown => { + act => sub { + my $unk = shift; + if ( $self->pragma('strict') ) { + $self->_add_error( + 'Unknown TAP token: "' . $unk->raw . '"' ); + } + }, + }, + pragma => { + act => sub { + my ($pragma) = @_; + for my $pr ( $pragma->pragmas ) { + if ( $pr =~ /^ ([-+])(\w+) $/x ) { + $self->pragma( $2, $1 eq '+' ); + } + } + }, + }, + ); + + # Provides default elements for transitions + my %state_defaults = ( + plan => { + act => sub { + my ($plan) = @_; + $self->tests_planned( $plan->tests_planned ); + $self->plan( $plan->plan ); + if ( $plan->has_skip ) { + $self->skip_all( $plan->explanation + || '(no reason given)' ); + } + + $planned_todo{$_}++ for @{ $plan->todo_list }; + }, + }, + test => { + act => sub { + my ($test) = @_; + + my ( $number, $tests_run ) + = ( $test->number, ++$self->{tests_run} ); + + # Fake TODO state + if ( defined $number && delete $planned_todo{$number} ) { + $test->set_directive('TODO'); + } + + my $has_todo = $test->has_todo; + + $self->in_todo($has_todo); + if ( defined( my $tests_planned = $self->tests_planned ) ) { + if ( $tests_run > $tests_planned ) { + $test->is_unplanned(1); + } + } + + if ( defined $number ) { + if ( $number != $tests_run ) { + my $count = $tests_run; + $self->_add_error( "Tests out of sequence. Found " + . "($number) but expected ($count)" ); + } + } + else { + $test->_number( $number = $tests_run ); + } + + push @{ $self->{todo} } => $number if $has_todo; + push @{ $self->{todo_passed} } => $number + if $test->todo_passed; + push @{ $self->{skipped} } => $number + if $test->has_skip; + + push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } => + $number; + push @{ + $self->{ + $test->is_actual_ok + ? 'actual_passed' + : 'actual_failed' + } + } => $number; + }, + }, + yaml => { act => sub { }, }, + ); + + # Each state contains a hash the keys of which match a token type. For + # each token + # type there may be: + # act A coderef to run + # goto The new state to move to. Stay in this state if + # missing + # continue Goto the new state and run the new state for the + # current token + %states = ( + INIT => { + version => { + act => sub { + my ($version) = @_; + my $ver_num = $version->version; + if ( $ver_num <= $DEFAULT_TAP_VERSION ) { + my $ver_min = $DEFAULT_TAP_VERSION + 1; + $self->_add_error( + "Explicit TAP version must be at least " + . "$ver_min. Got version $ver_num" ); + $ver_num = $DEFAULT_TAP_VERSION; + } + if ( $ver_num > $MAX_TAP_VERSION ) { + $self->_add_error( + "TAP specified version $ver_num but " + . "we don't know about versions later " + . "than $MAX_TAP_VERSION" ); + $ver_num = $MAX_TAP_VERSION; + } + $self->version($ver_num); + $self->_grammar->set_version($ver_num); + }, + goto => 'PLAN' + }, + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLAN => { + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLANNED => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { + act => sub { + my ($version) = @_; + $self->_add_error( + 'More than one plan found in TAP output'); + }, + }, + }, + PLANNED_AFTER_TEST => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { act => sub { }, continue => 'PLANNED' }, + yaml => { goto => 'PLANNED' }, + }, + GOT_PLAN => { + test => { + act => sub { + my ($plan) = @_; + my $line = $self->plan; + $self->_add_error( + "Plan ($line) must be at the beginning " + . "or end of the TAP output" ); + $self->is_good_plan(0); + }, + continue => 'PLANNED' + }, + plan => { continue => 'PLANNED' }, + }, + UNPLANNED => { + test => { goto => 'UNPLANNED_AFTER_TEST' }, + plan => { goto => 'GOT_PLAN' }, + }, + UNPLANNED_AFTER_TEST => { + test => { act => sub { }, continue => 'UNPLANNED' }, + plan => { act => sub { }, continue => 'UNPLANNED' }, + yaml => { goto => 'UNPLANNED' }, + }, + ); + + # Apply globals and defaults to state table + for my $name ( keys %states ) { + + # Merge with globals + my $st = { %state_globals, %{ $states{$name} } }; + + # Add defaults + for my $next ( keys %$st ) { + if ( my $default = $state_defaults{$next} ) { + for my $def ( keys %$default ) { + $st->{$next}->{$def} ||= $default->{$def}; + } + } + } + + # Stuff back in table + $states{$name} = $st; + } + + return \%states; +} + +=head3 C + +Get an a list of file handles which can be passed to C