diff --git a/.gitignore b/.gitignore index 4b09365..d90ed78 100644 --- a/.gitignore +++ b/.gitignore @@ -3,6 +3,8 @@ dist/ release/ .engine-build/ engines/java/target/ +engines/dotnet/bin/ +engines/dotnet/obj/ coverage/ playwright-report/ test-results/ diff --git a/.prettierignore b/.prettierignore index 47624d7..018b33f 100644 --- a/.prettierignore +++ b/.prettierignore @@ -1,3 +1 @@ -public/engines/pcre2/pcre2.mjs -public/engines/java/ -public/engines/python/ +public/engines/ diff --git a/CHANGELOG.md b/CHANGELOG.md index 2fcf65d..fefb158 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,69 @@ ## Unreleased +## 0.4.0 — 2026-07-27 + +- Expand the workbench from four to twelve selectable execution profiles: + JavaScript/ECMAScript, standalone PCRE2, PHP, Perl, Python, Ruby, Java, C++, + Go, Rust, .NET and Scala/JVM compatibility. +- Add actual PHP 8.5.8 `preg_*` execution through the self-hosted + `@php-wasm/web-8-5` 3.1.46 runtime. Preserve native UTF-8 byte ranges and + identify PHP's embedded PCRE2 as 10.44, independently of the standalone + PCRE2 10.47 pack. +- Add actual Perl 5.28.1 execution through unmodified WebPerl 0.09-beta assets + as an explicitly legacy beta profile. Pass user values through a fixed + data-only JSON request, stream pre-tokenized bounded replacement output into + a separately verified MEMFS binary file, disable runtime regex evaluation, + reject code assertions and retain the upstream loader's dormant + interoperability `eval` site as a documented CSP caveat. +- Add actual CRuby 4.0.0 `Regexp` execution through a minimal ruby.wasm + 2.9.3-2.9.4 pack. Native `String#gsub`/`String#sub` block iteration drives a + fixed byte-bounded CRuby-compatible replacement expander. Use separate + worker-local WASI request/output files and metadata-only inert JSON instead + of output escaping or ruby.wasm's JavaScript-eval object conversion; reject + lossy lone-surrogate requests and pass the strict-CSP browser gate. +- Add Emscripten 6.0.4 libc++ `std::wregex` execution with the modified + ECMAScript default grammar, alternate standard grammars and a build + configured with dynamic execution disabled. Stream a fixed bounded + replacement formatter through the byte cap and verify its grammar against + libc++ at load. +- Add Go 1.26.5 standard-library `regexp` and Rust `regex` crate 1.13.1 + execution, preserving their native UTF-8 byte ranges and non-backtracking + semantics. Use bounded streaming replacement expanders that are + differentially checked against `Regexp.ExpandString` and + `Captures::expand`, with predictable base64 output transport. Measure exact + encoded request bytes and reserve native JSON limits for worst-case escaping + so control-heavy inputs retain the documented decoded limits. +- Add .NET 10.0.10 `System.Text.RegularExpressions` in browser WebAssembly, + with invariant-culture execution, native UTF-16 ranges and a bounded native + regex timeout inside the killable worker. Stream bounded replacement tokens + without materializing `Match.Result`, verify token semantics against native + .NET at load, and transport output as bounded base64-encoded UTF-8. +- Add an explicitly labelled Scala/JVM compatibility profile backed by the + verified TeaVM 0.15.0 `java.util.regex` engine. No Scala runtime, Scala + wrapper API or OpenJDK runtime is claimed. +- Add partial application-owned lexical syntax and replacement providers, + flavour-specific quick-reference content and capability labels for the eight + new profiles while keeping each real runtime authoritative. +- Add deterministic, closed-file-set runtime packs, checksums, licences, + notices, exact toolchain/source identities and release verification for the + new self-hosted engines. +- Close the existing Pyodide pack's full base-runtime provenance: exact + primary archive or Git tree identities, vendored JavaScript-port hashes, + CPython/Emscripten patch and recipe hashes, a preferred-form HACL* route, + independently anchored notices, and executable identity checks for the + linked compression/database/parser components. +- Transport bounded Python replacement output as canonical base64 with strict + declared-length, request-cap and UTF-8 validation instead of + content-dependent JSON escaping. +- Close the PHP pack's complete native/source/legal inventory with exact + package, binary, build-recipe, archive and Git identities; independently + pin 38 legal assets; audit linked component versions; and explicitly exclude + the GMP, libsodium, tidy, ICU/intl, FreeType, ImageMagick and adjacent AOM + false-positive or unshipped detections. +- Bound retained heavyweight workers with least-recently-used eviction so + selecting many profiles does not leave every runtime resident. + ## 0.3.0 — 2026-07-27 - Add a self-hosted Pyodide 314.0.3 worker containing CPython 3.14.2 `re`, with diff --git a/README.md b/README.md index f455f37..acb2b36 100644 --- a/README.md +++ b/README.md @@ -8,18 +8,37 @@ Patterns, replacement templates, test text and project files stay in the browser. There is no account, backend, upload, remote execution, telemetry, runtime CDN, remote font, or cloud-save service. -## Current release — 0.3.0 +## Current release — 0.4.0 -The v0.3.0 release contains four executable engine slices: +The v0.4.0 release contains twelve selectable, executable profiles: -- the current browser's native ECMAScript `RegExp`; -- official PCRE2 10.47 as a self-hosted 8-bit WebAssembly pack; -- CPython 3.14.2 `re` in the self-hosted Pyodide 314.0.3 runtime; and -- TeaVM 0.15.0's `java.util.regex` class-library implementation as a - self-hosted ES2015 module. +- **JavaScript (ECMAScript)** — the current browser's native `RegExp`, with + ECMAScript 2025 syntax supplied by regexpp 4.12.2; +- **PCRE2** — official standalone PCRE2 10.47 as a self-hosted 8-bit + WebAssembly pack; +- **PHP** — actual PHP 8.5.8 `preg_*` in `@php-wasm/web-8-5` 3.1.46; this + runtime reports PCRE2 10.44 and is deliberately distinct from the standalone + PCRE2 10.47 profile; +- **Perl** — actual Perl 5.28.1 in WebPerl 0.09-beta, prominently identified as + a legacy beta compatibility target rather than current desktop Perl; +- **Python** — CPython 3.14.2 `re` in self-hosted Pyodide 314.0.3; +- **Ruby** — CRuby 4.0.0 `Regexp` in the minimal ruby.wasm + 2.9.3-2.9.4 runtime; +- **Java** — TeaVM 0.15.0's `java.util.regex` class-library implementation; +- **C++** — Emscripten 6.0.4 libc++ `std::wregex`, using the C++ modified + ECMAScript grammar by default and exposing the standard alternate grammar + choices; +- **Go** — Go 1.26.5 standard-library `regexp` with RE2 syntax; +- **Rust** — the Rust `regex` crate 1.13.1, built with rustc 1.97.1; +- **.NET** — .NET 10.0.10 `System.Text.RegularExpressions` in browser + WebAssembly with invariant-culture execution; and +- **Scala compatibility** — Scala/JVM regex syntax and replacement semantics + through the same TeaVM `java.util.regex` engine as the Java profile. No Scala + runtime or Scala `Regex` wrapper API is shipped. -The Java flavour is TeaVM class-library code compiled to JavaScript. It is not -OpenJDK and is not advertised as an OpenJDK compatibility oracle. +Every profile executes the named runtime. Java is TeaVM class-library code, +not OpenJDK. Scala is an explicitly labelled Java-compatibility profile, not a +relabeled Scala engine. - Syntax acceptance: `@eslint-community/regexpp` 4.12.2, ECMAScript 2025 grammar; application-owned structural explanations are partial and @@ -33,22 +52,55 @@ OpenJDK and is not advertised as an OpenJDK compatibility oracle. - PCRE2 automatic callouts are copied through a separate ABI operation and displayed from a dedicated killable trace worker under 50,000-event and 10 MiB serialized-data hard caps. +- PHP compilation and match selection use actual `preg_match()` in PHP 8.5.8. + A fixed byte-bounded expander reproduces PHP replacement tokens and is + checked against native `preg_replace()` at load. PHP returns native UTF-8 + byte ranges and reports its own PCRE2 10.44 identity. +- The legacy Perl bridge passes user values as JSON data to fixed application + code, disables runtime regex evaluation, rejects code assertions and exposes + a pre-tokenized, deliberately bounded replacement grammar. Replacement bytes + stream from native spans to a separate fixed MEMFS file instead of being + materialized or JSON-escaped; the worker validates the exact bounded UTF-8 + file before returning it. Its prebuilt WebPerl loader has a dormant optional + interoperability `eval` site; the fixed engine path is verified without broad + CSP `'unsafe-eval'`. - Python compilation, matching and replacement use the bundled CPython `re` module. Native code-point ranges are retained and normalized to exact editor - UTF-16 ranges. + UTF-16 ranges. Bounded replacement UTF-8 crosses the JSON bridge as canonical + base64; the adapter validates the declared byte count, cap and UTF-8 before + exposing output. +- Ruby compilation and matching use CRuby's `Regexp`; native `String#gsub` + and `String#sub` block iteration drives replacement matching, while a fixed + byte-bounded implementation of CRuby 4.0.0's `rb_reg_regsub` template + grammar produces the output prefix. Native character ranges are retained as + Unicode code-point offsets. Requests and replacement output use separate + bounded files in the worker-local WASI memory filesystem; only bounded + metadata returns as inert JSON, avoiding both output escaping amplification + and ruby.wasm's JavaScript-eval conversion path. - Java compilation, matching and replacement use TeaVM's `java.util.regex.Pattern` and `Matcher`. Native ranges are UTF-16 code units. - TeaVM 0.15.0 replacement supports its actual single-digit `$n` subset. `$12` is therefore `$1` followed by literal `2`; Java SE `${name}` replacement is reported as unavailable rather than presented as OpenJDK behavior. -- Python and Java use deliberately partial application-owned lexical syntax - providers; their actual runtime compiler remains authoritative. +- C++ compilation and matching use libc++ `std::wregex`; a fixed byte-bounded + formatter reproduces `match.format` grammar and checks parity with that + native API at load. Its 32-bit `wchar_t` ranges are Unicode code points. +- Go and Rust return native UTF-8 byte offsets from their real runtimes. Their + fixed bounded expanders are parity-checked against `Regexp.ExpandString` and + `Captures::expand`, then return output through predictable base64 envelopes. + Their adapters measure exact encoded request bytes, and their native JSON + caps cover worst-case escaping for every accepted input field. +- .NET returns native UTF-16 offsets and executes with a bounded native regex + timeout in addition to the killable worker boundary. +- Python, Java and all eight v0.4.0 community additions use deliberately + partial application-owned lexical syntax providers; their actual runtime + compiler remains authoritative. - Parsing and execution run in separate workers. - Actual execution can be terminated by killing its worker. - The worker is recreated after timeout, crash or cancellation. -- ECMAScript capture ranges use the engine's `d` indices result; the other - flavours return their native range records through bounded bridges. +- ECMAScript capture ranges use the engine's `d` indices result; every other + profile returns its native range records through a bounded fixed bridge. - Named, numbered, optional, empty and repeated-final captures are represented. - Match, replacement, typed list/extraction, corpus/apply and unit-test modes are available. @@ -92,8 +144,10 @@ as a complete record of every internal engine action. ## Workbench modes - **Match** — live highlighting, extraction tree and bounded capture table. -- **Replace** — engine-native bounded substitution for all four executable - flavours; +- **Replace** — bounded profile-authoritative substitution for all twelve + executable profiles; the legacy Perl profile uses its documented fixed + non-executable template grammar, and profiles that use fixed bounded + expanders identify and parity-check them against their named runtime; output completeness is reported separately from bounded per-match original/result, changed-range and token-contribution previews that synchronize the replacement, pattern, subject and output editors. @@ -138,15 +192,16 @@ unit test and explicit confirmation; see ## Flags and iteration Pattern and flags are stored separately; delimiters are presentation only. -ECMAScript preserves native `g` and `y`; PCRE2 offers the application-level -`g` iteration flag plus `i`, `m`, `s`, `x`, `U` and `J`. PCRE2 UTF/UCP mode is -mandatory because browser strings are Unicode and partial-byte ranges cannot be -represented safely in the editor. Python exposes application-level `g` plus -CPython `re` flags `a`, `i`, `m`, `s` and `x`. Java exposes application-level -`g` plus TeaVM `Pattern` flags `i`, `d`, `m`, `s`, `u`, `x` and the documented -`U` compatibility request. The optional **Scan all** action adds only an -internal iteration request and does not change saved flags. ECMAScript may add -internal `d` to obtain exact indices without changing match semantics. +Each profile exposes only its reviewed allowlist, and application-level `g` +means bounded iteration where the underlying API has no compile-time global +flag. PHP delimiters/modifiers, Go and Rust inline options, C++ grammar +selection, .NET options and the legacy Perl character-set modes are mapped by +their own adapters rather than reused across profiles. Standalone PCRE2 always +uses UTF/UCP; PHP controls UTF through its exposed `u` modifier and reports its +own PCRE2 version. The optional **Scan all** action adds only an internal +iteration request and does not change saved flags. ECMAScript may add internal +`d` to obtain exact indices without changing match semantics. The exact flag +matrix is in [`docs/FLAVOUR_SUPPORT.md`](docs/FLAVOUR_SUPPORT.md). Zero-length global iteration advances using the selected Unicode semantics and cannot loop forever. @@ -273,6 +328,20 @@ node scripts/python-engine-pack.mjs node_modules/pyodide .engine-build/python node scripts/install-python-engine.mjs .engine-build/python node scripts/java-engine-pack.mjs node scripts/install-java-engine.mjs +node scripts/php-engine-pack.mjs +node scripts/install-php-engine.mjs +node scripts/perl-engine-pack.mjs --archive /path/to/webperl_prebuilt_v0.09-beta.zip +node scripts/install-perl-engine.mjs +node scripts/ruby-engine-pack.mjs +node scripts/install-ruby-engine.mjs +node scripts/cpp-engine-pack.mjs --empp /path/to/em++ +node scripts/install-cpp-engine.mjs +node scripts/build-go-engine.mjs /path/to/go +node scripts/install-go-engine.mjs +node scripts/build-rust-engine.mjs /path/to/rust-toolchain +node scripts/install-rust-engine.mjs +node scripts/dotnet-engine-pack.mjs --dotnet /path/to/dotnet +node scripts/install-dotnet-engine.mjs npm run build npm run toolbox:check npm run check @@ -292,10 +361,9 @@ The deterministic release ZIP can be consumed by Toolbox Portal using an exact artifact URL, manifest ID, version and SHA-256. Portal builds consume the artifact; they do not build Regex Tools source. -The PCRE2 and Python workers load only self-hosted JavaScript, WebAssembly and -Python-standard-library assets; Java loads its self-hosted ES module. -Deployment must serve `.wasm` as `application/wasm` and allow WebAssembly -compilation in `script-src`; see +All runtime assets are self-hosted below the release path. Deployment must +serve `.wasm` as `application/wasm`, serve module/worker files with a +JavaScript MIME type and allow WebAssembly compilation in `script-src`; see [`docs/PORTAL_REQUIREMENTS.md`](docs/PORTAL_REQUIREMENTS.md). ## Flavour support and boundaries @@ -309,6 +377,27 @@ is bundled with its metadata, checksums and licence. The Python slice executes actual CPython 3.14.2 `re` in Pyodide 314.0.3; it does not translate a Python pattern into ECMAScript. Pyodide startup is a separate worker-load operation and is excluded from the normal execution deadline. +Its checked-in pack contains a machine-verified `SOURCE-MANIFEST.json` with the +complete base-runtime inventory, primary source hashes or immutable Git trees, +the vendored Error Stack Parser and StackFrame source ports, all Pyodide +CPython/Emscripten patches and an independently anchored legal file for every +component. Optional wheels named by Pyodide's package catalogue are not +shipped. + +PHP executes actual PHP 8.5.8 `preg_*`; the embedded PHP runtime reports PCRE2 +10.44. Selecting PHP therefore does not execute the separately built PCRE2 +10.47 pack. Perl executes the unmodified WebPerl 0.09-beta runtime containing +Perl 5.28.1 and is kept visibly legacy because that upstream beta was released +in 2019. + +Ruby, C++, Go, Rust and .NET execute their named WebAssembly runtimes. Their +native range units are preserved and normalized at checked boundaries. The +C++ profile defaults to libc++'s modified ECMAScript grammar; its checked-in +source manifest binds the exact module to the traced Emscripten runtime, musl, +emmalloc, compiler-rt, libc++ and libc++abi inputs and records libunwind as an +audited non-selection. Go and Rust provide non-backtracking engines that +deliberately exclude look-around and backreferences; .NET uses +`System.Text.RegularExpressions` 10.0.10 with invariant culture. The Java slice executes TeaVM 0.15.0's own `java.util.regex` class library. It does not translate a Java pattern into ECMAScript, but it is also not OpenJDK: @@ -317,6 +406,10 @@ in particular, TeaVM 0.15.0 does not implement compatibility request and preserves TeaVM's predefined-class and word-boundary behaviour. +Scala reuses that exact TeaVM engine as a clearly named Scala/JVM compatibility +profile. It does not ship or claim Scala compiler/runtime, `scala.util.matching` +wrapper behavior or OpenJDK parity. + Generated-case version 1 is ECMAScript-only. It traverses the complete application-owned ECMAScript AST under node, depth, attempt, byte, repetition and wall-time caps, then verifies every retained label through the actual @@ -324,8 +417,8 @@ browser `RegExp` adapter. PCRE2 generation remains unavailable until its syntax provider can expose a complete normalized tree. Pattern formatting is likewise ECMAScript-only. It consumes the complete -regexpp token model and does not reinterpret the partial PCRE2, Python or Java -structures. Those flavours remain unavailable until complete grammar-backed +regexpp token model and does not reinterpret any partial lexical structure. +Other profiles remain unavailable until complete grammar-backed implementations pass equivalent idempotence, reparse, engine and test gates. The first advertised generated-code target is the PCRE2 10.47 8-bit C API. @@ -333,8 +426,10 @@ Its deterministic match and replacement fixtures compile and execute against the exact official release. See [`docs/COMPARISON_AND_CODEGEN.md`](docs/COMPARISON_AND_CODEGEN.md). -Go, Rust, .NET and legacy PCRE follow only through their actual named runtimes. -No flavour is emulated through JavaScript and relabelled. +No profile is emulated through JavaScript and relabelled. The sole shared +runtime is explicit: Scala compatibility intentionally delegates to the +verified TeaVM Java engine and labels that boundary in the selector and result +identity. ## Licensing @@ -343,10 +438,15 @@ Degering. Shipped dependencies retain their own compatible licences and notices; see [`THIRD_PARTY_NOTICES.md`](THIRD_PARTY_NOTICES.md) and [`LICENSES/`](LICENSES/). +The PHP 8.5.8 codebase is distributed under the elected PHP License version 4 +(`BSD-3-Clause`) option, while WordPress Playground's `@php-wasm` packages +retain their separate GPL-2.0-or-later notice. Each runtime pack contains the +exact applicable licence and notice material recorded in its metadata. + No regex101 application source, branding, generated explanation prose, reference text or visual design is copied. RegexLib and RGXP.RU fixtures are not redistributed because a suitable fixture licence was not established. No -RegexHub fixture is shipped in v0.3.0. +RegexHub fixture is shipped in v0.4.0. ## Known limitations @@ -370,14 +470,20 @@ RegexHub fixture is shipped in v0.3.0. recognizes common capture forms and PCRE2-only constructs for reference, but the actual PCRE2 compiler is authoritative. Branch-reset capture numbering is omitted from the explanation rather than guessed. -- Python and Java structural explanations are deliberately partial lexical - models. CPython `re` and TeaVM `Pattern` respectively remain authoritative - for compilation, group count and matching. -- Python reports native Unicode code-point offsets and converts them at valid - boundaries to editor UTF-16 ranges. Java and ECMAScript report native UTF-16 - offsets; PCRE2 reports native UTF-8 bytes. Native units remain visible. +- Python, Java, PHP, Perl, Ruby, C++, Go, Rust, .NET and Scala compatibility + structural explanations are deliberately partial lexical models. The + selected runtime remains authoritative for compilation, group count and + matching. +- Python, Ruby, C++ and Perl report Unicode code-point offsets; Java, Scala, + .NET and ECMAScript report UTF-16 offsets; standalone PCRE2, PHP, Go and Rust + report UTF-8 bytes. Every range is checked before conversion and its native + unit remains visible. - TeaVM `java.util.regex` is not OpenJDK. Its `U` compatibility request does - not add OpenJDK's `UNICODE_CHARACTER_CLASS` semantics. + not add OpenJDK's `UNICODE_CHARACTER_CLASS` semantics; the same boundary + applies to the Scala compatibility profile. +- WebPerl 0.09-beta and Perl 5.28.1 are intentionally legacy. The shipped + upstream loader contains a dormant optional JavaScript-interoperability + `eval` site, although the fixed bridge does not import or invoke it. - Capture-table rendering is paged at 200 rows while aggregate collection is bounded separately. - Explanation/extraction trees and editor decorations show bounded 2,000-node @@ -387,10 +493,11 @@ RegexHub fixture is shipped in v0.3.0. at most 512. UI-only shortening shows the exact range length; engine-clipped values are labelled as prefixes of that range. Copy and eligible JSON export continue to use the separately bounded engine value. -- Replacement parsing is complete below its 64 Ki input limit, while editor - marks, token rows and diagnostics have explicit presentation caps. List token - chips are similarly bounded, and list rendering stops at 250,000 token - evaluations. +- Replacement parsing is complete only for the providers that advertise that + coverage; the v0.4.0 community providers label their lexical replacement + models as partial and defer semantics to the runtime. Editor marks, token + rows and diagnostics have explicit presentation caps. List token chips are + similarly bounded, and list rendering stops at 250,000 token evaluations. - Per-match replacement presentation renders at most 200 matches and 2,000 token contributions under a 50,000 token-evaluation budget. Bounded replacement output remains available separately and is labelled partial if @@ -413,8 +520,8 @@ RegexHub fixture is shipped in v0.3.0. source/candidate and unit-test validation is evidence for the checked snapshots, not a proof of equivalence over all subjects. - Cross-flavour comparison, PCRE2 C generation and subject minimization remain - scoped to their explicitly supported ECMAScript/PCRE2 paths; selecting - Python or Java does not silently substitute one of those engines. + scoped to their explicitly supported ECMAScript/PCRE2 paths; selecting any + other profile does not silently substitute one of those engines. Architecture, security, performance, provenance and flavour details live in [`docs/`](docs/). diff --git a/SOURCE.md b/SOURCE.md index eb7f3da..0899ba4 100644 --- a/SOURCE.md +++ b/SOURCE.md @@ -1,10 +1,10 @@ # Source identity - Project: Regex Tools -- Release version: `0.3.0` -- Release tag: `v0.3.0` +- Release version: `0.4.0` +- Release tag: `v0.4.0` - Repository: -- Previous release tag: `v0.2.0` +- Previous release tag: `v0.3.0` - Licence: GPL-3.0-or-later - Copyright: © 2026 Albrecht Degering @@ -28,18 +28,67 @@ The engine-pack inputs and rebuild gates are documented in - The Python pack is copied from the exact pinned Pyodide 314.0.3 npm package and contains its CPython 3.14.2 runtime, Python standard library, loader, WebAssembly module, metadata, checksums and licence material. + `SOURCE-MANIFEST.json` closes the base-runtime inventory with exact archive + hashes or Git commit/tree identities for Pyodide, pyodide-build, the + vendored Error Stack Parser and StackFrame ports, CPython, libffi, Hiwire, + liblzma, Zstandard, SQLite, bzip2, zlib, Emscripten and HACL*. It also pins + every Pyodide CPython/Emscripten patch and build recipe, documents the one + Regex Tools loader transformation, and maps each linked component to + independently anchored legal text. - The Java bridge source is under `engines/java/`. Its bundled module is compiled against TeaVM 0.15.0's `java.util.regex` class library and is identified as TeaVM rather than OpenJDK. +- The PHP bridge source is under `engines/php/`. The runtime pack comes from + the pinned `@php-wasm/web-8-5` and support packages at 3.1.46, executes PHP + 8.5.8, and reports its embedded PCRE2 as 10.44. This identity is separate + from the standalone PCRE2 10.47 pack. Its `native-components.json` binds the + exact WebAssembly to the WordPress Playground/PHP/Emscripten commits, + inventories all 32 linked native/source surfaces, records exact archive or + Git routes and explicitly bounds the upstream recipe's one unpinned + Oniguruma clone. Every linked component maps to independently pinned legal + text; runtime and binary audits distinguish GMP, libsodium, tidy, ICU/intl, + FreeType, ImageMagick and the adjacent AOM 3.13.1 recipe from what is + actually linked. +- The Perl bridge source is under `engines/perl/`. The byte-for-byte WebPerl + 0.09-beta prebuilt archive contains Perl 5.28.1 and Emscripten 1.38.28 + output. It is shipped only as a visibly legacy beta target; user values cross + a fixed data-only bridge. +- The Ruby pack comes from the pinned minimal `@ruby/4.0-wasm-wasi` and + `@ruby/wasm-wasi` packages at 2.9.3-2.9.4 and executes CRuby 4.0.0. The + application bridge under `engines/ruby/` uses bounded length-prefixed + worker-local WASI file input and inert JSON output instead of ruby.wasm's + JavaScript-eval object-conversion path. +- The C++ bridge source is under `engines/cpp/`. Emscripten 6.0.4 compiles it + against libc++ `std::wregex` with dynamic JavaScript execution disabled. Its + `SOURCE-MANIFEST.json` pins the Emscripten, emsdk and LLVM identities and + maps the exact traced musl, emmalloc, compiler-rt, libc++ and libc++abi link + inputs to preferred-source paths and legal files. libunwind is retained as + an explicit audited exclusion because the selected JavaScript-exception + build links no `libunwind.a` member. +- The Go bridge source is under `engines/go/`. The official Go 1.26.5 + linux/amd64 distribution cross-compiles standard-library `regexp` for + `js/wasm`. +- The Rust bridge source and exact Cargo lock are under `engines/rust/`. + rustc 1.97.1 and wasm-bindgen 0.2.126 compile `regex` crate 1.13.1 for + `wasm32-unknown-unknown`. +- The .NET bridge source is under `engines/dotnet/`. .NET SDK 10.0.302 with + runtime 10.0.10 and its `wasm-tools` workload publishes the + `System.Text.RegularExpressions` browser-WASM pack. +- Scala compatibility has no additional engine pack. It deliberately uses the + verified TeaVM Java pack and labels that shared runtime in every result. Generated staging is ignored. Only verified runtime packs with deterministic metadata, closed file sets, checksums and exact licence/notice material are installed under `public/engines/` and included in the application source and build. -The v0.3.0 release includes native browser ECMAScript, PCRE2 10.47, CPython -3.14.2 `re` through Pyodide 314.0.3 and TeaVM 0.15.0 `java.util.regex`. Go, -Rust, .NET and legacy PCRE remain unimplemented. Earlier releases remain -available under their historical tags and artifact coordinates. A future -public artifact must bump package, manifest, tag and source identity together; -it must not reuse `v0.3.0`. +The v0.4.0 release includes native browser ECMAScript, standalone PCRE2 10.47, +PHP 8.5.8 `preg` with PCRE2 10.44, legacy Perl 5.28.1 via WebPerl 0.09-beta, +CPython 3.14.2 `re`, CRuby 4.0.0 `Regexp`, TeaVM 0.15.0 `java.util.regex`, +Emscripten 6.0.4 libc++ `std::wregex`, Go 1.26.5 `regexp`, Rust `regex` 1.13.1, +.NET 10.0.10 `System.Text.RegularExpressions`, and the explicitly shared +TeaVM-backed Scala/JVM compatibility profile. + +Earlier releases remain available under their historical tags and artifact +coordinates. A future public artifact must bump package, manifest, tag and +source identity together; it must not reuse `v0.4.0`. diff --git a/THIRD_PARTY_NOTICES.md b/THIRD_PARTY_NOTICES.md index 90dd7c8..ea22fb1 100644 --- a/THIRD_PARTY_NOTICES.md +++ b/THIRD_PARTY_NOTICES.md @@ -4,32 +4,67 @@ Regex Tools original source is GPL-3.0-or-later. The production browser bundle contains the compatible runtime components below. Exact dependency resolution is recorded in `package-lock.json`. -| Component | Version | Licence | Shipped | Role and source | -| -------------------------------- | ------------------------------------------------------------------------ | --------------------------------- | ---------------------------- | -------------------------------------------------------------------------------------------- | -| `@add-ideas/toolbox-contract` | 0.2.2 | Apache-2.0 | Runtime | Manifest contract; | -| `@add-ideas/toolbox-shell-react` | 0.2.2 | Apache-2.0 | Runtime | Shared shell; same source | -| `@eslint-community/regexpp` | 4.12.2 | MIT | Syntax worker | ECMAScript parser; | -| CodeMirror packages | state 6.7.1; view 6.43.6; language 6.12.4; commands 6.10.4; search 6.7.1 | MIT | Runtime | Editors; | -| `@lezer/highlight` | 1.2.3 | MIT | Runtime | Editor highlighting support; | -| React / React DOM | 19.2.7 | MIT | Runtime | User interface; | -| `fflate` | 0.8.3 | MIT | Runtime and build dependency | Local corpus-output ZIP and deterministic release ZIP; | -| Emscripten generated runtime | 6.0.4 | MIT | Generated WebAssembly glue | PCRE2 module loader/runtime; | -| PCRE2 | 10.47 | BSD-3-Clause WITH PCRE2-exception | WebAssembly runtime | Pinned official 8-bit engine; | -| Pyodide | 314.0.3 | MPL-2.0 | Python runtime pack | Self-hosted CPython browser runtime; | -| CPython | 3.14.2 | PSF-2.0 | Python runtime/stdlib | `re` execution and bundled standard library; | -| TeaVM | 0.15.0 | Apache-2.0 | Generated Java engine module | `java.util.regex` class-library implementation; | -| Vite | 8.1.5 | MIT | Generated helpers | Production build; | -| Rolldown | 1.1.5 | MIT | Generated helpers | Production bundling; | +| Component | Version | Licence | Shipped | Role and source | +| -------------------------------- | -------------------------------------------------------------------------------------------------------------------------------------- | ---------------------------------------------------------------------------------------------- | ---------------------------- | -------------------------------------------------------------------------------------------------------------------------- | +| `@add-ideas/toolbox-contract` | 0.2.2 | Apache-2.0 | Runtime | Manifest contract; | +| `@add-ideas/toolbox-shell-react` | 0.2.2 | Apache-2.0 | Runtime | Shared shell; same source | +| `@eslint-community/regexpp` | 4.12.2 | MIT | Syntax worker | ECMAScript parser; | +| CodeMirror packages | state 6.7.1; view 6.43.6; language 6.12.4; commands 6.10.4; search 6.7.1 | MIT | Runtime | Editors; | +| `@lezer/highlight` | 1.2.3 | MIT | Runtime | Editor highlighting support; | +| React / React DOM | 19.2.7 | MIT | Runtime | User interface; | +| `fflate` | 0.8.3 | MIT | Runtime and build dependency | Local corpus-output ZIP and deterministic release ZIP; | +| Emscripten generated runtime | 6.0.4 | MIT OR NCSA | Generated WebAssembly glue | Standalone PCRE2 and C++ module toolchain; | +| PCRE2 | 10.47 | BSD-3-Clause WITH PCRE2-exception | WebAssembly runtime | Pinned official 8-bit engine; | +| PHP | 8.5.8 | PHP License 4 (BSD-3-Clause) | PHP runtime | `preg_*` execution; v4 elected through the earlier licence's later-version option; | +| PCRE2 in PHP | 10.44 | PCRE2 BSD licence | PHP runtime | Engine embedded in the PHP build; distinct from standalone PCRE2 10.47 | +| WordPress Playground `@php-wasm` | 3.1.46 | GPL-2.0-or-later | PHP runtime/host packages | `web-8-5`, `universal` and pinned support packages; | +| Zend Engine and PHP bundled code | PHP 8.5.8 | Zend Engine License 2.00; MIT; public-domain/CC0 and component terms | PHP WebAssembly | Exact Zend, official `README.REDIST.BINS`, CLI HTTP parser and hash-code notices travel with the pack | +| PHP-vendored support code | bcmath snapshot; timelib 2022.15; tzdata 2026.1; libmagic snapshot; Lexbor 2.7.0; libmbfl 1.3.2; uriparser 1.0.2; libavifinfo snapshot | LGPL-2.0-or-later; MIT; public domain; BSD; Apache-2.0; LGPL-2.1; BSD and AOM patent terms | PHP WebAssembly | Exact php-src 8.5.8 component paths and legal routes are recorded in the native inventory | +| PHP data/archive/image libraries | zlib 1.2.13; libzip 1.9.2; libxml2 2.9.10; SQLite 3.51.0; libgd 2.3.3 | Zlib; BSD-3-Clause; MIT; public domain; BSD-like | PHP WebAssembly | Exact primary archive hashes/commits and separately pinned legal files | +| PHP image codec libraries | libjpeg-turbo 3.0.3; libpng 1.6.39; libwebp/libsharpyuv pinned commit; libavif 1.3.0; libaom 3.12.1 with libyuv snapshot | IJG/BSD/Zlib; Libpng; BSD/patent grants; BSD-2-Clause/AOM patent terms | PHP WebAssembly | libavif's local AOM 3.12.1 is linked; the adjacent standalone AOM 3.13.1 recipe is not | +| PHP network/text libraries | OpenSSL 1.1.1t; curl 7.69.1; libiconv 1.17; Oniguruma 6.9.10 | OpenSSL/SSLeay; curl; LGPL-2.1-or-later; BSD-2-Clause | PHP WebAssembly | Oniguruma's exact archive/header and bounded upstream source interval are recorded without claiming an unpinned build HEAD | +| Emscripten system code in PHP | main linker 4.0.19; musl, compiler-rt, libc++, libc++abi and dlmalloc snapshots | MIT/NCSA; MIT/component terms; Apache-2.0 WITH LLVM-exception plus legacy terms; public domain | PHP WebAssembly | Exact Emscripten commit and independently pinned component legal files | +| WebPerl / Perl | 0.09-beta / 5.28.1 | GPL-1.0-or-later OR Artistic-1.0-Perl | Legacy Perl runtime | Unmodified, explicitly legacy prebuilt engine; | +| Emscripten used by WebPerl | 1.38.28 | MIT OR NCSA | Legacy Perl loader/runtime | Exact upstream-generated asset toolchain | +| Pyodide | 314.0.3 | MPL-2.0 | Python runtime pack | Self-hosted CPython browser runtime; | +| Error Stack Parser / StackFrame | 2.1.4 / 1.3.4 vendored ports | MIT | Python loader | Exact upstream tags/archives and Pyodide port-source hashes are recorded | +| CPython | 3.14.2 | Python-2.0 and bundled terms | Python runtime/stdlib | `re` execution and bundled standard library; | +| Expat / libmpdec / HACL* | 2.7.3 / 2.5.1 / pinned HACL commit | MIT / BSD-2-Clause / MIT | Python base WebAssembly | CPython-vendored static components; exact preferred HACL source and generated-source route are recorded | +| libffi / Hiwire | pinned commit / 1.0.1 | MIT / MPL-2.0 | Python base WebAssembly | Pyodide's exact `_ctypes` and JavaScript-reference bridge inputs | +| XZ liblzma / Zstandard | 5.2.2 / 1.5.7 | Public-domain fallback grant / BSD-3-Clause | Python base WebAssembly | Static compression modules from Pyodide's pinned primary source archives | +| SQLite | 3.39.0 | Public-domain dedication/blessing | Python base WebAssembly | Static `_sqlite3` from the pinned official amalgamation archive | +| bzip2 / zlib | 1.0.6 / 1.3.1 | bzip2-1.0.6 / Zlib | Python base WebAssembly | Exact Emscripten 5.0.3 ports selected by Pyodide | +| Emscripten used by Pyodide | 5.0.3 plus five pinned Pyodide patches | MIT OR NCSA | Python loader/WebAssembly | Exact toolchain source tree, patches and recipe hashes | +| Emscripten system runtime | snapshot in 5.0.3 | MIT and Apache-2.0 WITH LLVM-exception | Python base WebAssembly | musl, compiler-rt, libc++, libc++abi, libunwind and dlmalloc conservative notice closure | +| MiniLZ4 | snapshot in Emscripten 5.0.3 | MIT | Python loader | Selected by Pyodide's `-sLZ4=1`; its source notice is restored outside the minified loader | +| ruby.wasm / CRuby | 2.9.3-2.9.4 / 4.0.0 | MIT host; Ruby/BSD and bundled terms | Ruby runtime | Minimal CRuby WebAssembly pack and complete upstream NOTICE; | +| TeaVM | 0.15.0 | Apache-2.0 | Generated Java engine module | `java.util.regex` class-library implementation; | +| Emscripten system code in C++ | Emscripten 6.0.4; musl 1.2.6; compiler-rt 22.1.8; libc++/libc++abi 21.1.8; emmalloc snapshot | MIT/NCSA; MIT/component terms; Apache-2.0 WITH LLVM-exception plus legacy terms | C++ WebAssembly | Exact traced link and preferred-source/legal closure; libunwind 22.1.8 is retained as an audited non-selection | +| Go | 1.26.5 | BSD-3-Clause | Go runtime/engine | Standard-library `regexp` and official `js/wasm` support; | +| Rust `regex` / toolchain | regex 1.13.1 / rustc 1.97.1 | MIT OR Apache-2.0 plus component terms | Rust runtime/engine | Exact Cargo graph, standard library and wasm-bindgen notices travel with the pack | +| .NET | runtime 10.0.10 / SDK 10.0.302 | MIT plus bundled component terms | .NET runtime/engine | Browser-WASM `System.Text.RegularExpressions`; | +| Vite | 8.1.5 | MIT | Generated helpers | Production build; | +| Rolldown | 1.1.5 | MIT | Generated helpers | Production bundling; | `@add-ideas/toolbox-testkit` 0.2.2 and the other test/build dependencies are development-only and are not part of the static runtime bundle. +The PHP pack's `native-components.json` is scoped to the exact +`php.wasm` SHA-256 and routes every linked component above to one or more of 42 +independently verifier-pinned licence, notice or patent files. It separately +records and tests the false-positive/unshipped detections for GMP, libsodium, +tidy, ICU/intl, FreeType, ImageMagick/imagick and AOM 3.13.1. + `recheck` 4.5.0 and `regexp-ast-analysis` 0.7.1 were inspected but deliberately not installed or shipped. PCRE2 source is not vendored; its generated -WebAssembly pack is shipped with exact metadata, checksums and licence. Pyodide -is pinned as an npm build input and its reviewed self-hosted runtime files are -copied into the Python pack. The TeaVM module contains its compiled class -library and is explicitly identified as TeaVM, not OpenJDK. +WebAssembly pack is shipped with exact metadata, checksums and licence. Pyodide, +PHP WebAssembly and ruby.wasm are pinned npm build inputs whose reviewed +self-hosted files are copied into engine packs. The Python pack's +`SOURCE-MANIFEST.json` distinguishes the optional wheel catalogue from files +actually shipped, inventories the complete linked base runtime and provides +exact preferred-form/archive/Git/patch identities. The TeaVM module contains +its compiled class library and is explicitly identified as TeaVM, not OpenJDK; +the Scala compatibility profile shares it and ships no Scala runtime. Licence texts and copyright notices for the ordinary bundled dependencies are in `LICENSES/`. Each engine pack carries its exact upstream licence/notice diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md index ec1a1f6..68ece90 100644 --- a/docs/ARCHITECTURE.md +++ b/docs/ARCHITECTURE.md @@ -9,13 +9,22 @@ React workbench │ ├─ Regexpp ECMAScript provider → normalized AST │ ├─ PCRE2 lexical provider → partial normalized structure │ ├─ Python lexical provider → partial normalized structure - │ └─ Java lexical provider → partial normalized structure + │ ├─ Java lexical provider → partial normalized structure + │ └─ PHP/Perl/Ruby/C++/Go/Rust/.NET/Scala lexical providers → partial structures ├─ Replacement SyntaxSupervisor → syntax.worker → typed replacement tokens ├─ EngineSupervisor │ ├─ ecmascript.worker → native RegExp → match DTOs │ ├─ pcre2.worker → PCRE2 10.47 WASM ABI → match DTOs + │ ├─ php.worker → PHP 8.5.8 preg / PCRE2 10.44 → match DTOs + │ ├─ perl.worker → legacy WebPerl 0.09-beta / Perl 5.28.1 → match DTOs │ ├─ python.worker → Pyodide 314.0.3 → CPython 3.14.2 re → match DTOs - │ └─ java.worker → TeaVM 0.15.0 java.util.regex module → match DTOs + │ ├─ ruby.worker → ruby.wasm → CRuby 4.0.0 Regexp → match DTOs + │ ├─ java.worker → TeaVM 0.15.0 java.util.regex module → match DTOs + │ ├─ cpp.worker → Emscripten 6.0.4 libc++ std::wregex → match DTOs + │ ├─ go.worker → Go 1.26.5 standard-library regexp → match DTOs + │ ├─ rust.worker → Rust regex crate 1.13.1 → match DTOs + │ ├─ dotnet.worker → .NET 10.0.10 System.Text.RegularExpressions → match DTOs + │ └─ scala.worker → explicit compatibility adapter → TeaVM Java module ├─ Pcre2TraceSupervisor → pcre2-trace.worker │ └─ separate ABI-v3 PCRE2_AUTO_CALLOUT operation → bounded trace DTOs ├─ AnalysisPanel @@ -50,6 +59,9 @@ a new generation. Timeout is a distinct error state. A separate idempotent load operation verifies a worker's runtime identity before execution; its flavour-specific startup deadline is not charged to the 250 ms live or selected manual execution deadline. A killed generation must load and verify again. +The supervisor has a two-worker retention target; before creating another +profile worker it evicts the least recently used idle generation. Active work +is never evicted and may temporarily exceed that target. The Python worker imports only the self-hosted Pyodide loader and pack, then evaluates the application-owned bounded bridge in CPython. The bridge returns @@ -59,6 +71,22 @@ ES2015 module. That module executes TeaVM's own `java.util.regex.Pattern` and `Matcher` class-library implementation and returns native UTF-16 ranges; it is not OpenJDK. +PHP, Perl, Ruby, C++, Go, Rust and .NET each use a fixed bounded bridge to the +named self-hosted runtime. User values cross as structured/JSON data, never as +generated source. Scala intentionally reuses the TeaVM Java module and rewrites +only request/result profile metadata; it contains no Scala runtime. The legacy +Perl topology is unusual: the supervised module worker owns the classic worker +required by WebPerl, so supervisor termination still discards the complete +worker tree. + +Ruby's production bridge avoids ruby.wasm's generic JavaScript object +conversion: the worker writes one bounded length-prefixed request into its +private WASI memory filesystem, calls the fixed bridge with no user arguments, +reads one bounded inert metadata JSON string, and obtains bounded UTF-8 +replacement output from a separate private file. That path avoids JSON output +amplification and passes the same strict-CSP browser gate as the other +profiles. + PCRE2 tracing is not an `EngineSupervisor` match or replacement operation. Its own worker compiles with `PCRE2_AUTO_CALLOUT`, copies only complete fixed records and bounded mark bytes, and stops natively at either trace cap. @@ -86,9 +114,10 @@ deterministic golden identities and an exact PCRE2 10.47 compile/execute gate. Subject minimization is a main-thread bounded reducer whose expensive predicate checks stay in independently terminable ECMAScript or PCRE2 workers. Fixed -pattern syntax is parsed once for capture metadata. Python and Java are blocked -at this feature boundary rather than routed to a different engine. The baseline -and every accepted candidate retain the exact target and engine identity. +pattern syntax is parsed once for capture metadata. Every other profile is +blocked at this feature boundary rather than routed to a different engine. The +baseline and every accepted candidate retain the exact target and engine +identity. Timeout, crash, cancellation, worker failure and incomplete output are separate outcomes. Deterministic ddmin deletion is followed by a fixed-point local sweep over Unicode-scalar deletion and lower-rank canonical replacement; only @@ -139,13 +168,13 @@ separator during apply. This makes anchor and cross-line behavior deliberately different rather than silently rewriting the pattern. Match DTOs are reduced to bounded per-group participation counts and samples before the next document. -Native ranges are retained in the engine's declared unit. ECMAScript and Java -use UTF-16 code units. PCRE2 always uses UTF/UCP and exposes UTF-8 byte ranges; -its ABI copies scalar records and names out of WebAssembly before returning and -retains no code pointer. CPython `re` exposes Unicode code-point indices. -Browser editor ranges are half-open UTF-16 code-unit ranges. Reusable -converters cover UTF-8 byte and Unicode code-point offsets, including -invalid-boundary rejection and lone-surrogate detection. +Native ranges are retained in the engine's declared unit. ECMAScript, Java, +Scala compatibility and .NET use UTF-16 code units. Standalone PCRE2, PHP, Go +and Rust expose UTF-8 byte ranges. CPython, CRuby, libc++ `std::wregex` and +legacy Perl expose Unicode code-point positions. Browser editor ranges are +half-open UTF-16 code-unit ranges. Reusable converters cover UTF-8 byte and +Unicode code-point offsets, including invalid-boundary rejection and +lone-surrogate detection. The release boundary is `dist/` plus checked-in legal/source documents. The Portal consumes the resulting immutable ZIP and never imports React source. diff --git a/docs/COMPARISON_AND_CODEGEN.md b/docs/COMPARISON_AND_CODEGEN.md index 71f0892..86884bc 100644 --- a/docs/COMPARISON_AND_CODEGEN.md +++ b/docs/COMPARISON_AND_CODEGEN.md @@ -7,8 +7,9 @@ ECMAScript worker and one to the bundled PCRE2 10.47 worker. It does not translate patterns, flags, options or replacement templates. This is an explicit two-engine feature, not a generic active-flavour -comparison. Selecting Python or Java for the main workbench does not insert it -into either side or route it through ECMAScript/PCRE2. +comparison. Selecting PHP, Perl, Python, Ruby, Java, C++, Go, Rust, .NET or +Scala compatibility for the main workbench does not insert it into either side +or route it through ECMAScript/PCRE2. Two pattern models are available: @@ -55,11 +56,12 @@ result. The panel renders at most 250 differences and 100 alignments at once. ## PCRE2 C17 generator -The first reviewed code-generation target is the PCRE2 10.47 8-bit C API. -Python, Java and other targets remain unavailable until their generators have -equivalent escaping, semantic and named-runtime/toolchain gates. The executable -Python and Java browser flavours do not by themselves imply a code-generation -target. +The first reviewed code-generation target is the standalone PCRE2 10.47 8-bit +C API. Every other target remains unavailable until its generator has +equivalent escaping, semantic and named-runtime/toolchain gates. In particular, +PHP's embedded PCRE2 10.44 is not routed through the standalone-PCRE2 +generator; an executable browser profile does not by itself imply a +code-generation target. The generator consumes a validated PCRE2 snapshot and: diff --git a/docs/ENGINE_BUILDS.md b/docs/ENGINE_BUILDS.md index a7bf4ad..af853ac 100644 --- a/docs/ENGINE_BUILDS.md +++ b/docs/ENGINE_BUILDS.md @@ -1,9 +1,11 @@ # Engine builds The production application uses the browser's native `RegExp` for ECMAScript -and bundles verified PCRE2, Python and Java runtime packs. Normal application -builds never download or compile an engine: reviewed files under -`public/engines/` are copied into `dist/` and verified there. +and bundles ten verified runtime packs for standalone PCRE2, PHP, Perl, Python, +Ruby, Java, C++, Go, Rust and .NET. The Scala/JVM compatibility profile shares +the Java pack and contains no Scala runtime. Normal application builds never +download or compile an engine: reviewed files under `public/engines/` are +copied into `dist/` and verified there. ## Rebuilding PCRE2 @@ -68,14 +70,36 @@ independently reports `info.python` as 3.14.0, and the verifier records rather than conflates those two upstream identities. The pack copies only the reviewed loader, WebAssembly runtime, Python standard library and lock metadata required for a local CPython `re` worker. It adds deterministic engine metadata, a -closed-file-set checksum manifest and exact Pyodide/CPython licence material. +closed-file-set checksum manifest and a complete `SOURCE-MANIFEST.json`. + +The source manifest records immutable Git commit/tree identities or primary +release-archive SHA-256 values for Pyodide, its `pyodide-build` submodule, its +vendored Error Stack Parser 2.1.4 and StackFrame 1.3.4 ports, CPython, libffi, +Hiwire, XZ/liblzma, Zstandard, SQLite, the Emscripten bzip2 and zlib ports, +Emscripten itself and HACL* preferred source. It hashes both vendored +JavaScript ports, all nine CPython patches, all five Emscripten patches, and +the Pyodide Makefiles that select those inputs. That is the +preferred-form/patch route for the upstream MPL source; the exact npm package +remains the binary-distribution reference, not a claim that arbitrary future +host SDK packaging will reproduce identical bytes. + +The linked-component inventory is derived from the exact Pyodide recipe and +checked against executable identities where the libraries expose one. Besides +Pyodide and CPython, the base module contains CPython-vendored Expat 2.7.3, +libmpdec 2.5.1 and HACL*, plus libffi, Hiwire 1.0.1, liblzma 5.2.2, +Zstandard 1.5.7, SQLite 3.39.0, bzip2 1.0.6 and zlib 1.3.1. The conservative +Emscripten 5.0.3 runtime notice closure covers musl, compiler-rt, libc++, +libc++abi, libunwind, dlmalloc and the MiniLZ4 source selected by the pinned +link flags. The upstream stripped module contains no link map, so retaining the +complete potentially selected Emscripten runtime notice set is intentional. The install operation reads from the already installed pinned npm package. It does not contact a CDN or package index. It verifies source package identity, -file hashes, runtime metadata and licence inputs before atomically replacing +file hashes, runtime metadata, every independently fetched legal-source hash, +the generated source manifest and licence inputs before atomically replacing only `public/engines/python/`. The distribution verifier checks the same closed -set under `dist/`, validates WebAssembly magic and confirms that all runtime -references remain relative and self-hosted. +set under `dist/`, validates WebAssembly and native component identities and +confirms that all runtime references remain relative and self-hosted. ```sh node scripts/python-engine-pack.mjs \ @@ -88,8 +112,13 @@ The installed closed set is: - `pyodide.mjs`, `pyodide.asm.mjs` and `pyodide.asm.wasm`; - `python_stdlib.zip` and `pyodide-lock.json`; -- `engine-metadata.json` and `SHA256SUMS`; and -- `LICENSE.pyodide.txt` and `LICENSE.cpython.txt`. +- `engine-metadata.json`, `SOURCE-MANIFEST.json` and `SHA256SUMS`; and +- 22 exact `LICENSE.*`/`NOTICE.*` files enumerated and source-anchored by that + manifest. + +`pyodide-lock.json` is the upstream catalogue of optional packages. Regex +Tools does not ship the catalogue's wheels; `externalPackagesIncluded: false` +and the closed pack file set make that boundary machine-verifiable. ## Building the Java pack @@ -120,6 +149,179 @@ OpenJDK's `Pattern.UNICODE_CHARACTER_CLASS`; the bridge treats the application `U` flag as a compatibility request, implies Unicode case folding and reports that predefined-character classes and word boundaries retain TeaVM behaviour. +## Building the PHP pack + +The PHP bridge under `engines/php/` executes actual PHP 8.5.8 `preg_*`. +`@php-wasm/web-8-5` and `@php-wasm/universal` 3.1.46 plus their pinned support +packages supply the Asyncify WebAssembly runtime and host API. Direct identity +verification reports PCRE2 10.44; this pack is not the standalone PCRE2 10.47 +build. + +```sh +node scripts/php-engine-pack.mjs +node scripts/install-php-engine.mjs +``` + +The builder copies only the pinned npm runtime files, changes the +bundler-specific WebAssembly import into a same-directory URL, records the +original and transformed hashes, and runs real identity, match, bounded +replacement and native-component positive/negative audits before installation. +`native-components.json` binds the exact WebAssembly hash to WordPress +Playground `v3.1.46` commit +`581c7c172428159eb4e6c5309054a568cd39a97a`, PHP tag `php-8.5.8` commit +`26b97507444c4fbda072f57dda1820f7b7d5e467`, Emscripten 4.0.19 commit +`08e2de1031913e4ba7963b1c56f35f036a7d4d56` and all 32 linked native/source +surfaces. It carries exact archive hashes or Git identities where upstream +recorded them and honestly bounds the one unpinned Oniguruma clone using the +committed archive/header identities and upstream source interval. + +The pack elects PHP License version 4 (`BSD-3-Clause`) for PHP 8.5.8 through +PHP's later-version option and includes the complete PCRE2 and PHP-vendored, +external-library, patent and Emscripten/LLVM/musl legal set. This includes the +exact Zend Engine licence, official php-src binary redistribution notice, CLI +HTTP parser MIT terms, and the public-domain, CC0 and FNV permission notices for +linked hash implementations. The WordPress Playground `@php-wasm` packages +retain GPL-2.0-or-later; JavaScript support-package licences remain separate. +All 42 legal assets and the native inventory are independently SHA-256-pinned +by the builder, then covered again by the closed file set, `SHA256SUMS`, release +requirements and metadata. + +## Building the legacy Perl pack + +The Perl bridge under `engines/perl/` uses the unmodified WebPerl 0.09-beta +prebuilt archive, SHA-256 +`5f441249217e90ab378c666f473d4206ab4f44907f6bb0aa8d70834bc38c40dc`. +That 2019 beta contains Perl 5.28.1 and Emscripten 1.38.28 output. It is +intentionally a legacy compatibility target, not a current Perl distribution. + +The builder accepts only a local copy of that exact official archive; it never +downloads. An already extracted release root can be supplied with `--prebuilt` +instead of `--archive`. + +```sh +node scripts/perl-engine-pack.mjs \ + --archive /absolute/path/webperl_prebuilt_v0.09-beta.zip +node scripts/perl-engine-pack.mjs --verify .engine-build/perl +node scripts/install-perl-engine.mjs .engine-build/perl +``` + +The installed pack retains upstream `emperl.js`, `emperl.wasm` and +`emperl.data` byte-for-byte. Application-owned fixed worker and Perl bridge +files carry values through an exact-key, byte-bounded JSON request path; they do +not splice patterns or replacements into source. The metadata response remains +bounded JSON, while successful replacement UTF-8 bytes stream into a separate +fixed MEMFS binary file and receive exact worker-side byte, size and encoding +validation. Exact WebPerl/Perl, Emscripten and bundled-CPAN notices travel with +the pack. + +The legacy generated loader contains one `eval(code)` site in an optional +Perl-to-JavaScript interoperability import. The application bridge never loads +that facility. Its browser CSP smoke passes with `'wasm-unsafe-eval'` and +without broad `'unsafe-eval'`; that dormant upstream site remains documented +rather than removed from the checksummed asset. + +## Building the Ruby pack + +The Ruby pack copies the minimal runtime from pinned +`@ruby/4.0-wasm-wasi@2.9.3-2.9.4` and uses +`@ruby/wasm-wasi@2.9.3-2.9.4` as its host. It verifies the CRuby 4.0.0 +`wasm32-wasi` identity and actual `Regexp`/replacement behavior before +installation. + +```sh +node scripts/ruby-engine-pack.mjs +node scripts/install-ruby-engine.mjs +``` + +The closed set contains the runtime WebAssembly file, deterministic metadata +and checksums, ruby.wasm licence/complete NOTICE and the exact browser WASI +shim and `tslib` licence texts needed by the host bundle. The production worker +passes each request through a bounded length-prefixed file in its private WASI +memory filesystem. It receives bounded inert JSON metadata and reads bounded +UTF-8 replacement output from a separate private file, rather than amplifying +that output through JSON or using `RubyVM.wrap`/`toJS` and their +JavaScript-eval conversion path. Ruby cold startup passes the release's +strict-CSP browser gate. + +## Building the C++ pack + +The C++ bridge under `engines/cpp/` is compiled with Emscripten 6.0.4 at +compiler revision `fe5be6afdff43ad58860d821fcc8572a23f92d19`. It uses libc++ +`std::wregex`, 32-bit `wchar_t`, fixed structured Embind entry points and +`-sDYNAMIC_EXECUTION=0`. + +```sh +node scripts/cpp-engine-pack.mjs --empp /absolute/path/to/em++ +node scripts/install-cpp-engine.mjs +``` + +The verifier checks exact Emscripten, emsdk and LLVM identities, bridge hashes, +WebAssembly/module structure, absence of dynamic-execution constructs in the +generated module, runtime identity, code-point ranges and bounded replacement +parity. The build also enables `wasm-ld --trace` and accepts only the reviewed +linked archive set: Emscripten runtime support, musl `libc`, emmalloc, +compiler-rt builtins, libc++ and libc++abi. + +`SOURCE-MANIFEST.json` ties the exact module hash to Emscripten tag/commit +`6.0.4`/`fe5be6afdff43ad58860d821fcc8572a23f92d19`, emsdk commit +`224ec5f9f2f72f09f9ce0e26d66bae7dbd8b692f`, the official release commit and +LLVM compiler commit. It records preferred-source paths and independently +pinned legal files for musl 1.2.6, emmalloc, compiler-rt 22.1.8, libc++ 21.1.8 +and libc++abi 21.1.8. The current JavaScript-exception link selects no +`libunwind.a` member; libunwind 22.1.8 and its legal text remain as an explicit +audited exclusion. Any added, removed or newly selected archive fails the pack +build. + +## Building the Go pack + +Go 1.26.5 standard-library `regexp` is built with the official linux/amd64 +archive, SHA-256 +`5c2c3b16caefa1d968a94c1daca04a7ca301a496d9b086e17ad77bb81393f053`, +for `GOOS=js GOARCH=wasm`. + +```sh +node scripts/build-go-engine.mjs /absolute/path/to/go +node scripts/install-go-engine.mjs +node scripts/verify-go-engine.mjs +``` + +The pack pins the source commit, official archive, `wasm_exec.mjs`, bridge +source, build flags and Go licence. Verification executes real Unicode +matching and `regexp.ExpandString` cases. + +## Building the Rust pack + +The Rust bridge pins `regex` crate 1.13.1 and its complete Cargo graph, rustc +1.97.1, the matching `wasm32-unknown-unknown` standard library and wasm-bindgen +0.2.126. + +```sh +node scripts/build-rust-engine.mjs /absolute/path/to/rust-toolchain +node scripts/install-rust-engine.mjs +node scripts/verify-rust-engine.mjs +``` + +The pack records the distribution manifest/archive hashes, crate checksums, +compiler and LLVM identities, bridge sources, exact bindings and complete +Rust/crate licence material. Runtime verification covers identity, Unicode +byte ranges, limits and `Captures::expand`. + +## Building the .NET pack + +The fixed `[JSExport]` bridge under `engines/dotnet/` is published by .NET SDK +10.0.302 with runtime 10.0.10 and its `wasm-tools` workload. + +```sh +node scripts/dotnet-engine-pack.mjs --dotnet /absolute/path/to/dotnet +node scripts/install-dotnet-engine.mjs +``` + +The pack gate checks SDK/runtime/workload and bridge identities, removes +compressed/debug outputs, records every `_framework` file, and includes the +.NET MIT licence and third-party notices. The release browser gate executes +the browser-WASM identity, Unicode-range and native-replacement smoke. There +is no separate Scala pack. + ## Runtime boundaries ### PCRE2 @@ -150,9 +352,11 @@ CPython and `re` identities before accepting work. The application bridge is evaluated inside that interpreter and exposes bounded compile, match and native replacement operations. It reports CPython's Unicode code-point positions; the TypeScript adapter retains them and converts only valid boundaries to -half-open editor UTF-16 ranges. Runtime load has a separate startup deadline. -Execution timeout, cancellation or crash terminates the worker and its complete -Python/WebAssembly heap. +half-open editor UTF-16 ranges. Replacement output is byte-bounded in Python, +encoded as canonical base64 in the JSON envelope and decoded only after its +declared size, request cap and UTF-8 are validated. Runtime load has a separate +startup deadline. Execution timeout, cancellation or crash terminates the +worker and its complete Python/WebAssembly heap. ### Java @@ -163,3 +367,92 @@ replacement output, and returns native half-open UTF-16 ranges. No Java virtual machine, OpenJDK classes, remote service or ECMAScript regex fallback is involved. Runtime load has a separate startup deadline; termination discards the complete worker module state. + +### PHP + +The PHP worker starts the same-origin Asyncify runtime, installs the fixed +`bridge.php` in its private virtual filesystem and verifies PHP 8.5.8 plus +PCRE2 10.44 before accepting work. User values cross only as JSON data. The +bridge selects its own safe delimiter, permits only registered modifiers and +calls native `preg_match()`. `PREG_OFFSET_CAPTURE` byte offsets are retained; +byte matches that split an encoded character are rejected because they cannot +map losslessly to a browser string. Bounded replacement mirrors PHP 8.5.8's +`preg_get_backref()` syntax over those native records and clips every append +before allocation crosses the requested byte cap. `preg_replace()` is used +only by the fixed identity parity self-test. Replacement bytes cross the JSON +envelope as size-predictable base64 and are decoded with a fatal UTF-8 check. + +### Perl + +The supervised module worker owns a nested classic worker required by the +legacy WebPerl loader. Terminating the supervisor also terminates that +descendant and the complete Perl heap. The fixed bridge uses `no re 'eval'`, +rejects code assertions independently and exposes only literal text, `$$`, +greedy `$n` and `${name}` replacement expansion. It pre-tokenizes that grammar, +streams small bounded UTF-8 pieces from native spans without constructing a +complete expansion or JSON output, and preserves the unmatched tail when the +match/capture-row bound stops replacement. Fixed named and numbered fixtures +are checked against native Perl `s///` during the identity self-test. Perl +character offsets are returned as Unicode code points. This containment does +not make WebPerl current software; the UI continues to report its legacy beta +identity. + +### Ruby + +The Ruby worker starts the minimal WASI runtime, evaluates only the fixed +application bridge and verifies CRuby 4.0.0 identity. User values travel as +bounded length-prefixed data in the worker-local memory filesystem; the bridge +returns inert metadata JSON and never sends a user-controlled value through +ruby.wasm's JavaScript-eval object-conversion path. CRuby compiles and matches. +Native `String#gsub`/`String#sub` block iteration selects replacement matches; +a fixed streaming implementation of CRuby 4.0.0's `rb_reg_regsub` grammar +writes only the configured UTF-8 prefix to a separate private file. A +load-time parity check compares the fixed expander with CRuby on bounded +fixtures. Native character offsets are retained as Unicode code points. +Worker termination discards the Ruby VM and both private files. + +### C++ + +The C++ worker loads fixed Embind exports whose generated module was built with +dynamic execution disabled. Each request constructs `std::wregex`, iterates +under central result limits and streams a fixed implementation of libc++'s +`match_results::format` default grammar through the output byte cap. Load-time +fixtures compare it with the native formatter. The adapter exposes 32-bit +`wchar_t` positions as Unicode code points. The default grammar is C++'s +modified ECMAScript grammar, not the browser's current ECMAScript grammar. + +### Go and Rust + +The Go and Rust workers load their own fixed JSON bridges and verify the exact +runtime/crate identities before work. Both return UTF-8 byte ranges and reject +lone surrogates before encoding. Go uses standard-library `regexp` and +`ExpandString`; Rust uses `regex` crate iteration and `Captures::expand`. +Their fixed streaming expanders reproduce those native replacement grammars +under the output byte cap and compare bounded fixtures with the native APIs at +load. The adapters measure exact request JSON bytes, while matching native caps +include the worst-case sixfold escaping of every accepted string field. Output +bytes use fixed 4:3 base64 JSON envelopes instead of content-dependent JSON +escaping. Neither runtime supports look-around or backreferences. Each module +also enforces its own pattern, result and output bounds; Rust adds +compiled-regex and DFA-size limits. + +### .NET + +The .NET worker loads the browser-WASM runtime and calls only fixed +`[JSExport]` methods with bounded JSON. It verifies runtime 10.0.10, +`System.Text.RegularExpressions`, UTF-16 offsets and invariant culture. A +nine-second native regex timeout complements the shorter supervisor deadline; +terminating the worker discards the managed runtime. The adapter currently +returns the final retained capture only, not .NET capture history. Replacement +templates are parsed once by a fixed streaming implementation of .NET's +numbered, named and special substitution tokens. A load-time oracle compares +the fixed implementation with native `Match.Result`; bounded UTF-8 output is +transported as canonical base64 rather than JSON-escaped user text. + +### Scala/JVM compatibility + +Scala requests deliberately delegate to the same verified TeaVM adapter and +module described under Java. Result metadata says “no Scala runtime”. The +profile covers Java-compatible pattern/replacement semantics only and does not +claim Scala `Regex` wrappers, extractors, compiler/runtime code or OpenJDK +behavior. diff --git a/docs/EXECUTION_TRACES.md b/docs/EXECUTION_TRACES.md index b2edeeb..59e3626 100644 --- a/docs/EXECUTION_TRACES.md +++ b/docs/EXECUTION_TRACES.md @@ -5,9 +5,10 @@ results, but no V8, SpiderMonkey or JavaScriptCore execution trace. Regex Tools does not relabel structural explanations, static findings or timing observations as an ECMAScript engine trace. -The bundled CPython `re` and TeaVM `java.util.regex` bridges likewise expose -compilation, bounded match/capture and replacement results, not internal engine -steps. Regex Tools does not label their partial lexical syntax trees as traces. +The PHP, legacy Perl, CPython, CRuby, TeaVM Java/Scala compatibility, libc++, +Go, Rust and .NET bridges likewise expose compilation, bounded match/capture +and replacement results, not internal engine steps. Regex Tools does not label +their partial lexical syntax trees as traces. PCRE2 10.47 has a separate actual automatic-callout vertical. ABI version 3 compiles the requested pattern with `PCRE2_AUTO_CALLOUT`, registers an diff --git a/docs/EXPLANATION_MODEL.md b/docs/EXPLANATION_MODEL.md index e3832d4..698838f 100644 --- a/docs/EXPLANATION_MODEL.md +++ b/docs/EXPLANATION_MODEL.md @@ -20,16 +20,18 @@ common capture forms. It does not infer branch-reset numbering or claim full nesting; authoritative compilation, capture counts, names and result ranges come from PCRE2 itself. -The Python and Java providers likewise emit deliberately partial lexical trees. -They recognize their documented capture and replacement forms for navigation -and display, but do not claim full grammar acceptance. CPython `re` and TeaVM -`Pattern` remain authoritative for compilation. Java capture names displayed -with native numbered spans come from the bounded lexical metadata; they are not -invented as a TeaVM-reported name table. +The Python, Java, PHP, Perl, Ruby, C++, Go, Rust, .NET and Scala-compatibility +providers likewise emit deliberately partial lexical trees. They recognize +their documented capture and replacement forms for navigation and display, +but do not claim full grammar acceptance. The selected named runtime remains +authoritative for compilation. Java and Scala capture names displayed with +native numbered spans come from bounded lexical metadata; they are not +invented as a TeaVM-reported name table. C++ capture discovery is explicitly +unavailable for alternate grammars or `nosubs`. The explanation tree is structural. It is never called an actual execution trace. Selecting a node selects and scrolls its exact editor range; selecting pattern text chooses the smallest enclosing node. PCRE2’s separate trace viewer contains actual bounded automatic callouts; its movement labels remain a distinct derived layer and are never copied into the structural explanation. -Python and Java expose no actual execution trace. +The other eleven profiles expose no actual execution trace. diff --git a/docs/EXTRACTION_MODEL.md b/docs/EXTRACTION_MODEL.md index 7721919..55406c0 100644 --- a/docs/EXTRACTION_MODEL.md +++ b/docs/EXTRACTION_MODEL.md @@ -18,14 +18,22 @@ budget. Consumers must inspect the preview status rather than treating a preview as complete. In particular, list export is disabled if its template would consume an incomplete value. -Repeated ECMAScript, PCRE2, Python and Java captures expose only the final -retained capture. The UI labels this limitation and does not invent history. -Later .NET support may add actual engine capture-history nodes without -degrading them to this model. +Repeated captures expose only the final retained value in all twelve v0.4.0 +profiles. This includes .NET even though its native API can retain capture +history: the current adapter deliberately normalizes only the final record and +reports `captureHistory: false`. The UI labels the limitation and does not +invent or silently discard advertised history. -The syntactic hierarchy remains useful even if actual spans overlap or fall -outside a parent's geometry; native and normalized ranges are preserved rather -than “fixed”. ECMAScript and Java native offsets are UTF-16 code units, PCRE2 -native offsets are UTF-8 bytes and Python native offsets are Unicode code -points. All editor ranges are normalized to UTF-16 without discarding the -native unit. +The partial syntactic hierarchy remains useful when the active provider found +capture relationships, even if actual spans overlap or fall outside a parent's +geometry. For C++ alternate grammars or suppressed submatches, capture +discovery can be explicitly unavailable. Runtime records remain authoritative. + +Native and normalized ranges are preserved rather than “fixed”: + +- JavaScript, Java, Scala compatibility and .NET use UTF-16 code units; +- standalone PCRE2, PHP, Go and Rust use UTF-8 bytes; and +- Python, Ruby, C++ and legacy Perl use Unicode code points. + +All editor ranges are normalized to UTF-16 only after the adapter verifies +valid boundaries. The native unit and original range remain available. diff --git a/docs/FLAVOUR_SUPPORT.md b/docs/FLAVOUR_SUPPORT.md index 57e65b1..feeea00 100644 --- a/docs/FLAVOUR_SUPPORT.md +++ b/docs/FLAVOUR_SUPPORT.md @@ -1,75 +1,87 @@ # Flavour support -| Flavour | Syntax | Execution | Replacement | Captures | Trace | Analysis | Generated cases | Native offsets | -| ---------------------- | ------------------------------------------------------------ | --------------------------------------------------------- | ---------------------------------------- | -------------------------------------------------- | ------------------------------------------------------------ | ------------------------------------------------------ | ------------------------------------------------------- | -------------- | -| ECMAScript | regexpp 4.12.2; explanations partial/feature-matrix tested | Current browser `RegExp`; conformance tested | Bounded ECMAScript `GetSubstitution` | Named/numbered; final repeated capture; no history | Unavailable | Experimental static heuristics + bounded native probes | Bounded normalized-AST sampling; actual-engine verified | UTF-16 | -| PCRE2 10.47 | Application lexical provider partial; compiler authoritative | Pinned 8-bit WASM; bounded/killable/conformance tested | Native bounded `pcre2_substitute()` loop | Native named/numbered records; no capture history | Bounded reported automatic callouts; derived movement labels | Unavailable; ECMAScript heuristics are never applied | Unavailable; structural syntax provider is partial | UTF-8 bytes | -| Python `re` | Application lexical provider partial; compiler authoritative | CPython 3.14.2 in self-hosted Pyodide 314.0.3 | Native bounded `re` expansion | Native named/numbered spans; no capture history | Unavailable | Unavailable; ECMAScript heuristics are never applied | Unavailable; structural syntax provider is partial | Code points | -| Java `java.util.regex` | Application lexical provider partial; compiler authoritative | TeaVM 0.15.0 class library; bounded/killable; not OpenJDK | TeaVM single-digit `$n`; no `${name}` | Native numbered ranges; lexical names; no history | Unavailable | Unavailable; ECMAScript heuristics are never applied | Unavailable; structural syntax provider is partial | UTF-16 | -| PCRE | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | -| Go `regexp` | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Planned bytes | -| Rust `regex` | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Unavailable | Planned bytes | -| .NET | Unavailable | Unavailable | Unavailable | Planned capture history | Unavailable | Unavailable | Unavailable | Planned UTF-16 | +Version 0.4.0 exposes twelve executable profiles. “Partial lexical provider” +means that Regex Tools recognizes common structure and replacement tokens for +explanation only; the named runtime compiler and replacement operation remain +authoritative. -ECMAScript tests cover its complete exposed flag matrix, internal indices, -zero-length iteration, captures, lookbehind, backreferences, Unicode properties -and bounded replacement. +| Profile | Syntax and execution identity | Replacement | Captures and native offsets | +| ----------------------- | ------------------------------------------------------------------------------------------------ | ------------------------------------------------------------------------------------------- | ------------------------------------------------------------------------------------ | +| JavaScript (ECMAScript) | regexpp 4.12.2 with ECMAScript 2025 syntax; current browser `RegExp` executes | Bounded ECMAScript `GetSubstitution` | Named/numbered, final repeated capture; UTF-16 | +| PCRE2 | Partial provider; official standalone PCRE2 10.47 8-bit WASM executes in mandatory UTF/UCP mode | Native bounded `pcre2_substitute()` loop | Native named/numbered records, no history; UTF-8 bytes | +| PHP | Partial provider; actual PHP 8.5.8 `preg_*` in `@php-wasm/web-8-5` 3.1.46, reporting PCRE2 10.44 | Fixed bounded PHP-token expansion; load-time `preg_replace()` parity | Native named/numbered records, no history; UTF-8 bytes | +| Perl | Partial provider; actual Perl 5.28.1 through legacy WebPerl 0.09-beta | Fixed bounded literal/`$$`/`$n`/`${name}` expansion; arbitrary Perl expressions unavailable | Native numbered spans plus bounded name annotations, no history; Unicode code points | +| Python | Partial provider; CPython 3.14.2 `re` in Pyodide 314.0.3 | Native bounded `re` expansion | Native named/numbered spans, no history; Unicode code points | +| Ruby | Partial provider; CRuby 4.0.0 `Regexp` in ruby.wasm 2.9.3-2.9.4 | Native `gsub`/`sub` iteration plus bounded CRuby 4.0.0-compatible expansion | Native named/numbered spans, no history; Unicode code points | +| Java | Partial provider; TeaVM 0.15.0 `java.util.regex`, not OpenJDK | TeaVM single-digit `$n`; no `${name}` | Native numbered ranges plus lexical names, no history; UTF-16 | +| C++ | Partial provider; Emscripten 6.0.4 libc++ `std::wregex`; modified ECMAScript grammar by default | Fixed bounded formatter; load-time libc++ `match.format` parity | Numbered captures only, no history; 32-bit `wchar_t` code points | +| Go | Partial provider; Go 1.26.5 standard-library `regexp` with RE2 syntax | Fixed bounded expansion; load-time `regexp.ExpandString` parity | Native named/numbered records, no history; UTF-8 bytes | +| Rust | Partial provider; Rust `regex` crate 1.13.1, built with rustc 1.97.1 | Fixed bounded expansion; load-time `Captures::expand` parity | Native named/numbered records, no history; UTF-8 bytes | +| .NET | Partial provider; .NET 10.0.10 `System.Text.RegularExpressions`, invariant culture | Fixed streaming .NET-token expansion with load-time native `Match.Result` parity | Named/numbered final records, no capture history in this adapter; UTF-16 | +| Scala/JVM compatibility | Partial provider; explicitly shares TeaVM 0.15.0 `java.util.regex`; no Scala runtime | Same TeaVM single-digit `$n` subset; no `${name}` | Same ranges as the TeaVM Java adapter; UTF-16 | -PCRE2 tests cover `g`, `i`, `m`, `s`, `x`, `U`, `J`, mandatory UTF/UCP, -branch-reset groups, recursion, `\K`, duplicate names, native substitution, -astral byte/UTF-16 ranges, zero-length iteration, compile errors, match limits -and result/output truncation. Trace tests cover reported automatic callouts, -bounded mark copying, native stop at the complete-event cap, compile ranges, -worker loading and browser rendering. +## Flags and options -Python tests cover application-level `g`, CPython flags `a`, `i`, `m`, `s` and -`x`, Python-only named-group/replacement syntax, native `re` substitution, -astral code-point/UTF-16 normalization, zero-length iteration, compile errors, -result limits, runtime identity and worker recovery. +- JavaScript exposes `g`, `i`, `m`, `s`, `u`, `v`, `y` and `d`; `u` and `v` + are mutually exclusive. +- Standalone PCRE2 exposes application iteration `g` plus `i`, `m`, `s`, `x`, + `U` and `J`, with match-step, depth and heap limits. UTF/UCP is mandatory. +- PHP exposes application iteration `g` plus the reviewed `preg` modifiers + `i`, `m`, `s`, `x`, `u`, `U`, `A`, `D`, `J`, `n` and `r`. PHP's `u` is not + conflated with standalone PCRE2's mandatory UTF/UCP configuration. +- Legacy Perl exposes `g`, `i`, `m`, `s`, `x`, `n` and one of `a`, `d`, `l` or + `u`. The two-character `/aa` mode is not exposed. +- Python exposes application iteration `g` plus `a`, `i`, `m`, `s` and `x`. +- Ruby exposes application iteration `g` plus `i`, `m` and `x`; Ruby `m` + includes dot-all behavior. +- Java and Scala compatibility expose application iteration `g` plus TeaVM + `Pattern` flags `i`, `d`, `m`, `s`, `u`, `x` and the documented `U` + compatibility request. +- C++ exposes application iteration `g` plus `i`, `n`, `o` and `c`, and a + required grammar option: `ECMAScript`, `basic`, `extended`, `awk`, `grep` or + `egrep`. +- Go exposes application iteration `g` plus `i`, `m`, `s` and `U`. +- Rust exposes application iteration `g` plus `i`, `m`, `s`, `U`, `u`, `x` and + `R`; Unicode is enabled by default. +- .NET exposes application iteration `g` plus `i`, `m`, `s`, `n`, `x`, `r`, + `c` and `b`. Execution is always culture invariant; `c` makes that fixed + compatibility choice explicit. -Java tests cover application-level `g`, TeaVM `Pattern` flags, Java named-group -syntax, TeaVM's native single-digit `$n` `Matcher` replacement, explicit -rejection of unsupported `${name}`, astral UTF-16 ranges, zero-length -iteration, compile errors, result limits, module identity and worker recovery. -The runtime and UI explicitly report that TeaVM 0.15.0 is not OpenJDK and does -not implement OpenJDK `Pattern.UNICODE_CHARACTER_CLASS`; `U` is a compatibility -request rather than an exact implementation of that flag. +## Verified boundaries -ECMAScript static findings and generated-input timing observations are -advisory. They describe only the selected ECMAScript 2025 pattern, browser -runtime and bounded inputs; they are not proofs of safety or general -complexity. +Every adapter has focused identity, request and result-contract tests. +Conformance and browser suites exercise compilation errors, bounded matching, +zero-length iteration, range normalization, replacement and worker recovery +across the profile set. Pack verifiers additionally check self-hosted assets, +metadata, closed-file-set checksums and applicable licences/notices. -ECMAScript generated-case version 1 uses only a complete accepted normalized -AST, an explicit deterministic seed and bounded sampling strategies. Every -retained positive or negative label is confirmed by the actual selected -browser engine. PCRE2, Python and Java generation are unavailable because -their current lexical providers are intentionally partial; ECMAScript behavior -is never relabelled as another flavour. +TeaVM supplies an Apache Harmony-derived class library. It is not OpenJDK and +does not implement OpenJDK `Pattern.UNICODE_CHARACTER_CLASS`; `U` means the +documented TeaVM compatibility behavior in both the Java and Scala profiles. +The Scala profile also does not implement `scala.util.matching.Regex` wrapper +or extractor APIs. -The PCRE2, Python and Java explanation providers deliberately do not invent -full structural coverage. PCRE2 branch-reset numbering is omitted from the -syntax tree, while actual capture numbers, names and ranges still come from the -selected runtime result. +The Perl target is intentionally legacy. Its unmodified WebPerl loader contains +one `eval(code)` site in an optional Perl-to-JavaScript interoperability import. +The fixed Regex Tools bridge does not load that facility, accepts pattern and +replacement values only as JSON data, uses `no re 'eval'`, rejects `(?{...})` +and `(??{...})`, and passes the documented CSP smoke without broad +`'unsafe-eval'`. -ECMAScript and PCRE2 support exact-request comparison for syntax acceptance, -engine compilation, matches, captures and engine-native replacement. Results -align by normalized UTF-16 ranges while retaining each native offset model. -Timeout, cancellation, rejection and truncation are never presented as -equivalent results. +## Feature scope -Pattern formatting is available only for an exact accepted ECMAScript regexpp -snapshot. It canonicalizes literal slashes and raw control/line-separator -representations, then requires paired actual-engine and applicable exact-test -validation before apply. PCRE2, Python and Java formatting is unavailable -because those providers are deliberately partial; their syntax is never -treated as ECMAScript. +Static findings, bounded growth probes, benchmarks, generated cases and +formatting are ECMAScript-only. Generated-case version 1 requires the complete +accepted regexpp AST and verifies every retained label through the actual +browser engine. No partial provider is passed through that generator or +formatter. -Subject minimization accepts only the verified ECMAScript and PCRE2 paths. -Python and Java selections are disabled rather than being minimized through a -different flavour. Semantic comparison is likewise an explicit -ECMAScript/PCRE2 operation; it is not a generic four-way equivalence checker. +Automatic-callout tracing and reviewed C17 code generation are standalone +PCRE2-only. The PHP profile does not reuse the standalone PCRE2 10.47 trace or +code-generation path because its authoritative engine is PHP `preg` with +PCRE2 10.44. -PCRE2 is the only current code-generation target. The reviewed C17 generator is -pinned to the PCRE2 10.47 8-bit API; other language generators remain -unavailable until they pass equivalent escaping and named-toolchain gates. +Exact-request semantic comparison and subject minimization support only their +reviewed ECMAScript/standalone-PCRE2 paths. Other selections are disabled +rather than routed through another profile. Results never claim generic +twelve-way equivalence. diff --git a/docs/FORMATTING.md b/docs/FORMATTING.md index 48ff3ee..376f6db 100644 --- a/docs/FORMATTING.md +++ b/docs/FORMATTING.md @@ -23,9 +23,9 @@ pretty-printer. The transform is idempotent. Formatting requires the exact current, accepted, non-recovered syntax snapshot from the bundled `@eslint-community/regexpp` provider. Transformations are derived from the provider's literal-token ranges rather than from a heuristic -text scan. A stale parse, a malformed pattern, a partial provider, PCRE2, -Python, Java or any other flavour is reported as unavailable and is never -silently rewritten. +text scan. A stale parse, malformed pattern, partial provider or any +non-ECMAScript profile is reported as unavailable and is never silently +rewritten. ## Mandatory validation before apply diff --git a/docs/GENERATED_CASES.md b/docs/GENERATED_CASES.md index 94e1740..43fee32 100644 --- a/docs/GENERATED_CASES.md +++ b/docs/GENERATED_CASES.md @@ -25,11 +25,11 @@ The coverage report says `covered`, `partial`, `unsupported` or sampling strategy was requested. It does not mean every string in the regular language was enumerated. -PCRE2, Python and Java generation is unavailable in version 1. Their actual -engines are complete for the advertised execution operations, but their -current structural syntax providers are intentionally partial. Regex Tools -does not feed their syntax to the ECMAScript generator or relabel ECMAScript -behaviour. +Standalone PCRE2, PHP, Perl, Python, Ruby, Java, C++, Go, Rust, .NET and Scala +compatibility generation is unavailable in version 1. Their actual engines are +complete for the advertised execution operations, but their current structural +syntax providers are intentionally partial. Regex Tools does not feed their +syntax to the ECMAScript generator or relabel ECMAScript behaviour. ## Unsupported and partial constructs diff --git a/docs/MINIMIZATION.md b/docs/MINIMIZATION.md index c7fe730..8f19c4e 100644 --- a/docs/MINIMIZATION.md +++ b/docs/MINIMIZATION.md @@ -10,9 +10,10 @@ selected real ECMAScript or PCRE2 worker. It can preserve: - the same one-sided comparison timeout while the other engine completes with authoritative, untruncated output. -Python and Java are not supported minimization targets in v0.3.0. The workspace -disables reduction for those active flavours; it does not substitute -ECMAScript, PCRE2 or a lexical provider as an execution oracle. +PHP, Perl, Python, Ruby, Java, C++, Go, Rust, .NET and Scala compatibility are +not supported minimization targets in v0.4.0. The workspace disables reduction +for those active profiles; it does not substitute ECMAScript, PCRE2 or a +lexical provider as an execution oracle. The fixed pattern, ordered flags, options, replacement and engine versions form the target identity. Syntax is parsed once to obtain capture metadata. Every diff --git a/docs/PARSER_PROFILES.md b/docs/PARSER_PROFILES.md index 10d20d7..272cd4c 100644 --- a/docs/PARSER_PROFILES.md +++ b/docs/PARSER_PROFILES.md @@ -6,20 +6,38 @@ Regex Tools has one public profile: community ``` -It uses only reviewed open-source dependencies and builds without private -registry credentials. ECMAScript uses regexpp 4.12.2. PCRE2 uses an -application-owned lexical provider for partial explanations and the actual -bundled PCRE2 compiler for authoritative acceptance. Python and Java use -application-owned lexical providers for partial explanations and -flavour-native replacement tokens; bundled CPython `re` and TeaVM -`java.util.regex` respectively remain authoritative for compilation. -The Java provider follows the bundled TeaVM 0.15.0 replacement subset: -single-digit `$n` is executable, `$12` is `$1` followed by literal `2`, and -Java SE `${name}` references are surfaced as a compatibility limitation. +It uses reviewed open-source dependencies and builds without private registry +credentials. No licensed parser is installed, referenced or required. + +JavaScript/ECMAScript uses regexpp 4.12.2 for ECMAScript 2025 syntax. That is +the only current complete grammar-backed normalized syntax tree. All other +profiles use application-owned, deliberately partial lexical providers: + +| Profile | Authoritative compiler | Lexical-provider boundary | +| ----------------------- | --------------------------------------------- | -------------------------------------------------------------------------------------------------------------------- | +| PCRE2 | Standalone PCRE2 10.47 | Common captures and PCRE2 constructs; no complete structural grammar or branch-reset numbering | +| PHP | PHP 8.5.8 `preg` / PCRE2 10.44 | Common PCRE2/PHP capture forms and numbered replacement references; no delimiter or complete `preg` template model | +| Perl | Perl 5.28.1 via legacy WebPerl 0.09-beta | Common captures and fixed bridge references only; embedded code and complete Perl interpolation are unavailable | +| Python | CPython 3.14.2 `re` | Common Python captures and replacement references | +| Ruby | CRuby 4.0.0 `Regexp` | Common Onigmo capture forms and `String#gsub` references | +| Java | TeaVM 0.15.0 `java.util.regex` | Common Java captures and TeaVM replacement subset; not OpenJDK | +| C++ | Emscripten 6.0.4 libc++ `std::wregex` | Capture discovery only for the default modified ECMAScript grammar; alternate grammars remain compiler-authoritative | +| Go | Go 1.26.5 standard-library `regexp` | Common RE2 capture forms and `regexp.Expand` references | +| Rust | Rust `regex` crate 1.13.1 | Common capture forms and `Captures::expand` references | +| .NET | .NET 10.0.10 `System.Text.RegularExpressions` | Common captures/substitutions; no balancing-group or capture-history structure | +| Scala/JVM compatibility | Same TeaVM 0.15.0 Java engine | Java-compatible syntax only; no Scala runtime, wrapper or extractor model | + +The Java and Scala providers follow the bundled TeaVM 0.15.0 replacement +subset: single-digit `$n` is executable, `$12` is `$1` followed by literal +`2`, and `${name}` is surfaced as a compatibility limitation. The Scala +provider deliberately shares that implementation and says so. + +Every partial provider exposes its gaps through coverage metadata. Actual +acceptance, capture numbering and replacement output always come from the +selected runtime. ECMAScript analysis, case generation and formatting are not +applied to these partial trees. The product deliberately does not implement or reference an `@r101/parser` profile. No commercial package alias, import, tarball, credential, licence key -or private CI path exists. Additional flavour syntax is implemented -incrementally as open-source providers behind the same application-owned -interface. Partial coverage is exposed as metadata and never presented as a -complete parser. +or private CI path exists. Further syntax coverage can grow behind the same +application-owned interface without changing the runtime identity. diff --git a/docs/PERFORMANCE.md b/docs/PERFORMANCE.md index ea10e7c..915050a 100644 --- a/docs/PERFORMANCE.md +++ b/docs/PERFORMANCE.md @@ -19,12 +19,23 @@ supervisor wall clock, and cancellation discards the complete worker heap. Python has a materially larger cold start because its worker loads the self-hosted Pyodide JavaScript/WebAssembly runtime and Python standard library before verifying CPython and `re`. Java imports and self-tests its bundled -TeaVM ES module. Engine loading is an explicit operation with a -flavour-specific startup deadline; it is not charged to the 250 ms live or -selected manual execution timeout. Warm requests reuse the verified worker. -Killing a worker for timeout, crash or cancellation discards its complete -runtime, so the next request pays the cold-load cost and verifies identity -again. +TeaVM ES module. Scala compatibility shares that Java module and does not load +a second runtime. + +PHP, legacy Perl, Ruby, Go, Rust, C++ and .NET likewise load only when first +selected. Their cold cost differs substantially: PHP, Perl, Ruby and .NET +instantiate larger language/runtime packs; Go includes its standard +WebAssembly runtime; Rust and C++ are comparatively compact native modules. +The UI reports loading separately rather than charging it to the 250 ms live or +selected manual execution timeout. + +Warm requests reuse a verified worker. To prevent profile exploration from +leaving every large runtime resident, the supervisor uses a two-worker +retention target and evicts the least recently used idle generation before it +creates another profile worker. An active request is never evicted, so +concurrent active work can temporarily exceed the target. Killing or evicting +a worker discards its complete runtime, so the next request pays the cold-load +cost and verifies identity again. Automatic-callout tracing is deliberately excluded from every benchmark. It compiles an independently instrumented PCRE2 pattern in a separate worker and diff --git a/docs/PORTAL_REQUIREMENTS.md b/docs/PORTAL_REQUIREMENTS.md index 5cd34a2..90ceb0f 100644 --- a/docs/PORTAL_REQUIREMENTS.md +++ b/docs/PORTAL_REQUIREMENTS.md @@ -1,31 +1,46 @@ # Portal requirements -Regex Tools is a static nested-path-safe application. +Regex Tools is a static nested-path-safe application. All engine resources are +self-hosted below the mounted release path; no runtime CDN fallback is allowed. Required delivery behavior: -- JavaScript workers use a JavaScript MIME type. -- `toolbox-app.json`, HTML and legal/source documents should remain - revalidation/no-cache resources. -- Hashed Vite assets may use immutable long-term caching. -- CSP must allow `worker-src 'self' blob:`. -- `engines/pcre2/pcre2.wasm` and - `engines/python/pyodide.asm.wasm` must use `application/wasm`. -- Engine `.mjs` files must use a JavaScript MIME type; - `engines/python/python_stdlib.zip`, JSON, licence, notice and checksum files - must be delivered without content transformation. -- `script-src` must permit self-hosted WebAssembly compilation, normally with - `'wasm-unsafe-eval'`; broad `'unsafe-eval'` is neither needed nor recommended. -- `connect-src 'self'` must allow the Pyodide worker to fetch its own - same-origin WebAssembly, standard-library and lock files. -- Every file below `engines/pcre2/`, `engines/python/` and `engines/java/` - should use revalidation or a release-scoped immutable cache. These are not - content-hashed filenames and must never drift under one release identity. +- JavaScript, module and worker files (`.js` and `.mjs`) use a JavaScript MIME + type. +- Every `.wasm` file below `engines/` uses `application/wasm`. This includes + standalone PCRE2, PHP, Perl, Python, Ruby, C++, Go, Rust and every .NET + `_framework` WebAssembly file. +- `toolbox-app.json`, HTML and legal/source documents remain + revalidation/no-cache resources. Hashed Vite assets may use immutable + long-term caching. +- CSP permits `worker-src 'self' blob:`. The legacy Perl profile starts one + nested same-origin classic worker inside its supervised module worker. +- CSP permits self-hosted WebAssembly compilation in `script-src`, normally + through `'wasm-unsafe-eval'`. Broad `'unsafe-eval'` must not be enabled to + accommodate a runtime. Ruby cold startup and the fixed legacy Perl path pass + the release's strict-CSP browser gate without broad eval. WebPerl retains a + dormant optional interoperability `eval` site in upstream `emperl.js`, but + the fixed bridge does not load it. +- `connect-src 'self'` permits workers/runtimes to fetch their own same-origin + WebAssembly, Python standard-library, Perl data, .NET framework and metadata + resources. +- Binary/data assets such as `python_stdlib.zip`, `emperl.data`, metadata JSON, + checksum files, licences and notices are delivered without content + transformation. +- Range support is not required, but servers and proxies must not rewrite + engine bytes or apply HTML fallbacks to missing asset paths. +- Every directory below `engines/` uses revalidation or a release-scoped + immutable cache. Most engine filenames are not content-addressed and must + never drift under one release identity. + +A suitable CSP is documented in [`SECURITY.md`](SECURITY.md). Deployments +should test both a direct root mount and a nested mount such as +`/apps/regex/`, including cold loading of all twelve profiles. The Portal must consume the immutable release ZIP, verify its SHA-256, verify -manifest ID `de.add-ideas.regex-tools` and version `0.3.0`, and mount it at a +manifest ID `de.add-ideas.regex-tools` and version `0.4.0`, and mount it at a relative target such as `apps/regex/`. -The package, manifest, tag, artifact URL and checksum must all use the v0.3.0 +The package, manifest, tag, artifact URL and checksum must all use the v0.4.0 identity. Historical artifact coordinates remain immutable and must not be overwritten or reused. diff --git a/docs/REFERENCE_IMPLEMENTATIONS.md b/docs/REFERENCE_IMPLEMENTATIONS.md index 80d78f1..4b2d726 100644 --- a/docs/REFERENCE_IMPLEMENTATIONS.md +++ b/docs/REFERENCE_IMPLEMENTATIONS.md @@ -2,23 +2,34 @@ Inspection date: 2026-07-27. -| Reference | Exact revision/version | Licence | Use and copying status | -| ------------------------ | ----------------------------------------------------------------------------------------------------------------------- | -------------------------------------- | --------------------------------------------------------------------------------------------------- | -| Regex Tools | Release identity `v0.3.0` | GPL-3.0-or-later | Application source written for this project. | -| Toolbox SDK | `53c40a61ba1581246f65773fcbb1c1cfd31ac98e` / 0.2.2 | Apache-2.0 | Contract, shell and release conventions; package APIs used, no source adapted. | -| Toolbox Portal | `a9c31c8986c40a0097966318e925083302e91e13` / 0.5.0 | AGPL-3.0-only | Assembly/lock conventions inspected; no source copied into the app. | -| regexpp | 4.12.2; npm integrity `sha512-EriSTlt5OC9/7SXkRSCAhfSxxoSUgBm33OH+IkwbdpgoqsSsUg7y3uh+IICI/Qg4BBWr3U2i39RpmycbxMq4ew==` | MIT | Pinned ECMAScript syntax provider. Provider AST is normalized in a worker. | -| PCRE2 | signed tag 10.47; commit `f454e231fe5006dd7ff8f4693fd2b8eb94333429` | BSD-3-Clause WITH PCRE2-exception | Pinned offline build; generated verified WebAssembly pack is shipped, source is not vendored. | -| Pyodide | tag 314.0.3; commit `ac57031be7564f864d061cb37c5c152e59f83ad4`; pinned npm integrity | MPL-2.0 | Reviewed self-hosted runtime pack; no CDN use. | -| CPython | executable runtime identity 3.14.2 in Pyodide 314.0.3 | PSF-2.0 | Actual `re` compiler, matcher and replacement runtime; Python source is not vendored. | -| TeaVM | tag/commit `ee91b03e616c4b45401cd11fb0cd7eb0daf6649b` / 0.15.0 | Apache-2.0 | `java.util.regex` class library compiled into the verified module; not OpenJDK. | -| ECMAScript specification | ; living specification inspected 2026-07-24 | ECMA terms | Semantics reference; no prose copied. | -| regex101 | and public parser documentation | Product/commercial terms | Product reference only. No source, branding, explanations, reference prose or visual design copied. | -| `recheck` | 4.5.0 | MIT | Metadata inspected; not installed or shipped. | -| `regexp-ast-analysis` | 0.7.1 | MIT | Metadata inspected; not installed or shipped. | -| RegexHub | repository revision `d1d9f19d259745dfdd21935b9ef3e747b62b9bfb` | MIT | Potential future adversarial cases; no file copied. | -| RegexLib | Website inspected | Redistribution licence not established | No fixture copied. | -| RGXP.RU | Website inspected | Redistribution licence not established | No fixture copied. | +| Reference | Exact revision/version | Licence | Use and copying status | +| -------------------------------- | ---------------------------------------------------------------------------------------------------------------------------------------------------------- | ------------------------------------------------------------------------------------------------ | ----------------------------------------------------------------------------------------------------------------------------------------- | +| Regex Tools | Release identity `v0.4.0` | GPL-3.0-or-later | Application source written for this project. | +| Toolbox SDK | `53c40a61ba1581246f65773fcbb1c1cfd31ac98e` / 0.2.2 | Apache-2.0 | Contract, shell and release conventions; package APIs used, no source adapted. | +| Toolbox Portal | `9347554324299c8ec9dfaec2c9730907736f62c3` / aggregate v0.8.0 / package 0.2.7 | AGPL-3.0-only | Assembly/lock conventions inspected; no source copied into the app. | +| regexpp | 4.12.2; pinned npm integrity in `package-lock.json` | MIT | ECMAScript 2025 syntax provider; normalized in the syntax worker. | +| PCRE2 | Signed tag 10.47; commit `f454e231fe5006dd7ff8f4693fd2b8eb94333429` | BSD-3-Clause WITH PCRE2-exception | Standalone pinned offline build; verified 8-bit WebAssembly pack shipped, source not vendored. | +| PHP | Executable identity 8.5.8; embedded PCRE2 identity 10.44 | PHP License version 4 (BSD-3-Clause), elected through the earlier licence's later-version option | Actual PHP `preg_*` compiler, matcher and replacement runtime; PHP source not vendored. | +| WordPress Playground `@php-wasm` | `web-8-5`, `universal`, `util`, `logger`, `stream-compression` and `progress` 3.1.46; pinned npm integrities | GPL-2.0-or-later | Self-hosted PHP WebAssembly distribution/host packages; their separate GPL notice is included and recorded in the pack metadata. | +| WebPerl | 0.09-beta; commit `6f2173d29a2c2e3536e1de75ff5d291ae96ab348`; prebuilt archive SHA-256 `5f441249217e90ab378c666f473d4206ab4f44907f6bb0aa8d70834bc38c40dc` | GPL-1.0-or-later OR Artistic-1.0-Perl | Unmodified legacy prebuilt pack containing Perl 5.28.1; visibly labelled beta/legacy. | +| Emscripten used by WebPerl | 1.38.28 | MIT OR NCSA | Upstream-generated legacy Perl loader/runtime; applicable licence included. | +| Pyodide | Tag 314.0.3; commit `ac57031be7564f864d061cb37c5c152e59f83ad4`; pinned npm integrity | MPL-2.0 | Reviewed self-hosted runtime pack; no CDN use. | +| CPython | Executable runtime identity 3.14.2 in Pyodide 314.0.3 | PSF-2.0 | Actual `re` compiler, matcher and replacement runtime; Python source not vendored. | +| ruby.wasm / CRuby | `@ruby/4.0-wasm-wasi` and `@ruby/wasm-wasi` 2.9.3-2.9.4; executable CRuby identity 4.0.0 | MIT for ruby.wasm host; Ruby/BSD and component terms in bundled NOTICE | Minimal self-hosted CRuby `Regexp` runtime; pinned npm integrities/notices; fixed file/JSON bridge avoids the JavaScript-eval conversion. | +| TeaVM | Tag/commit `ee91b03e616c4b45401cd11fb0cd7eb0daf6649b` / 0.15.0 | Apache-2.0 | `java.util.regex` class library compiled into the verified Java module; not OpenJDK. Also backs the explicit Scala compatibility profile. | +| Emscripten / libc++ | Emscripten 6.0.4 compiler revision `fe5be6afdff43ad58860d821fcc8572a23f92d19` | MIT OR NCSA; Apache-2.0 WITH LLVM-exception | Compiles the application C++ bridge against libc++ `std::wregex`; toolchain source not vendored. | +| Go | Tag 1.26.5; commit `c19862e5f8415b4f24b189d065ed739517c548ba`; official archive SHA-256 `5c2c3b16caefa1d968a94c1daca04a7ca301a496d9b086e17ad77bb81393f053` | BSD-3-Clause | Standard-library `regexp` compiler/matcher and official `js/wasm` runtime. | +| Rust `regex` | 1.13.1; commit `2b527599eb9eea0dcc288c704584f242f26a5c61`; crate checksum `f020237b6c8eed93db2e2cb53c00c60a8e1bc73da7d073199a1180401450218d` | MIT OR Apache-2.0 | Actual crate compiler/matcher built for WebAssembly with the pinned Cargo graph. | +| Rust toolchain | rustc 1.97.1 commit `8bab26f4f68e0e26f0bb7960be334d5b520ea452`; wasm-bindgen 0.2.126 | Apache-2.0 OR MIT plus bundled component terms | Exact compiler, standard library and binding tool identities recorded in pack metadata. | +| .NET | SDK 10.0.302 / runtime 10.0.10; runtime commit `f7d90799ce` | MIT plus bundled third-party notices | Actual `System.Text.RegularExpressions` browser-WASM runtime. | +| ECMAScript specification | ; living specification inspected 2026-07-24 | ECMA terms | Semantics reference; no prose copied. | +| regex101 | and public parser documentation | Product/commercial terms | Product reference only. No source, branding, explanations, reference prose or visual design copied. | +| `recheck` | 4.5.0 | MIT | Metadata inspected; not installed or shipped. | +| `regexp-ast-analysis` | 0.7.1 | MIT | Metadata inspected; not installed or shipped. | +| RegexHub | Repository revision `d1d9f19d259745dfdd21935b9ef3e747b62b9bfb` | MIT | Potential future adversarial cases; no file copied. | +| RegexLib | Website inspected | Redistribution licence not established | No fixture copied. | +| RGXP.RU | Website inspected | Redistribution licence not established | No fixture copied. | -All v0.1.0, v0.2.0 and v0.3.0 conformance cases are project-authored. See -`tests/fixtures/README.md`. +All v0.1.0 through v0.4.0 conformance cases are project-authored. See +`tests/fixtures/README.md`. Runtime pack metadata and adjacent licence/notice +files are authoritative for the exact binary distribution. diff --git a/docs/RELEASE.md b/docs/RELEASE.md index d560464..90f2990 100644 --- a/docs/RELEASE.md +++ b/docs/RELEASE.md @@ -18,13 +18,31 @@ on publication failure, replaces an existing exact version only with `--force`, and produces: ```text -release/regex-tools-0.3.0.zip -release/regex-tools-0.3.0.zip.sha256 +release/regex-tools-0.4.0.zip +release/regex-tools-0.4.0.zip.sha256 ``` -Before packaging, the engine verifier checks the closed PCRE2, Python and Java -file sets in `dist/`, including checksums, metadata, licences/notices, module -and WebAssembly identities and self-hosted relative asset references. +The release scan checks ASCII/UTF-8, UTF-16LE and UTF-16BE content in text, +JavaScript, WebAssembly and PDB-like assets for local Unix/macOS/Windows build +paths. Runtime virtual homes are allowed only for the named generated loaders. +Two byte-exact upstream prebuilts are hash-bound exceptions: +`engines/perl/emperl.data` retains WebPerl's historical build paths and +documentation examples, and `engines/ruby/ruby.wasm` retains ruby.wasm's +upstream build paths. Any byte or path change removes that exception and fails +the release scan; neither artifact is rewritten. -The existing v0.1.0 and v0.2.0 ZIPs and matching sidecars are historical -immutable artifacts. Creating v0.3.0 must not replace, rename or remove them. +Before packaging, the engine verifier checks the closed standalone-PCRE2, PHP, +Perl, Python, Ruby, Java, C++, Go, Rust and .NET file sets in `dist/`, +including checksums, metadata, licences/notices, module and WebAssembly +identities and self-hosted relative asset references. Browser/runtime smoke +tests cover every selectable profile; Scala compatibility must resolve to the +verified TeaVM Java pack while reporting that no Scala runtime is present. +The Python gate additionally requires its complete `SOURCE-MANIFEST.json`, +every preferred-form archive/Git/patch identity and all 22 independently +anchored base-runtime legal files. The C++ gate requires its exact traced +component/source manifest and six independently pinned legal files. The release +packager names every one of those files explicitly. + +The existing v0.1.0, v0.2.0 and v0.3.0 ZIPs and matching sidecars are +historical immutable artifacts. Creating v0.4.0 must not replace, rename or +remove them. diff --git a/docs/SECURITY.md b/docs/SECURITY.md index f2bbef7..f048723 100644 --- a/docs/SECURITY.md +++ b/docs/SECURITY.md @@ -23,10 +23,67 @@ untrusted. identities. Pattern, subject, flags and replacement remain string data passed to the fixed application bridge; no user-supplied Python source is evaluated. Native code-point boundaries are checked before conversion to editor UTF-16. + Bounded replacement bytes use canonical base64 rather than content-dependent + JSON escaping; declared length, request cap and canonical UTF-8 are validated + before the output is exposed. - Java starts only after the worker verifies the TeaVM bridge ABI, engine identity and compiled self-test. It exposes only fixed bounded `Pattern`/`Matcher` entry points; no JVM, Java class loading or user-supplied JavaScript is available. The runtime is TeaVM, not OpenJDK. +- PHP starts only after the worker verifies PHP 8.5.8, PCRE2 10.44 and the + fixed bridge ABI. User values are JSON data written to a private virtual + filesystem; the bridge chooses a safe delimiter, allowlists modifiers and + invokes only fixed `preg_*` operations. +- The legacy Perl worker writes exact-key, byte-bounded JSON to a fixed MEMFS + request path and invokes only the constant `RegexTools::run_request()` entry + point. The bridge uses `no re 'eval'`, rejects `(?{...})` and `(??{...})` + outside escaped literals/classes, pre-tokenizes its non-executable + replacement grammar and streams bounded UTF-8 chunks from native match spans. + Successful output uses a separate fixed binary file, never the JSON response; + the worker verifies exact bytes, limit and canonical UTF-8 before decoding + it. Replacement stops at the match/capture-row bound and leaves the + unprocessed subject tail unchanged. WebPerl 0.09-beta's unmodified generated + loader contains one `eval(code)` site in an optional + JavaScript-interoperability import; the fixed bridge never loads or calls it. + The checksummed asset passes the browser CSP smoke without broad + `'unsafe-eval'`. +- Ruby evaluates only the fixed application bridge during worker startup. + Pattern, subject, flags, limits and replacement travel in one bounded, + length-prefixed file in the worker-local WASI memory filesystem. Native + `String#gsub`/`String#sub` block iteration cannot materialize expanded user + output: a fixed CRuby 4.0.0-compatible expander stops at the byte limit and + writes that prefix to a separate bounded file. The inert JSON response + contains metadata only and is assembled without per-code-point arrays. No + user value is interpolated into source or sent through ruby.wasm's + `RubyVM.wrap`/`toJS` JavaScript-eval conversion path. Unpaired browser + surrogates are rejected before UTF-8 encoding. Ruby cold startup passes the + strict-CSP release browser gate. +- C++ accepts only structured fixed Embind calls and is compiled with + Emscripten `-sDYNAMIC_EXECUTION=0`; the generated module is checked for + dynamic-source construction. Its libc++-compatible replacement expander + appends directly through the UTF-8 byte cap and is parity-checked at load. + Embind returns a structured JavaScript string rather than JSON, so there is + no escape amplification; the 64 MiB native buffer and its bounded UTF-16 + conversion are the explicit peak-output copies. +- Go and Rust accept JSON data only through fixed exports. Each validates its + request and enforces pattern, subject, result and output caps inside + WebAssembly. Adapters measure exact encoded request bytes; the native request + cap covers worst-case sixfold JSON escaping for every accepted string field, + so control-heavy values retain the documented decoded field limits. Their + native-compatible replacement token streams stop at the output cap without + allocating a whole capture expansion. Bounded UTF-8 output crosses the JSON + bridge as fixed 4:3 base64 rather than content-dependent escaped text. Rust + additionally caps compiled-regex and DFA storage. +- .NET accepts bounded JSON only through fixed `[JSExport]` methods and never + evaluates user input as managed or JavaScript source. A native regex timeout + complements the supervisor timeout. Its fixed replacement parser streams + native-compatible token fragments through the UTF-8 byte cap, verifies + parity with `Match.Result` at load and transports output as canonical base64 + to avoid JSON escaping amplification. The shipped .NET host contains runtime + debugging machinery, but normal production startup disables debugging and + is verified under the documented CSP. +- Scala compatibility shares the TeaVM Java bridge. It introduces no Scala + runtime, dynamic compiler or additional execution surface. - Every bundled engine directory has a closed file set, deterministic metadata/checksums and licence material verified both before installation and in `dist/`. Runtime imports and fetches resolve only against the same-origin @@ -86,12 +143,15 @@ untrusted. closed. Subjects and results are ephemeral and never uploaded or persisted. - No backend, uploads, telemetry, remote corpus URL, CDN, remote font, arbitrary command line or unsafe HTML rendering exists. Application code - does not evaluate user-controlled JavaScript or Python. The generic generated - Pyodide loader contains an Emscripten dynamic-link branch that uses - JavaScript `eval`, but the shipped self-contained CPython/stdlib path does not - exercise it and loads under the CSP below without broad `'unsafe-eval'`. + does not evaluate user-controlled source in any language. The generic + generated Pyodide loader contains an Emscripten dynamic-link branch that + uses JavaScript `eval`, while the legacy WebPerl loader contains the optional + interop site described above. Neither shipped fixed execution path exercises + those branches, and both load under the CSP below without broad + `'unsafe-eval'`. -The engine-enabled build needs a CSP equivalent to: +Every enabled profile, including a cold Ruby start, passes the release CSP +equivalent to: ```text default-src 'self'; @@ -107,11 +167,12 @@ base-uri 'none'; form-action 'none'; ``` -The Toolbox shell currently requires inline styles. Corpus ZIP generation, -PCRE2, Pyodide and TeaVM use self-hosted modules/assets and local workers under -the existing `worker-src` and `connect-src` policy. Broad `'unsafe-eval'` is not -required; `'wasm-unsafe-eval'` remains required for the two WebAssembly -runtimes. +The Toolbox shell currently requires inline styles. Corpus ZIP generation and +every engine pack use self-hosted modules/assets and local workers under the +existing `worker-src` and `connect-src` policy. Broad `'unsafe-eval'` must not +be added to accommodate an engine. The release gate blocks any future profile +that fails this strict-CSP browser matrix. `'wasm-unsafe-eval'` remains required +for the WebAssembly runtimes. Report vulnerabilities privately to the repository owner before public issue details are posted. diff --git a/engines/cpp/README.md b/engines/cpp/README.md new file mode 100644 index 0000000..9bb3d6b --- /dev/null +++ b/engines/cpp/README.md @@ -0,0 +1,34 @@ +# C++ regex engine + +This bridge executes patterns with the `std::wregex` implementation shipped in +Emscripten 6.0.4's libc++. The default grammar is the C++ standard library's +modified ECMAScript grammar; it is not presented as modern browser ECMAScript. + +The fixed Embind entry points accept structured values only. User patterns, +subjects and replacement templates are passed as data and are never evaluated +as JavaScript or C++ source. The worker remains subject to Regex Tools' hard +timeout and result limits. + +Replacement is streamed through the output byte limit with libc++ +`match_results::format` default grammar. A load-time differential self-test +compares bounded fixture output with the native API; capture amplification +never materializes a whole per-match expansion. + +Build with the pinned Emscripten checkout: + +```sh +node scripts/cpp-engine-pack.mjs --empp /absolute/path/to/em++ +node scripts/install-cpp-engine.mjs +``` + +The builder enables `wasm-ld --trace` and accepts only the reviewed archive +set. The generated `SOURCE-MANIFEST.json` records the exact Emscripten, emsdk +and LLVM identities; maps the selected Emscripten runtime, musl 1.2.6, +emmalloc, compiler-rt 22.1.8, libc++ 21.1.8 and libc++abi 21.1.8 sources to +their pinned legal files; and records that JavaScript exceptions select no +libunwind object. The libunwind legal text is retained so that exclusion stays +explicit and reviewable. + +Native positions are Unicode code-point offsets because the bridge deliberately +uses 32-bit `wchar_t`; the TypeScript adapter preserves them and separately +normalizes editor ranges to UTF-16. diff --git a/engines/cpp/cpp_regex_bridge.cpp b/engines/cpp/cpp_regex_bridge.cpp new file mode 100644 index 0000000..553eafb --- /dev/null +++ b/engines/cpp/cpp_regex_bridge.cpp @@ -0,0 +1,419 @@ +#include +#include + +#include +#include +#include +#include + +namespace { + +using emscripten::val; + +constexpr int kBridgeAbiVersion = 1; +constexpr std::size_t kMaximumCaptureGroups = 1000; + +std::wstring decode_utf8(const std::string& input) { + std::wstring output; + output.reserve(input.size()); + for (std::size_t index = 0; index < input.size();) { + const auto first = static_cast(input[index]); + std::uint32_t code_point = 0; + std::size_t width = 0; + if (first <= 0x7f) { + code_point = first; + width = 1; + } else if ((first & 0xe0) == 0xc0) { + code_point = first & 0x1f; + width = 2; + } else if ((first & 0xf0) == 0xe0) { + code_point = first & 0x0f; + width = 3; + } else if ((first & 0xf8) == 0xf0) { + code_point = first & 0x07; + width = 4; + } else { + throw std::invalid_argument("Input is not valid UTF-8."); + } + if (index + width > input.size()) { + throw std::invalid_argument("Input ends inside a UTF-8 sequence."); + } + for (std::size_t offset = 1; offset < width; ++offset) { + const auto continuation = + static_cast(input[index + offset]); + if ((continuation & 0xc0) != 0x80) { + throw std::invalid_argument("Input contains invalid UTF-8."); + } + code_point = (code_point << 6) | (continuation & 0x3f); + } + const bool overlong = (width == 2 && code_point < 0x80) || + (width == 3 && code_point < 0x800) || + (width == 4 && code_point < 0x10000); + if (overlong || code_point > 0x10ffff || + (code_point >= 0xd800 && code_point <= 0xdfff)) { + throw std::invalid_argument("Input contains invalid Unicode."); + } + output.push_back(static_cast(code_point)); + index += width; + } + return output; +} + +void append_utf8_code_point(std::string& output, std::uint32_t code_point) { + if (code_point <= 0x7f) { + output.push_back(static_cast(code_point)); + } else if (code_point <= 0x7ff) { + output.push_back(static_cast(0xc0 | (code_point >> 6))); + output.push_back(static_cast(0x80 | (code_point & 0x3f))); + } else if (code_point <= 0xffff) { + output.push_back(static_cast(0xe0 | (code_point >> 12))); + output.push_back(static_cast(0x80 | ((code_point >> 6) & 0x3f))); + output.push_back(static_cast(0x80 | (code_point & 0x3f))); + } else { + output.push_back(static_cast(0xf0 | (code_point >> 18))); + output.push_back( + static_cast(0x80 | ((code_point >> 12) & 0x3f))); + output.push_back(static_cast(0x80 | ((code_point >> 6) & 0x3f))); + output.push_back(static_cast(0x80 | (code_point & 0x3f))); + } +} + +std::string encode_utf8(const std::wstring& input) { + std::string output; + output.reserve(input.size()); + for (const wchar_t character : input) { + append_utf8_code_point(output, static_cast(character)); + } + return output; +} + +class BoundedOutput { + public: + explicit BoundedOutput(std::size_t maximum_bytes) + : maximum_bytes_(maximum_bytes) {} + + void append( + std::wstring::const_iterator first, + std::wstring::const_iterator last) { + if (truncated_) return; + for (; first != last; ++first) { + std::string encoded; + append_utf8_code_point( + encoded, static_cast(*first)); + if (value_.size() + encoded.size() > maximum_bytes_) { + truncated_ = true; + return; + } + value_ += encoded; + } + } + + void append(const std::wstring& value) { + append(value.cbegin(), value.cend()); + } + + const std::string& value() const { return value_; } + bool truncated() const { return truncated_; } + + private: + std::size_t maximum_bytes_; + std::string value_; + bool truncated_ = false; +}; + +template +void append_native_format_bounded( + BoundedOutput& output, + const std::match_results& match, + const std::wstring& replacement) { + for (std::size_t index = 0; + index < replacement.size() && !output.truncated(); + ++index) { + if (replacement[index] != L'$' || index + 1 == replacement.size()) { + output.append( + replacement.cbegin() + index, + replacement.cbegin() + index + 1); + continue; + } + const wchar_t next = replacement[index + 1]; + if (next == L'$') { + output.append( + replacement.cbegin() + index + 1, + replacement.cbegin() + index + 2); + ++index; + } else if (next == L'&') { + output.append(match[0].first, match[0].second); + ++index; + } else if (next == L'`') { + output.append(match.prefix().first, match.prefix().second); + ++index; + } else if (next == L'\'') { + output.append(match.suffix().first, match.suffix().second); + ++index; + } else if (next >= L'0' && next <= L'9') { + std::size_t capture = static_cast(next - L'0'); + ++index; + if (index + 1 < replacement.size() && + replacement[index + 1] >= L'0' && + replacement[index + 1] <= L'9') { + capture = + capture * 10 + + static_cast(replacement[index + 1] - L'0'); + ++index; + } + output.append(match[capture].first, match[capture].second); + } else { + output.append( + replacement.cbegin() + index, + replacement.cbegin() + index + 1); + } + } +} + +bool replacement_expansion_self_test() { + const std::wstring subject = L"xab!"; + const std::wregex expression(L"(a)(b)?"); + std::wsmatch match; + if (!std::regex_search(subject, match, expression)) return false; + const std::wstring fixtures[] = { + L"<$1:$2:$&>", + L"$$-$`-$'", + L"$0-$00-$01-$99", + L"$x-$", + }; + for (const auto& replacement : fixtures) { + BoundedOutput bounded(4096); + append_native_format_bounded(bounded, match, replacement); + if (bounded.truncated() || + bounded.value() != encode_utf8(match.format(replacement))) { + return false; + } + } + + const std::wstring large_subject(4096, L'a'); + const std::wregex large_expression(L"(a+)"); + std::wsmatch large_match; + if (!std::regex_search( + large_subject, large_match, large_expression)) { + return false; + } + std::wstring amplifying_replacement; + amplifying_replacement.reserve(65'536); + for (std::size_t index = 0; index < 32'768; ++index) { + amplifying_replacement += L"$1"; + } + BoundedOutput adversarial(5); + append_native_format_bounded( + adversarial, large_match, amplifying_replacement); + return adversarial.truncated() && adversarial.value() == "aaaaa"; +} + +val failure( + const std::string& phase, + const std::string& code, + const std::string& message) { + val result = val::object(); + result.set("abi", kBridgeAbiVersion); + result.set("ok", false); + result.set("phase", phase); + result.set("code", code); + result.set( + "message", + message.size() <= 1024 ? message : message.substr(0, 1024)); + return result; +} + +std::regex_constants::syntax_option_type syntax_options( + const val& request) { + using namespace std::regex_constants; + auto result = syntax_option_type{}; + const val options = request["options"]; + std::string grammar = "ECMAScript"; + const val configured_grammar = options["grammar"]; + if (!configured_grammar.isUndefined()) { + grammar = configured_grammar.as(); + } + if (grammar == "ECMAScript") { + result = ECMAScript; + } else if (grammar == "basic") { + result = basic; + } else if (grammar == "extended") { + result = extended; + } else if (grammar == "awk") { + result = awk; + } else if (grammar == "grep") { + result = grep; + } else if (grammar == "egrep") { + result = egrep; + } else { + throw std::invalid_argument("Unsupported std::regex grammar."); + } + const std::string flags = request["flags"].as(); + if (flags.find('i') != std::string::npos) result |= icase; + if (flags.find('n') != std::string::npos) result |= nosubs; + if (flags.find('o') != std::string::npos) result |= optimize; + if (flags.find('c') != std::string::npos) result |= collate; + return result; +} + +template +val match_record( + const std::match_results& match, + Iterator subject_begin) { + val record = val::object(); + val span = val::array(); + span.call( + "push", + static_cast(std::distance(subject_begin, match[0].first))); + span.call( + "push", + static_cast(std::distance(subject_begin, match[0].second))); + record.set("span", span); + val captures = val::array(); + for (std::size_t group = 1; group < match.size(); ++group) { + if (!match[group].matched) { + captures.call("push", val::null()); + continue; + } + val capture = val::array(); + capture.call( + "push", + static_cast( + std::distance(subject_begin, match[group].first))); + capture.call( + "push", + static_cast( + std::distance(subject_begin, match[group].second))); + captures.call("push", capture); + } + record.set("captures", captures); + return record; +} + +val cpp_regex_identity() { + val identity = val::object(); + identity.set("implementation", "libc++ std::wregex"); + identity.set("cplusplus", static_cast(__cplusplus)); +#ifdef __EMSCRIPTEN_MAJOR__ + identity.set( + "emscripten", + std::to_string(__EMSCRIPTEN_MAJOR__) + "." + + std::to_string(__EMSCRIPTEN_MINOR__) + "." + + std::to_string(__EMSCRIPTEN_TINY__)); +#else + identity.set("emscripten", "unknown"); +#endif + identity.set("wcharBits", static_cast(sizeof(wchar_t) * 8)); + identity.set( + "replacementSelfTest", replacement_expansion_self_test()); + return identity; +} + +val cpp_regex_run(const val& request) { + try { + if (request["abi"].as() != kBridgeAbiVersion) { + return failure("bridge", "unsupported-abi", "Unsupported bridge ABI."); + } + const std::string operation = request["operation"].as(); + if (operation != "execute" && operation != "replace") { + return failure( + "bridge", "invalid-operation", "Unsupported bridge operation."); + } + const std::wstring pattern = + decode_utf8(request["pattern"].as()); + const std::wstring subject = + decode_utf8(request["subject"].as()); + const std::wstring replacement = + operation == "replace" + ? decode_utf8(request["replacement"].as()) + : std::wstring(); + const std::string flags = request["flags"].as(); + const bool global = flags.find('g') != std::string::npos; + const auto maximum_matches = + request["maximumMatches"].as(); + const auto maximum_capture_rows = + request["maximumCaptureRows"].as(); + const auto maximum_output_bytes = + operation == "replace" + ? request["maximumOutputBytes"].as() + : 1U; + + std::wregex expression; + try { + expression.assign(pattern, syntax_options(request)); + } catch (const std::regex_error& error) { + return failure("compile", "regex-error", error.what()); + } + const std::size_t group_count = expression.mark_count(); + if (group_count > kMaximumCaptureGroups) { + return failure( + "compile", + "capture-group-limit", + "The pattern exceeds the 1,000 capture-group bridge limit."); + } + + val matches = val::array(); + std::size_t match_count = 0; + std::size_t capture_rows = 0; + bool results_truncated = false; + BoundedOutput output(maximum_output_bytes); + auto next_output = subject.cbegin(); + using Iterator = std::wstring::const_iterator; + std::regex_iterator current( + subject.cbegin(), subject.cend(), expression); + const std::regex_iterator end; + for (; current != end; ++current) { + const auto& match = *current; + const std::size_t rows = std::max(1, group_count); + if (match_count >= maximum_matches || + capture_rows + rows > maximum_capture_rows) { + results_truncated = true; + break; + } + matches.call( + "push", match_record(match, subject.cbegin())); + ++match_count; + capture_rows += rows; + + if (operation == "replace") { + output.append(next_output, match[0].first); + append_native_format_bounded(output, match, replacement); + next_output = match[0].second; + } + if (!global) { + ++current; + break; + } + } + if (operation == "replace") { + output.append(next_output, subject.cend()); + } + + val result = val::object(); + result.set("abi", kBridgeAbiVersion); + result.set("ok", true); + result.set("groupCount", static_cast(group_count)); + result.set("groupNames", val::array()); + result.set("matches", matches); + result.set("resultsTruncated", results_truncated); + if (operation == "replace") { + result.set("output", output.value()); + result.set( + "outputBytes", static_cast(output.value().size())); + result.set("outputTruncated", output.truncated()); + } + return result; + } catch (const std::exception& error) { + return failure("bridge", "bridge-error", error.what()); + } catch (...) { + return failure( + "bridge", "bridge-error", "Unknown C++ bridge failure."); + } +} + +} // namespace + +EMSCRIPTEN_BINDINGS(regex_tools_cpp_bridge) { + emscripten::function("regexToolsCppIdentity", &cpp_regex_identity); + emscripten::function("regexToolsCppRun", &cpp_regex_run); +} diff --git a/engines/dotnet/Program.cs b/engines/dotnet/Program.cs new file mode 100644 index 0000000..1312702 --- /dev/null +++ b/engines/dotnet/Program.cs @@ -0,0 +1,818 @@ +using System.Buffers; +using System.Globalization; +using System.Runtime.InteropServices.JavaScript; +using System.Text; +using System.Text.Json; +using System.Text.RegularExpressions; + +public static partial class RegexBridge +{ + private const int AbiVersion = 1; + private const int MaximumCaptureGroups = 1_000; + private static readonly TimeSpan MatchTimeout = TimeSpan.FromSeconds(9); + private static readonly Lazy ReplacementParity = new( + ReplacementParitySelfTest + ); + + [JSExport] + public static string Identity() + { + if (!ReplacementParity.Value) + throw new InvalidOperationException( + "The bounded replacement parser failed its native parity self-test." + ); + return "dotnet-regex|10.0.10|System.Text.RegularExpressions|utf16|culture-invariant|replacement-parity"; + } + + [JSExport] + public static string Run(string requestJson) + { + try + { + using var document = JsonDocument.Parse( + requestJson, + new JsonDocumentOptions + { + AllowTrailingCommas = false, + CommentHandling = JsonCommentHandling.Disallow, + MaxDepth = 16, + } + ); + var root = document.RootElement; + if (RequiredInt(root, "abi") != AbiVersion) + return Failure("bridge", "unsupported-abi", "Unsupported bridge ABI."); + + var operation = RequiredString(root, "operation", 16); + if (operation is not ("execute" or "replace")) + return Failure( + "bridge", + "invalid-operation", + "Unsupported bridge operation." + ); + var pattern = RequiredString(root, "pattern", 65_536); + var subject = RequiredString(root, "subject", 16 * 1024 * 1024); + var flags = RequiredString(root, "flags", 32); + var maximumMatches = RequiredInt(root, "maximumMatches"); + var maximumCaptureRows = RequiredInt(root, "maximumCaptureRows"); + if ( + maximumMatches is < 1 or > 10_000 + || maximumCaptureRows is < 1 or > 100_000 + ) + return Failure( + "bridge", + "invalid-limit", + "Result limits are outside the bridge contract." + ); + var replacement = + operation == "replace" + ? RequiredString(root, "replacement", 65_536) + : string.Empty; + var maximumOutputBytes = + operation == "replace" ? RequiredInt(root, "maximumOutputBytes") : 1; + if ( + operation == "replace" + && maximumOutputBytes is < 1 or > 64 * 1024 * 1024 + ) + return Failure( + "bridge", + "invalid-limit", + "Output limit is outside the bridge contract." + ); + + Regex expression; + try + { + expression = new Regex( + pattern, + RegexOptionsFor(flags) | RegexOptions.CultureInvariant, + MatchTimeout + ); + } + catch (RegexParseException error) + { + return Failure( + "compile", + "regex-parse-error", + error.Message, + error.Offset + ); + } + catch (ArgumentException error) + { + return Failure("compile", "regex-parse-error", error.Message); + } + + var numbers = expression.GetGroupNumbers(); + var groupCount = numbers.Length == 0 ? 0 : numbers.Max(); + if (groupCount > MaximumCaptureGroups) + return Failure( + "compile", + "capture-group-limit", + "The pattern exceeds the 1,000 capture-group bridge limit." + ); + var presentNumbers = numbers.ToHashSet(); + var groupNames = expression + .GetGroupNames() + .Select(name => (Name: name, Number: expression.GroupNumberFromName(name))) + .Where(item => + item.Number > 0 + && !int.TryParse( + item.Name, + NumberStyles.None, + CultureInfo.InvariantCulture, + out _ + ) + ) + .OrderBy(item => item.Number) + .ToArray(); + ReplacementProgram? replacementProgram = null; + if (operation == "replace") + { + try + { + replacementProgram = ReplacementProgram.Parse( + replacement, + expression, + presentNumbers + ); + } + catch (ArgumentException error) + { + return Failure( + "replacement", + "replacement-error", + error.Message + ); + } + } + + var records = new List(); + var captureRows = 0; + var resultsTruncated = false; + var global = flags.Contains('g'); + try + { + for (var match = expression.Match(subject); match.Success; match = match.NextMatch()) + { + var rows = Math.Max(1, groupCount); + if ( + records.Count >= maximumMatches + || captureRows + rows > maximumCaptureRows + ) + { + resultsTruncated = true; + break; + } + var captures = new NativeSpan?[groupCount]; + for (var number = 1; number <= groupCount; number++) + { + if (!presentNumbers.Contains(number)) + continue; + var group = match.Groups[number]; + if (group.Success) + captures[number - 1] = new NativeSpan( + group.Index, + group.Index + group.Length + ); + } + records.Add( + new MatchRecord( + new NativeSpan(match.Index, match.Index + match.Length), + captures, + match + ) + ); + captureRows += rows; + if (!global) + break; + } + } + catch (RegexMatchTimeoutException error) + { + return Failure("match", "match-timeout", error.Message); + } + + BoundedUtf8Output? output = null; + if (operation == "replace") + { + output = new BoundedUtf8Output(maximumOutputBytes); + var sourcePosition = 0; + try + { + foreach (var record in records.OrderBy(record => record.Span.Start)) + { + output.Append( + subject.AsSpan( + sourcePosition, + record.Span.Start - sourcePosition + ) + ); + AppendReplacement( + output, + subject, + record.Match, + replacementProgram! + ); + sourcePosition = record.Span.End; + } + output.Append(subject.AsSpan(sourcePosition)); + } + catch (ArgumentException error) + { + return Failure( + "replacement", + "replacement-error", + error.Message + ); + } + } + + return Success( + groupCount, + groupNames, + records, + resultsTruncated, + output + ); + } + catch (JsonException error) + { + return Failure("bridge", "invalid-json", error.Message); + } + catch (Exception error) + { + return Failure("bridge", "bridge-error", error.Message); + } + } + + private static RegexOptions RegexOptionsFor(string flags) + { + var options = RegexOptions.None; + foreach (var flag in flags) + options |= flag switch + { + 'g' => RegexOptions.None, + 'i' => RegexOptions.IgnoreCase, + 'm' => RegexOptions.Multiline, + 's' => RegexOptions.Singleline, + 'n' => RegexOptions.ExplicitCapture, + 'x' => RegexOptions.IgnorePatternWhitespace, + 'r' => RegexOptions.RightToLeft, + 'c' => RegexOptions.CultureInvariant, + 'b' => RegexOptions.NonBacktracking, + _ => throw new ArgumentException($"Unsupported .NET flag: {flag}."), + }; + return options; + } + + private static string RequiredString(JsonElement root, string name, int maximumLength) + { + if ( + !root.TryGetProperty(name, out var property) + || property.ValueKind != JsonValueKind.String + ) + throw new JsonException($"{name} must be a string."); + var value = property.GetString()!; + if (value.Length > maximumLength) + throw new JsonException($"{name} exceeds its bounded contract."); + return value; + } + + private static int RequiredInt(JsonElement root, string name) + { + if ( + !root.TryGetProperty(name, out var property) + || !property.TryGetInt32(out var value) + ) + throw new JsonException($"{name} must be a 32-bit integer."); + return value; + } + + private static string Failure( + string phase, + string code, + string message, + int? position = null + ) + { + using var stream = new MemoryStream(); + using (var writer = new Utf8JsonWriter(stream)) + { + writer.WriteStartObject(); + writer.WriteNumber("abi", AbiVersion); + writer.WriteBoolean("ok", false); + writer.WriteString("phase", phase); + writer.WriteString("code", code); + writer.WriteString( + "message", + message.Length <= 1_024 ? message : message[..1_024] + ); + if (position >= 0) + writer.WriteNumber("position", position.Value); + writer.WriteEndObject(); + } + return Encoding.UTF8.GetString(stream.ToArray()); + } + + private static string Success( + int groupCount, + IEnumerable<(string Name, int Number)> groupNames, + IEnumerable records, + bool resultsTruncated, + BoundedUtf8Output? output + ) + { + using var stream = new MemoryStream(); + using (var writer = new Utf8JsonWriter(stream)) + { + writer.WriteStartObject(); + writer.WriteNumber("abi", AbiVersion); + writer.WriteBoolean("ok", true); + writer.WriteNumber("groupCount", groupCount); + writer.WriteStartArray("groupNames"); + foreach (var group in groupNames) + { + writer.WriteStartArray(); + writer.WriteNumberValue(group.Number); + writer.WriteStringValue(group.Name); + writer.WriteEndArray(); + } + writer.WriteEndArray(); + writer.WriteStartArray("matches"); + foreach (var record in records) + { + writer.WriteStartObject(); + WriteSpan(writer, "span", record.Span); + writer.WriteStartArray("captures"); + foreach (var capture in record.Captures) + { + if (capture is { } span) + WriteSpan(writer, null, span); + else + writer.WriteNullValue(); + } + writer.WriteEndArray(); + writer.WriteEndObject(); + } + writer.WriteEndArray(); + writer.WriteBoolean("resultsTruncated", resultsTruncated); + if (output is not null) + { + writer.WriteBase64String("outputBase64", output.Bytes); + writer.WriteNumber("outputBytes", output.ByteCount); + writer.WriteBoolean("outputTruncated", output.Truncated); + } + writer.WriteEndObject(); + } + return Encoding.UTF8.GetString(stream.ToArray()); + } + + private static void WriteSpan( + Utf8JsonWriter writer, + string? propertyName, + NativeSpan span + ) + { + if (propertyName is null) + writer.WriteStartArray(); + else + writer.WriteStartArray(propertyName); + writer.WriteNumberValue(span.Start); + writer.WriteNumberValue(span.End); + writer.WriteEndArray(); + } + + private readonly record struct NativeSpan(int Start, int End); + + private sealed record MatchRecord( + NativeSpan Span, + NativeSpan?[] Captures, + Match Match + ); + + private static void AppendReplacement( + BoundedUtf8Output output, + string subject, + Match match, + ReplacementProgram replacement + ) + { + foreach (var token in replacement.Tokens) + { + switch (token.Kind) + { + case ReplacementTokenKind.Literal: + output.Append( + replacement.Template.AsSpan(token.Start, token.Length) + ); + break; + case ReplacementTokenKind.Group: + { + var group = match.Groups[token.GroupNumber]; + if (group.Success) + output.Append(subject.AsSpan(group.Index, group.Length)); + break; + } + case ReplacementTokenKind.LeftPortion: + output.Append(subject.AsSpan(0, match.Index)); + break; + case ReplacementTokenKind.RightPortion: + { + var start = match.Index + match.Length; + output.Append(subject.AsSpan(start)); + break; + } + case ReplacementTokenKind.LastGroup: + { + var group = match.Groups[replacement.LastGroupNumber]; + if (group.Success) + output.Append(subject.AsSpan(group.Index, group.Length)); + break; + } + case ReplacementTokenKind.WholeString: + output.Append(subject.AsSpan()); + break; + } + } + } + + private static bool ReplacementParitySelfTest() + { + try + { + var expression = new Regex( + "(?a)(b)?(?c)?", + RegexOptions.CultureInvariant, + MatchTimeout + ); + var presentNumbers = expression.GetGroupNumbers().ToHashSet(); + var templates = new[] + { + "$2:$1/${word}/${3}/$$/$&/$`/$'/$+/$_/$99/${missing}/$", + "${1}$01-$0", + "literal", + }; + for ( + var match = expression.Match("zab a"); + match.Success; + match = match.NextMatch() + ) + { + foreach (var template in templates) + { + var replacement = ReplacementProgram.Parse( + template, + expression, + presentNumbers + ); + var bounded = new BoundedUtf8Output(16 * 1024); + AppendReplacement( + bounded, + "zab a", + match, + replacement + ); + if ( + bounded.Truncated + || Encoding.UTF8.GetString(bounded.Bytes) + != match.Result(template) + ) + return false; + } + } + + try + { + _ = ReplacementProgram.Parse( + "$2147483648", + expression, + presentNumbers + ); + return false; + } + catch (ArgumentException) + { + try + { + _ = expression.Match("a").Result("$2147483648"); + return false; + } + catch (ArgumentException) + { + // Both parsers reject an overflowing numeric reference. + } + } + + var largeSubject = new string('a', 256 * 1024); + var largeExpression = new Regex( + "(a+)", + RegexOptions.CultureInvariant, + MatchTimeout + ); + var amplifyingTemplate = string.Concat( + Enumerable.Repeat("$1", 32_768) + ); + var amplifyingProgram = ReplacementProgram.Parse( + amplifyingTemplate, + largeExpression, + largeExpression.GetGroupNumbers().ToHashSet() + ); + var adversarial = new BoundedUtf8Output(5); + AppendReplacement( + adversarial, + largeSubject, + largeExpression.Match(largeSubject), + amplifyingProgram + ); + return adversarial.Truncated + && Encoding.UTF8.GetString(adversarial.Bytes) == "aaaaa"; + } + catch + { + return false; + } + } + + private enum ReplacementTokenKind + { + Literal, + Group, + LeftPortion, + RightPortion, + LastGroup, + WholeString, + } + + private readonly record struct ReplacementToken( + ReplacementTokenKind Kind, + int Start = 0, + int Length = 0, + int GroupNumber = 0 + ); + + private sealed record ReplacementProgram( + string Template, + ReplacementToken[] Tokens, + int LastGroupNumber + ) + { + public static ReplacementProgram Parse( + string template, + Regex expression, + HashSet presentNumbers + ) + { + var tokens = new List(); + var literalStart = 0; + var cursor = 0; + + void AddLiteral(int end) + { + if (end > literalStart) + tokens.Add( + new ReplacementToken( + ReplacementTokenKind.Literal, + literalStart, + end - literalStart + ) + ); + } + + void AddRecognized( + int dollar, + int end, + ReplacementToken token + ) + { + AddLiteral(dollar); + tokens.Add(token); + cursor = end; + literalStart = end; + } + + while (cursor < template.Length) + { + var dollar = template.IndexOf('$', cursor); + if (dollar < 0) + break; + if (dollar + 1 >= template.Length) + { + cursor = dollar + 1; + continue; + } + + var next = template[dollar + 1]; + if (next == '$') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.Literal, + dollar + 1, + 1 + ) + ); + continue; + } + if (next == '&') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.Group, + GroupNumber: 0 + ) + ); + continue; + } + if (next == '`') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.LeftPortion + ) + ); + continue; + } + if (next == '\'') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.RightPortion + ) + ); + continue; + } + if (next == '+') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.LastGroup + ) + ); + continue; + } + if (next == '_') + { + AddRecognized( + dollar, + dollar + 2, + new ReplacementToken( + ReplacementTokenKind.WholeString + ) + ); + continue; + } + + var angled = next == '{' && dollar + 2 < template.Length; + var referenceStart = dollar + (angled ? 2 : 1); + if ( + referenceStart < template.Length + && template[referenceStart] is >= '0' and <= '9' + ) + { + var number = 0; + var end = referenceStart; + while ( + end < template.Length + && template[end] is >= '0' and <= '9' + ) + { + var digit = template[end] - '0'; + if ( + number > int.MaxValue / 10 + || ( + number == int.MaxValue / 10 + && digit > int.MaxValue % 10 + ) + ) + throw new ArgumentException( + "A replacement capture number exceeds Int32.MaxValue." + ); + number = number * 10 + digit; + end++; + } + var syntaxComplete = + !angled + || ( + end < template.Length + && template[end] == '}' + ); + if (syntaxComplete && presentNumbers.Contains(number)) + { + AddRecognized( + dollar, + angled ? end + 1 : end, + new ReplacementToken( + ReplacementTokenKind.Group, + GroupNumber: number + ) + ); + continue; + } + } + else if ( + angled + && referenceStart < template.Length + && IsBoundaryWordCharacter(template[referenceStart]) + ) + { + var end = referenceStart + 1; + while ( + end < template.Length + && IsBoundaryWordCharacter(template[end]) + ) + end++; + if (end < template.Length && template[end] == '}') + { + var name = template[ + referenceStart..end + ]; + var number = expression.GroupNumberFromName(name); + if (number >= 0) + { + AddRecognized( + dollar, + end + 1, + new ReplacementToken( + ReplacementTokenKind.Group, + GroupNumber: number + ) + ); + continue; + } + } + } + + cursor = dollar + 1; + } + + AddLiteral(template.Length); + var numbers = expression.GetGroupNumbers(); + return new ReplacementProgram( + template, + tokens.ToArray(), + numbers.Length == 0 ? 0 : numbers[^1] + ); + } + + private static bool IsBoundaryWordCharacter(char value) + { + if (value is '\u200c' or '\u200d') + return true; + return CharUnicodeInfo.GetUnicodeCategory(value) switch + { + UnicodeCategory.UppercaseLetter => true, + UnicodeCategory.LowercaseLetter => true, + UnicodeCategory.TitlecaseLetter => true, + UnicodeCategory.ModifierLetter => true, + UnicodeCategory.OtherLetter => true, + UnicodeCategory.NonSpacingMark => true, + UnicodeCategory.DecimalDigitNumber => true, + UnicodeCategory.ConnectorPunctuation => true, + _ => false, + }; + } + } + + private sealed class BoundedUtf8Output(int maximumBytes) + { + private readonly ArrayBufferWriter _value = new(); + public int ByteCount => _value.WrittenCount; + public bool Truncated { get; private set; } + public ReadOnlySpan Bytes => _value.WrittenSpan; + + public void Append(ReadOnlySpan value) + { + if (Truncated) + return; + while (!value.IsEmpty) + { + var status = Rune.DecodeFromUtf16(value, out var rune, out var consumed); + if (status != OperationStatus.Done) + { + rune = Rune.ReplacementChar; + consumed = 1; + } + var width = rune.Utf8SequenceLength; + if (ByteCount + width > maximumBytes) + { + Truncated = true; + return; + } + var destination = _value.GetSpan(width); + var written = rune.EncodeToUtf8(destination); + _value.Advance(written); + value = value[consumed..]; + } + } + } +} diff --git a/engines/dotnet/README.md b/engines/dotnet/README.md new file mode 100644 index 0000000..1490330 --- /dev/null +++ b/engines/dotnet/README.md @@ -0,0 +1,26 @@ +# .NET regex engine + +This is a fixed `[JSExport]` bridge over .NET 10.0.10 +`System.Text.RegularExpressions`, built with SDK 10.0.302 for `browser-wasm`. +It always applies `RegexOptions.CultureInvariant` for deterministic local +results. Native match positions are UTF-16 offsets. The project uses +WebAssembly library mode because its `[JSExport]` methods are hosted directly +inside a module worker and do not require an executable entry point. + +The bridge receives one JSON value and never evaluates user input as managed or +JavaScript source. A nine-second native regex timeout complements the app's +shorter killable-worker deadline. Match, capture-row, pattern, subject and +replacement-output limits are enforced in managed code as a second boundary. +Replacement templates are parsed once by a fixed streaming implementation of +.NET's `$$`, numbered/named-group, whole-match, left/right-context, last-group +and whole-input tokens. Engine startup compares that implementation with +native `Match.Result` on a parity corpus. Successful output crosses the JS +export as bounded UTF-8 bytes in canonical base64, avoiding unbounded +intermediate replacement strings and JSON escaping amplification. + +Build from the pinned SDK plus `wasm-tools` workload: + +```sh +/absolute/path/to/dotnet publish engines/dotnet/RegexTools.DotNet.csproj \ + --configuration Release +``` diff --git a/engines/dotnet/RegexTools.DotNet.csproj b/engines/dotnet/RegexTools.DotNet.csproj new file mode 100644 index 0000000..9f4caed --- /dev/null +++ b/engines/dotnet/RegexTools.DotNet.csproj @@ -0,0 +1,19 @@ + + + net10.0 + true + Library + true + enable + enable + RegexTools.DotNet + RegexToolsDotNet + true + false + none + true + false + true + full + + diff --git a/engines/dotnet/wwwroot/main.js b/engines/dotnet/wwwroot/main.js new file mode 100644 index 0000000..abb304c --- /dev/null +++ b/engines/dotnet/wwwroot/main.js @@ -0,0 +1,2 @@ +// Fixed entry point retained by the WebAssembly SDK publish pipeline. +// Regex Tools imports _framework/dotnet.js directly inside its engine worker. diff --git a/engines/go/README.md b/engines/go/README.md new file mode 100644 index 0000000..ae8ccf3 --- /dev/null +++ b/engines/go/README.md @@ -0,0 +1,26 @@ +# Go regexp WebAssembly engine + +This directory is the fixed bridge around Go 1.26.5's standard-library +`regexp` package. It is compiled with the official `go1.26.5` toolchain for +`GOOS=js GOARCH=wasm`; `public/engines/go/wasm_exec.mjs` must come from that +same toolchain. + +The bridge accepts JSON data only. The adapter measures the exact encoded +request size, and the native cap includes JSON's worst-case sixfold escaping +for every accepted string field. It implements native RE2-family Go syntax, +native UTF-8 byte offsets, `SubexpNames`, `Find(All)StringSubmatchIndex`, and +`Regexp.ExpandString` replacement templates. Application flags `i`, `m`, `s` +and `U` become Go inline flags; `g` selects native global iteration. + +Replacement uses a bounded streaming implementation of `Regexp.ExpandString` +grammar. Load-time differential fixtures compare it with the native API, and +capture references stop expanding as soon as the UTF-8 output cap is reached. +The bounded bytes cross the JSON bridge as base64, so control-heavy output has +a fixed 4:3 transport expansion instead of JSON's content-dependent escaping. + +Go deliberately excludes look-around and backreferences. Its global iterator +also ignores an empty match that abuts the preceding match. Those behaviours +are tested rather than emulated. + +The bridge independently caps pattern, subject, match, capture-row and output +sizes. Replacement output is clipped only at a complete UTF-8 boundary. diff --git a/engines/go/go.mod b/engines/go/go.mod new file mode 100644 index 0000000..be07a11 --- /dev/null +++ b/engines/go/go.mod @@ -0,0 +1,5 @@ +module git.add-ideas.de/zemion/regex-tools/engines/go + +go 1.26.0 + +toolchain go1.26.5 diff --git a/engines/go/main.go b/engines/go/main.go new file mode 100644 index 0000000..5b89350 --- /dev/null +++ b/engines/go/main.go @@ -0,0 +1,521 @@ +// Regex Tools Go engine bridge. +// +// The WebAssembly module exposes two fixed callbacks. User-controlled values +// enter only through JSON data and are handed to the standard-library regexp +// package; no Go or JavaScript source is evaluated. +package main + +import ( + "bytes" + "encoding/base64" + "encoding/json" + "fmt" + "regexp" + "runtime" + "sort" + "strings" + "syscall/js" + "unicode" + "unicode/utf8" +) + +const ( + bridgeABIVersion = 1 + expectedGoVersion = "go1.26.5" + maximumPatternBytes = 256 * 1024 + maximumSubjectBytes = 16 * 1024 * 1024 + maximumReplacementBytes = 256 * 1024 + maximumMatches = 10_000 + maximumCaptureRows = 100_000 + maximumCaptureGroups = 1_000 + maximumOutputBytes = 64 * 1024 * 1024 + maximumRequestJSONBytes = 6*(maximumSubjectBytes+maximumPatternBytes+maximumReplacementBytes) + 64*1024 + maximumErrorMessageBytes = 1_024 + bridgeInstallerGlobalName = "__regexToolsInstallGoBridge" +) + +type bridgeRequest struct { + ABI int `json:"abi"` + Operation string `json:"operation"` + Pattern string `json:"pattern"` + Flags string `json:"flags"` + Options map[string]json.RawMessage `json:"options"` + Subject string `json:"subject"` + ScanAll bool `json:"scanAll"` + MaximumMatches int `json:"maximumMatches"` + MaximumCaptureRows int `json:"maximumCaptureRows"` + Replacement *string `json:"replacement,omitempty"` + MaximumOutputBytes *int `json:"maximumOutputBytes,omitempty"` +} + +type bridgeFailure struct { + ABI int `json:"abi"` + OK bool `json:"ok"` + Phase string `json:"phase"` + Code string `json:"code"` + Message string `json:"message"` + Position *int `json:"position,omitempty"` +} + +type nativeMatch struct { + Span [2]int `json:"span"` + Captures []*[2]int `json:"captures"` +} + +type bridgeSuccess struct { + ABI int `json:"abi"` + OK bool `json:"ok"` + GroupCount int `json:"groupCount"` + GroupNames [][2]any `json:"groupNames"` + Matches []nativeMatch `json:"matches"` + ResultsTruncated bool `json:"resultsTruncated"` + OutputBase64 *string `json:"outputBase64,omitempty"` + OutputBytes *int `json:"outputBytes,omitempty"` + OutputTruncated *bool `json:"outputTruncated,omitempty"` +} + +type identityEnvelope struct { + ABI int `json:"abi"` + OK bool `json:"ok"` + Identity map[string]any `json:"identity"` +} + +func boundedMessage(value string) string { + if len(value) <= maximumErrorMessageBytes { + return value + } + end := maximumErrorMessageBytes - len("…") + for end > 0 && !utf8.ValidString(value[:end]) { + end-- + } + return value[:end] + "…" +} + +func marshal(value any) string { + encoded, err := json.Marshal(value) + if err == nil { + return string(encoded) + } + fallback, _ := json.Marshal(bridgeFailure{ + ABI: bridgeABIVersion, + OK: false, + Phase: "bridge", + Code: "serialization-error", + Message: "The Go bridge could not serialize its bounded result.", + }) + return string(fallback) +} + +func failure(phase, code string, err any) string { + return marshal(bridgeFailure{ + ABI: bridgeABIVersion, + OK: false, + Phase: phase, + Code: code, + Message: boundedMessage(fmt.Sprint(err)), + }) +} + +func decodeRequest(encoded string) (bridgeRequest, string) { + var request bridgeRequest + if len(encoded) > maximumRequestJSONBytes { + return request, failure("bridge", "request-limit", "The encoded request exceeds the bridge limit.") + } + decoder := json.NewDecoder(strings.NewReader(encoded)) + decoder.DisallowUnknownFields() + if err := decoder.Decode(&request); err != nil { + return request, failure("bridge", "invalid-request", err) + } + if decoder.More() { + return request, failure("bridge", "invalid-request", "The encoded request contains trailing JSON values.") + } + return request, "" +} + +func validateRequest(request bridgeRequest) string { + if request.ABI != bridgeABIVersion { + return failure("bridge", "abi-mismatch", "The bridge ABI version is unsupported.") + } + if request.Operation != "execute" && request.Operation != "replace" { + return failure("bridge", "invalid-operation", "The bridge operation is unsupported.") + } + if len(request.Options) != 0 { + return failure("bridge", "unsupported-option", "Go regexp does not accept engine options.") + } + if !utf8.ValidString(request.Pattern) || len(request.Pattern) > maximumPatternBytes { + return failure("bridge", "pattern-limit", "The pattern is invalid UTF-8 or exceeds the bridge limit.") + } + if !utf8.ValidString(request.Subject) || len(request.Subject) > maximumSubjectBytes { + return failure("bridge", "subject-limit", "The subject is invalid UTF-8 or exceeds the bridge limit.") + } + if request.MaximumMatches < 1 || request.MaximumMatches > maximumMatches || + request.MaximumCaptureRows < 1 || request.MaximumCaptureRows > maximumCaptureRows { + return failure("bridge", "result-limit", "The requested result bounds are outside the bridge contract.") + } + seenFlags := make(map[rune]bool) + for _, flag := range request.Flags { + if !strings.ContainsRune("gimsU", flag) || seenFlags[flag] { + return failure("bridge", "unsupported-flag", "The request contains an unsupported or duplicate Go flag.") + } + seenFlags[flag] = true + } + if request.Operation == "execute" { + if request.Replacement != nil || request.MaximumOutputBytes != nil { + return failure("bridge", "invalid-request", "Execution requests cannot contain replacement fields.") + } + return "" + } + if request.Replacement == nil || request.MaximumOutputBytes == nil { + return failure("bridge", "invalid-request", "Replacement requests require a template and output bound.") + } + if !utf8.ValidString(*request.Replacement) || len(*request.Replacement) > maximumReplacementBytes { + return failure("bridge", "replacement-limit", "The replacement is invalid UTF-8 or exceeds the bridge limit.") + } + if *request.MaximumOutputBytes < 1 || *request.MaximumOutputBytes > maximumOutputBytes { + return failure("bridge", "output-limit", "The output bound is outside the bridge contract.") + } + return "" +} + +func compilePattern(pattern, flags string) (*regexp.Regexp, error) { + var modifiers strings.Builder + for _, flag := range "imsU" { + if strings.ContainsRune(flags, flag) { + modifiers.WriteRune(flag) + } + } + if modifiers.Len() != 0 { + pattern = "(?" + modifiers.String() + ")" + pattern + } + return regexp.Compile(pattern) +} + +func materializeMatch(indices []int, groupCount int) nativeMatch { + record := nativeMatch{ + Span: [2]int{indices[0], indices[1]}, + Captures: make([]*[2]int, groupCount), + } + for group := 0; group < groupCount; group++ { + start := indices[2+group*2] + end := indices[3+group*2] + if start >= 0 { + span := [2]int{start, end} + record.Captures[group] = &span + } + } + return record +} + +func collectMatches( + compiled *regexp.Regexp, + subject string, + global bool, + maximumMatchCount int, + maximumRows int, +) ([][]int, bool) { + rowsPerMatch := compiled.NumSubexp() + if rowsPerMatch < 1 { + rowsPerMatch = 1 + } + allowed := maximumMatchCount + if rowBound := maximumRows / rowsPerMatch; rowBound < allowed { + allowed = rowBound + } + probeLimit := allowed + 1 + var indices [][]int + if global { + indices = compiled.FindAllStringSubmatchIndex(subject, probeLimit) + } else if candidate := compiled.FindStringSubmatchIndex(subject); candidate != nil { + indices = [][]int{candidate} + } + if len(indices) <= allowed { + return indices, false + } + return indices[:allowed], true +} + +type boundedOutput struct { + buffer bytes.Buffer + maximum int + truncated bool +} + +func (output *boundedOutput) append(value string) { + if output.truncated || value == "" { + return + } + remaining := output.maximum - output.buffer.Len() + if len(value) <= remaining { + output.buffer.WriteString(value) + return + } + end := remaining + for end > 0 && !utf8.ValidString(value[:end]) { + end-- + } + output.buffer.WriteString(value[:end]) + output.truncated = true +} + +func extractReplacementReference(value string) (name string, number int, rest string, ok bool) { + if value == "" { + return + } + braced := false + if value[0] == '{' { + braced = true + value = value[1:] + } + index := 0 + for index < len(value) { + character, size := utf8.DecodeRuneInString(value[index:]) + if !unicode.IsLetter(character) && !unicode.IsDigit(character) && character != '_' { + break + } + index += size + } + if index == 0 { + return + } + name = value[:index] + if braced { + if index >= len(value) || value[index] != '}' { + return + } + index++ + } + + number = 0 + for position := 0; position < len(name); position++ { + if name[position] < '0' || name[position] > '9' || number >= 1e8 { + number = -1 + break + } + number = number*10 + int(name[position]) - '0' + } + if name[0] == '0' && len(name) > 1 { + number = -1 + } + rest = value[index:] + ok = true + return +} + +func expandReplacementBounded( + output *boundedOutput, + compiled *regexp.Regexp, + template, subject string, + match []int, +) { + for len(template) > 0 && !output.truncated { + before, after, found := strings.Cut(template, "$") + if !found { + break + } + output.append(before) + if output.truncated { + return + } + template = after + if template != "" && template[0] == '$' { + output.append("$") + template = template[1:] + continue + } + name, number, rest, ok := extractReplacementReference(template) + if !ok { + output.append("$") + continue + } + template = rest + if number >= 0 { + if 2*number+1 < len(match) && match[2*number] >= 0 { + output.append(subject[match[2*number]:match[2*number+1]]) + } + continue + } + for index, candidate := range compiled.SubexpNames() { + if name == candidate && 2*index+1 < len(match) && match[2*index] >= 0 { + output.append(subject[match[2*index]:match[2*index+1]]) + break + } + } + } + output.append(template) +} + +func replaceBounded( + compiled *regexp.Regexp, + subject, replacement string, + indices [][]int, + maximumBytes int, +) (string, int, bool) { + output := boundedOutput{maximum: maximumBytes} + cursor := 0 + for _, match := range indices { + output.append(subject[cursor:match[0]]) + expandReplacementBounded(&output, compiled, replacement, subject, match) + cursor = match[1] + } + output.append(subject[cursor:]) + value := output.buffer.Bytes() + return base64.StdEncoding.EncodeToString(value), len(value), output.truncated +} + +func run(encoded string) string { + request, requestError := decodeRequest(encoded) + if requestError != "" { + return requestError + } + if validationError := validateRequest(request); validationError != "" { + return validationError + } + + compiled, err := compilePattern(request.Pattern, request.Flags) + if err != nil { + return failure("compile", "compile-error", err) + } + groupCount := compiled.NumSubexp() + if groupCount > maximumCaptureGroups { + return failure( + "compile", + "capture-group-limit", + fmt.Sprintf("The pattern declares %d capture groups; the bridge limit is %d.", groupCount, maximumCaptureGroups), + ) + } + + names := make([][2]any, 0) + for number, name := range compiled.SubexpNames() { + if number > 0 && name != "" { + names = append(names, [2]any{number, name}) + } + } + sort.Slice(names, func(left, right int) bool { + return names[left][0].(int) < names[right][0].(int) + }) + + global := strings.ContainsRune(request.Flags, 'g') + indices, resultsTruncated := collectMatches( + compiled, + request.Subject, + global, + request.MaximumMatches, + request.MaximumCaptureRows, + ) + records := make([]nativeMatch, len(indices)) + for index, match := range indices { + records[index] = materializeMatch(match, groupCount) + } + result := bridgeSuccess{ + ABI: bridgeABIVersion, + OK: true, + GroupCount: groupCount, + GroupNames: names, + Matches: records, + ResultsTruncated: resultsTruncated, + } + if request.Operation == "replace" { + outputBase64, outputBytes, outputTruncated := replaceBounded( + compiled, + request.Subject, + *request.Replacement, + indices, + *request.MaximumOutputBytes, + ) + result.OutputBase64 = &outputBase64 + result.OutputBytes = &outputBytes + result.OutputTruncated = &outputTruncated + } + return marshal(result) +} + +func selfTest() bool { + if runtime.Version() != expectedGoVersion { + return false + } + compiled, err := regexp.Compile(`(?P😀+)`) + if err != nil { + return false + } + match := compiled.FindStringSubmatchIndex("x😀😀") + if len(match) != 4 || match[0] != 1 || match[1] != 9 || + match[2] != 1 || match[3] != 9 || compiled.SubexpNames()[1] != "word" { + return false + } + for _, template := range []string{ + `${word}-$1-$$`, + `$1x|${1}x`, + `${missing}|$|${word`, + `$01|${01}|$1234567890`, + } { + expected := string(compiled.ExpandString(nil, template, "x😀😀", match)) + bounded := boundedOutput{maximum: 4 * 1024} + expandReplacementBounded(&bounded, compiled, template, "x😀😀", match) + if bounded.truncated || bounded.buffer.String() != expected { + return false + } + } + adversarial := boundedOutput{maximum: 5} + expandReplacementBounded( + &adversarial, + compiled, + strings.Repeat("$word", 32*1024), + "x😀😀", + match, + ) + if !adversarial.truncated || adversarial.buffer.String() != "😀" { + return false + } + empty := regexp.MustCompile("a*").FindAllStringIndex("baaab", -1) + return len(empty) == 3 && + empty[0][0] == 0 && empty[0][1] == 0 && + empty[1][0] == 1 && empty[1][1] == 4 && + empty[2][0] == 5 && empty[2][1] == 5 +} + +func identity() string { + return marshal(identityEnvelope{ + ABI: bridgeABIVersion, + OK: true, + Identity: map[string]any{ + "bridge": "regex-tools-go-json", + "bridgeVersion": bridgeABIVersion, + "engine": "Go standard-library regexp", + "engineVersion": "1.26.5", + "goVersion": runtime.Version(), + "offsetUnit": "utf8-byte", + "package": "regexp", + "selfTest": selfTest(), + }, + }) +} + +var retainedCallbacks []js.Func + +func main() { + identityCallback := js.FuncOf(func(_ js.Value, arguments []js.Value) any { + if len(arguments) != 0 { + return failure("bridge", "invalid-request", "The identity callback does not accept arguments.") + } + return identity() + }) + runCallback := js.FuncOf(func(_ js.Value, arguments []js.Value) (result any) { + defer func() { + if recovered := recover(); recovered != nil { + result = failure("bridge", "panic", "The Go bridge stopped an unexpected internal panic.") + } + }() + if len(arguments) != 1 || arguments[0].Type() != js.TypeString { + return failure("bridge", "invalid-request", "The run callback requires one JSON string.") + } + return run(arguments[0].String()) + }) + retainedCallbacks = []js.Func{identityCallback, runCallback} + + installer := js.Global().Get(bridgeInstallerGlobalName) + if installer.Type() != js.TypeFunction { + panic("Regex Tools Go bridge installer is unavailable") + } + installer.Invoke(identityCallback, runCallback) + select {} +} diff --git a/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt b/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt new file mode 100644 index 0000000..55cfbd6 --- /dev/null +++ b/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt @@ -0,0 +1,207 @@ +This software is Copyright (c) 2000 - 2017 by David Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + + The Artistic License 2.0 + + Copyright (c) 2000-2006, The Perl Foundation. + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +Preamble + +This license establishes the terms under which a given free software +Package may be copied, modified, distributed, and/or redistributed. +The intent is that the Copyright Holder maintains some artistic +control over the development of that Package while still keeping the +Package available as open source and free software. + +You are always permitted to make arrangements wholly outside of this +license directly with the Copyright Holder of a given Package. If the +terms of this license do not permit the full use that you propose to +make of the Package, you should contact the Copyright Holder and seek +a different licensing arrangement. + +Definitions + + "Copyright Holder" means the individual(s) or organization(s) + named in the copyright notice for the entire Package. + + "Contributor" means any party that has contributed code or other + material to the Package, in accordance with the Copyright Holder's + procedures. + + "You" and "your" means any person who would like to copy, + distribute, or modify the Package. + + "Package" means the collection of files distributed by the + Copyright Holder, and derivatives of that collection and/or of + those files. A given Package may consist of either the Standard + Version, or a Modified Version. + + "Distribute" means providing a copy of the Package or making it + accessible to anyone else, or in the case of a company or + organization, to others outside of your company or organization. + + "Distributor Fee" means any fee that you charge for Distributing + this Package or providing support for this Package to another + party. It does not mean licensing fees. + + "Standard Version" refers to the Package if it has not been + modified, or has been modified only in ways explicitly requested + by the Copyright Holder. + + "Modified Version" means the Package, if it has been changed, and + such changes were not explicitly requested by the Copyright + Holder. + + "Original License" means this Artistic License as Distributed with + the Standard Version of the Package, in its current version or as + it may be modified by The Perl Foundation in the future. + + "Source" form means the source code, documentation source, and + configuration files for the Package. + + "Compiled" form means the compiled bytecode, object code, binary, + or any other form resulting from mechanical transformation or + translation of the Source form. + + +Permission for Use and Modification Without Distribution + +(1) You are permitted to use the Standard Version and create and use +Modified Versions for any purpose without restriction, provided that +you do not Distribute the Modified Version. + + +Permissions for Redistribution of the Standard Version + +(2) You may Distribute verbatim copies of the Source form of the +Standard Version of this Package in any medium without restriction, +either gratis or for a Distributor Fee, provided that you duplicate +all of the original copyright notices and associated disclaimers. At +your discretion, such verbatim copies may or may not include a +Compiled form of the Package. + +(3) You may apply any bug fixes, portability changes, and other +modifications made available from the Copyright Holder. The resulting +Package will still be considered the Standard Version, and as such +will be subject to the Original License. + + +Distribution of Modified Versions of the Package as Source + +(4) You may Distribute your Modified Version as Source (either gratis +or for a Distributor Fee, and with or without a Compiled form of the +Modified Version) provided that you clearly document how it differs +from the Standard Version, including, but not limited to, documenting +any non-standard features, executables, or modules, and provided that +you do at least ONE of the following: + + (a) make the Modified Version available to the Copyright Holder + of the Standard Version, under the Original License, so that the + Copyright Holder may include your modifications in the Standard + Version. + + (b) ensure that installation of your Modified Version does not + prevent the user installing or running the Standard Version. In + addition, the Modified Version must bear a name that is different + from the name of the Standard Version. + + (c) allow anyone who receives a copy of the Modified Version to + make the Source form of the Modified Version available to others + under + + (i) the Original License or + + (ii) a license that permits the licensee to freely copy, + modify and redistribute the Modified Version using the same + licensing terms that apply to the copy that the licensee + received, and requires that the Source form of the Modified + Version, and of any works derived from it, be made freely + available in that license fees are prohibited but Distributor + Fees are allowed. + + +Distribution of Compiled Forms of the Standard Version +or Modified Versions without the Source + +(5) You may Distribute Compiled forms of the Standard Version without +the Source, provided that you include complete instructions on how to +get the Source of the Standard Version. Such instructions must be +valid at the time of your distribution. If these instructions, at any +time while you are carrying out such distribution, become invalid, you +must provide new instructions on demand or cease further distribution. +If you provide valid instructions or cease distribution within thirty +days after you become aware that the instructions are invalid, then +you do not forfeit any of your rights under this license. + +(6) You may Distribute a Modified Version in Compiled form without +the Source, provided that you comply with Section 4 with respect to +the Source of the Modified Version. + + +Aggregating or Linking the Package + +(7) You may aggregate the Package (either the Standard Version or +Modified Version) with other packages and Distribute the resulting +aggregation provided that you do not charge a licensing fee for the +Package. Distributor Fees are permitted, and licensing fees for other +components in the aggregation are permitted. The terms of this license +apply to the use and Distribution of the Standard or Modified Versions +as included in the aggregation. + +(8) You are permitted to link Modified and Standard Versions with +other works, to embed the Package in a larger work of your own, or to +build stand-alone binary or bytecode versions of applications that +include the Package, and Distribute the result without restriction, +provided the result does not expose a direct interface to the Package. + + +Items That are Not Considered Part of a Modified Version + +(9) Works (including, but not limited to, modules and scripts) that +merely extend or make use of the Package, do not, by themselves, cause +the Package to be a Modified Version. In addition, such works are not +considered parts of the Package itself, and are not subject to the +terms of this license. + + +General Provisions + +(10) Any use, modification, and distribution of the Standard or +Modified Versions is governed by this Artistic License. By using, +modifying or distributing the Package, you accept this license. Do not +use, modify, or distribute the Package, if you do not accept this +license. + +(11) If your Modified Version has been derived from a Modified +Version made by someone other than you, you are nevertheless required +to ensure that your Modified Version complies with the requirements of +this license. + +(12) This license does not grant you the right to use any trademark, +service mark, tradename, or logo of the Copyright Holder. + +(13) This license includes the non-exclusive, worldwide, +free-of-charge patent license to make, have made, use, offer to sell, +sell, import and otherwise transfer the Package with respect to any +patent claims licensable by the Copyright Holder that are necessarily +infringed by the Package. If you institute patent litigation +(including a cross-claim or counterclaim) against any party alleging +that the Package constitutes direct or contributory patent +infringement, then this Artistic License to you shall terminate on the +date that such litigation is filed. + +(14) Disclaimer of Warranty: +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/perl/LICENSE-Emscripten.txt b/engines/perl/LICENSE-Emscripten.txt new file mode 100644 index 0000000..a1fe6bf --- /dev/null +++ b/engines/perl/LICENSE-Emscripten.txt @@ -0,0 +1,101 @@ +Emscripten is available under 2 licenses, the MIT license and the +University of Illinois/NCSA Open Source License. + +Both are permissive open source licenses, with little if any +practical difference between them. + +The reason for offering both is that (1) the MIT license is +well-known, while (2) the University of Illinois/NCSA Open Source +License allows Emscripten's code to be integrated upstream into +LLVM, which uses that license, should the opportunity arise. + +The full text of both licenses follows. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following disclaimers + in the documentation and/or other materials provided with the + distribution. + + Neither the names of Mozilla, + nor the names of its contributors may be used to endorse + or promote products derived from this Software without specific prior + written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + +============================================================================== + +This program uses portions of Node.js source code located in src/library_path.js, +in accordance with the terms of the MIT license. Node's license follows: + + """ + Copyright Joyent, Inc. and other Node contributors. All rights reserved. + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. + """ + +The musl libc project is bundled in this repo, and it has the MIT license, see +system/lib/libc/musl/COPYRIGHT + +The third_party/ subdirectory contains code with other licenses. None of it is +used by default, but certain options use it (e.g., the optional closure compiler +flag will run closure compiler from third_party/). diff --git a/engines/perl/NOTICE.txt b/engines/perl/NOTICE.txt new file mode 100644 index 0000000..084dae3 --- /dev/null +++ b/engines/perl/NOTICE.txt @@ -0,0 +1,68 @@ +Legacy WebPerl runtime notices +============================== + +This directory contains the unmodified WebPerl v0.09-beta prebuilt runtime, +released in 2019 and explicitly treated by regex-tools as legacy beta software. + +WebPerl +------- + +Project: https://github.com/haukex/webperl +Release: v0.09-beta +Commit: 6f2173d29a2c2e3536e1de75ff5d291ae96ab348 +Copyright (c) 2018 Hauke Daempfling, Leibniz Institute of Freshwater Ecology +and Inland Fisheries (IGB), Berlin, Germany. + +WebPerl is distributed under the same terms as Perl 5: either the GNU General +Public License version 1 or later, or the Artistic License supplied with Perl 5. +The complete upstream texts are included as LICENSE-WebPerl-GPL.txt and +LICENSE-WebPerl-Artistic.txt. + +Perl +---- + +The binary and data pack contain Perl v5.28.1 and its core library. Perl 5 is +distributed under the same GNU GPL / Artistic dual-license terms described +above. Exact upstream source is available from: + +https://github.com/Perl/perl5/tree/v5.28.1 + +Emscripten +---------- + +The generated loader and WebAssembly runtime were built by upstream WebPerl +with Emscripten 1.38.28. Emscripten is dual-licensed under the MIT and +University of Illinois/NCSA licenses. The upstream 1.38.28 license text, +including its bundled-code notices, is included as LICENSE-Emscripten.txt. + +Bundled CPAN additions +---------------------- + +The upstream prebuilt data pack also contains the modules selected by +WebPerl's pinned build: + +- Cpanel::JSON::XS 4.09 — same terms as Perl 5; +- Devel::StackTrace 2.03 — Artistic License 2.0; its upstream distribution + license is included as LICENSE-Devel-StackTrace-Artistic-2.0.txt; and +- Future 0.39 — same terms as Perl 5. + +The Devel::StackTrace license was reproduced byte-for-byte from +https://www.cpan.org/authors/id/D/DR/DROLSKY/Devel-StackTrace-2.03.tar.gz +(SHA-256 7618cd4ebe24e254c17085f4b418784ab503cb4cb3baf8f48a7be894e59ba848). + +regex-tools uses Cpanel::JSON::XS only as the fixed bridge's bounded JSON +codec. It does not load Devel::StackTrace, Future, or WebPerl's JavaScript +interop module on the normal engine path. Those files remain present because +emperl.data is the unmodified, checksummed upstream prebuilt pack. + +Security boundary +----------------- + +The upstream generated emperl.js has one JavaScript eval(code) call in the +optional WebPerl JavaScript-interoperability import. regex-tools neither loads +nor calls that Perl module. User values cross the fixed bridge only as +exact-key, byte-bounded JSON in MEMFS; the sole Perl evaluator invocation is +the constant RegexTools::run_request(). The bounded metadata response is JSON, +while successful replacement UTF-8 bytes use a separate fixed MEMFS binary +file with exact worker-side length and encoding verification. Perl's +runtime-regex eval mode and regex code assertions are disabled. diff --git a/engines/perl/README.md b/engines/perl/README.md new file mode 100644 index 0000000..c95220f --- /dev/null +++ b/engines/perl/README.md @@ -0,0 +1,66 @@ +# Legacy Perl engine + +This engine uses the unmodified prebuilt WebPerl `v0.09-beta` distribution, +which contains Perl `v5.28.1` compiled by Emscripten `1.38.28`. It is an +explicitly legacy, beta compatibility target. It is not current desktop Perl. + +## Trust boundary + +`regex_tools_bridge.pl` is fixed application source. The classic runtime worker +writes each exact-key, byte-bounded request as JSON to a fixed MEMFS path and +invokes only the constant Perl expression `RegexTools::run_request()`. The +metadata-only response uses a second bounded JSON file. Successful replacement +bytes use a third, fixed binary file; the worker checks its exact declared +length, output bound and canonical UTF-8 before supplying the decoded string to +the adapter. Pattern, subject, flags and replacement values are never +interpolated into Perl or JavaScript source. + +The bridge: + +- compiles a scalar pattern with `no re 'eval'`; +- independently rejects `(?{...})` and `(??{...})` outside escaped literals + and character classes; +- never imports the WebPerl JavaScript interoperability module; +- pre-tokenizes a deliberately bounded replacement grammar consisting of + literal text, `$$`, greedy `$n` and `${name}`; +- streams unmatched spans, literals and native capture values to the binary + output file in small UTF-8 chunks, stopping before a code point would cross + the output-byte bound; +- stops replacement at the match/capture-row result bound and preserves the + remaining subject as an unchanged tail; +- compares fixed named and numbered streaming fixtures with native Perl + `s///` output during the identity self-test; +- validates every request again inside Perl; and +- reports native Perl character offsets as Unicode code-point offsets. + +Numbered capture participation and spans come from Perl's native `@-` and `@+` +arrays. The legacy runtime does not expose a stable name-to-number table, so +the adapter annotates those native capture rows with names from regex-tools' +syntax metadata. Numbered replacement values are streamed directly from their +native spans. Named replacement lookup itself uses Perl's native `%+`, and only +names present in the pre-tokenized template are read. + +The prebuilt `emperl.js` contains one JavaScript `eval(code)` site in its +optional Perl-to-JavaScript interoperability import. The fixed bridge does not +load or call that facility. A Chromium CSP smoke succeeds with +`script-src 'self' 'wasm-unsafe-eval'` and without `'unsafe-eval'`. + +The module worker remains responsive while the nested classic worker executes. +Terminating the supervised module worker terminates its worker descendants, so +catastrophic matching remains killable. + +## Provenance + +- WebPerl release: `v0.09-beta` +- Release commit: `6f2173d29a2c2e3536e1de75ff5d291ae96ab348` +- Prebuilt archive: + `https://github.com/haukex/webperl/releases/download/v0.09-beta/webperl_prebuilt_v0.09-beta.zip` +- Archive SHA-256: + `5f441249217e90ab378c666f473d4206ab4f44907f6bb0aa8d70834bc38c40dc` +- Perl runtime identity: `v5.28.1` +- Emscripten toolchain identified by the pinned upstream build configuration: + `1.38.28` + +The deployed `emperl.js`, `emperl.wasm` and `emperl.data` files are copied +byte-for-byte from that archive. See `public/engines/perl/engine-metadata.json`, +`NOTICE.txt`, and the adjacent license files. diff --git a/engines/perl/perl-runtime.worker.js b/engines/perl/perl-runtime.worker.js new file mode 100644 index 0000000..33ca67f --- /dev/null +++ b/engines/perl/perl-runtime.worker.js @@ -0,0 +1,367 @@ +"use strict"; + +/* + * Classic-worker wrapper for the pinned WebPerl 0.09-beta Emscripten runtime. + * User-controlled values cross into Perl only through a JSON file in MEMFS. + * Successful replacement bytes return through a separate fixed binary file; + * the bounded JSON response contains metadata only. + * The sole call through WebPerl's eval export is the fixed source string + * "RegexTools::run_request()"; no request data is interpolated into code. + */ + +var BRIDGE_PROTOCOL_VERSION = 1; +var REQUEST_PATH = "/tmp/regex-tools-request.json"; +var RESPONSE_PATH = "/tmp/regex-tools-response.json"; +var OUTPUT_PATH = "/tmp/regex-tools-output.bin"; +var HARNESS_PATH = "/tmp/regex-tools-bridge.pl"; +var FIXED_INVOCATION = "RegexTools::run_request()"; +var MAXIMUM_PATTERN_CHARACTERS = 64 * 1024; +var MAXIMUM_SUBJECT_BYTES = 16 * 1024 * 1024; +var MAXIMUM_REPLACEMENT_CHARACTERS = 64 * 1024; +var MAXIMUM_MATCHES = 10000; +var MAXIMUM_CAPTURE_ROWS = 100000; +var MAXIMUM_OUTPUT_BYTES = 64 * 1024 * 1024; +var MAXIMUM_REQUEST_JSON_BYTES = + 6 * + (MAXIMUM_SUBJECT_BYTES + + MAXIMUM_PATTERN_CHARACTERS + + MAXIMUM_REPLACEMENT_CHARACTERS) + + 16 * 1024; +var MAXIMUM_RESPONSE_JSON_BYTES = 8 * 1024 * 1024; +var utf8Encoder = new TextEncoder(); +var runtimeRoot = new URL("./", self.location.href); +var runtimeResolve; +var runtimeReject; +var runtimeReady = new Promise(function (resolve, reject) { + runtimeResolve = resolve; + runtimeReject = reject; +}); +var stderrTail = ""; + +function boundedRuntimeError(value) { + var message = value instanceof Error ? value.message : String(value); + if (stderrTail) { + message += " (" + stderrTail.slice(-512) + ")"; + } + return message.slice(0, 1024); +} + +function captureStderr(value) { + stderrTail = (stderrTail + String(value) + "\n").slice(-4096); +} + +function isRecord(value) { + return typeof value === "object" && value !== null && !Array.isArray(value); +} + +function owns(value, key) { + return Object.prototype.hasOwnProperty.call(value, key); +} + +function isIntegerInRange(value, minimum, maximum) { + return Number.isSafeInteger(value) && value >= minimum && value <= maximum; +} + +function hasExactKeys(value, expected) { + var actual = Object.keys(value).sort(); + var wanted = expected.slice().sort(); + if (actual.length !== wanted.length) return false; + for (var index = 0; index < actual.length; index += 1) { + if (actual[index] !== wanted[index]) return false; + } + return true; +} + +function encodeRequest(request) { + if ( + !isRecord(request) || + request.abi !== 1 || + typeof request.operation !== "string" + ) { + throw new Error("The WebPerl bridge request is invalid."); + } + if (request.operation === "identity") { + if (!hasExactKeys(request, ["abi", "operation"])) { + throw new Error("The WebPerl identity request is invalid."); + } + } else { + var replacement = request.operation === "replace"; + if ( + (!replacement && request.operation !== "execute") || + !hasExactKeys( + request, + [ + "abi", + "operation", + "pattern", + "flags", + "options", + "subject", + "scanAll", + "maximumMatches", + "maximumCaptureRows", + ].concat(replacement ? ["replacement", "maximumOutputBytes"] : []), + ) || + typeof request.pattern !== "string" || + request.pattern.length > MAXIMUM_PATTERN_CHARACTERS || + typeof request.flags !== "string" || + request.flags.length > 10 || + typeof request.subject !== "string" || + typeof request.scanAll !== "boolean" || + !isRecord(request.options) || + Object.keys(request.options).length !== 0 || + !isIntegerInRange(request.maximumMatches, 1, MAXIMUM_MATCHES) || + !isIntegerInRange(request.maximumCaptureRows, 1, MAXIMUM_CAPTURE_ROWS) + ) { + throw new Error("The WebPerl execution request is invalid."); + } + if ( + utf8Encoder.encode(request.subject).byteLength > MAXIMUM_SUBJECT_BYTES + ) { + throw new Error("The WebPerl subject exceeds its UTF-8 byte limit."); + } + if ( + replacement && + (typeof request.replacement !== "string" || + request.replacement.length > MAXIMUM_REPLACEMENT_CHARACTERS || + !isIntegerInRange(request.maximumOutputBytes, 1, MAXIMUM_OUTPUT_BYTES)) + ) { + throw new Error("The WebPerl replacement request is invalid."); + } + } + var encoded = utf8Encoder.encode(JSON.stringify(request)); + if (encoded.byteLength > MAXIMUM_REQUEST_JSON_BYTES) { + throw new Error("The WebPerl request exceeds its JSON byte limit."); + } + return encoded; +} + +function decodeUtf8Exact(encoded, label) { + var decoded; + try { + decoded = new TextDecoder("utf-8", { fatal: true }).decode(encoded); + } catch (_error) { + throw new Error(label + " is not valid UTF-8."); + } + var roundTrip = utf8Encoder.encode(decoded); + if (roundTrip.byteLength !== encoded.byteLength) { + throw new Error(label + " has an inconsistent UTF-8 length."); + } + for (var index = 0; index < encoded.byteLength; index += 1) { + if (roundTrip[index] !== encoded[index]) { + throw new Error(label + " is not canonical UTF-8."); + } + } + return decoded; +} + +function readResponse() { + var encoded = FS.readFile(RESPONSE_PATH); + if ( + Object.prototype.toString.call(encoded) !== "[object Uint8Array]" || + encoded.byteLength === 0 || + encoded.byteLength > MAXIMUM_RESPONSE_JSON_BYTES + ) { + throw new Error("The fixed Perl bridge response exceeds its byte limit."); + } + var parsed; + try { + parsed = JSON.parse(decodeUtf8Exact(encoded, "The WebPerl response")); + } catch (error) { + if (error instanceof SyntaxError) { + throw new Error("The fixed Perl bridge returned malformed JSON."); + } + throw error; + } + if (!isRecord(parsed)) { + throw new Error("The fixed Perl bridge returned a non-object response."); + } + return parsed; +} + +function injectReplacementOutput(response, maximumOutputBytes) { + if ( + owns(response, "output") || + !isIntegerInRange(response.outputBytes, 0, maximumOutputBytes) || + typeof response.outputTruncated !== "boolean" + ) { + throw new Error("The fixed Perl bridge returned invalid output metadata."); + } + var encoded = FS.readFile(OUTPUT_PATH); + if ( + Object.prototype.toString.call(encoded) !== "[object Uint8Array]" || + encoded.byteLength !== response.outputBytes || + encoded.byteLength > maximumOutputBytes + ) { + throw new Error( + "The fixed Perl bridge output file exceeds its bounded contract.", + ); + } + response.output = decodeUtf8Exact(encoded, "The WebPerl output file"); +} + +function removeFixedFile(path) { + try { + FS.unlink(path); + } catch (_error) { + // The fixed file does not exist before its first use. + } +} + +var Perl = { + trace: false, + glue: function () { + throw new Error("The WebPerl JavaScript bridge is disabled."); + }, + unglue: function () { + throw new Error("The WebPerl JavaScript bridge is disabled."); + }, +}; + +var Module = { + noInitialRun: true, + noExitRuntime: true, + arguments: ["--version"], + print: function () {}, + printErr: captureStderr, + stdout: function () {}, + stderr: function (character) { + if (character) { + stderrTail = (stderrTail + String.fromCharCode(character)).slice(-4096); + } + }, + stdin: function () { + return null; + }, + locateFile: function (file) { + return new URL(file, runtimeRoot).href; + }, + preRun: [], + onRuntimeInitialized: function () { + runtimeResolve(); + }, + onAbort: function (reason) { + runtimeReject( + new Error("The legacy WebPerl runtime aborted: " + String(reason)), + ); + }, +}; + +importScripts(new URL("emperl.js", runtimeRoot).href); + +var harnessPromise; + +async function loadHarness() { + if (harnessPromise) return harnessPromise; + harnessPromise = (async function () { + await runtimeReady; + var response = await fetch(new URL("regex_tools_bridge.pl", runtimeRoot)); + if (!response.ok) { + throw new Error( + "The fixed Perl bridge request failed with HTTP " + + response.status + + ".", + ); + } + var source = await response.text(); + FS.writeFile(HARNESS_PATH, source, { encoding: "utf8" }); + Module.callMain([HARNESS_PATH]); + return true; + })(); + return harnessPromise; +} + +async function invokeHarness(request) { + stderrTail = ""; + await loadHarness(); + if (stderrTail) { + throw new Error("The fixed Perl bridge failed to load: " + stderrTail); + } + removeFixedFile(REQUEST_PATH); + removeFixedFile(RESPONSE_PATH); + removeFixedFile(OUTPUT_PATH); + try { + FS.writeFile(REQUEST_PATH, encodeRequest(request)); + var status = Module.ccall( + "webperl_eval_perl", + "string", + ["string"], + [FIXED_INVOCATION], + ); + if (status !== "ok") { + throw new Error("The fixed Perl bridge returned an invalid status."); + } + var parsed = readResponse(); + if (request.operation === "replace" && parsed.ok === true) { + injectReplacementOutput(parsed, request.maximumOutputBytes); + } else if ( + owns(parsed, "output") || + owns(parsed, "outputBytes") || + owns(parsed, "outputTruncated") + ) { + throw new Error( + "The fixed Perl bridge returned output for a non-replacement result.", + ); + } + return parsed; + } finally { + removeFixedFile(REQUEST_PATH); + removeFixedFile(RESPONSE_PATH); + removeFixedFile(OUTPUT_PATH); + } +} + +async function handleMessage(message) { + if ( + !message || + message.protocolVersion !== BRIDGE_PROTOCOL_VERSION || + !Number.isSafeInteger(message.requestId) + ) { + throw new Error("The WebPerl bridge received an invalid message."); + } + if (message.kind === "load") { + return invokeHarness({ abi: 1, operation: "identity" }); + } + if (message.kind === "run") { + if ( + !message.request || + typeof message.request !== "object" || + Array.isArray(message.request) + ) { + throw new Error("The WebPerl bridge received an invalid request."); + } + return invokeHarness(message.request); + } + throw new Error("The WebPerl bridge operation is unsupported."); +} + +var operationQueue = Promise.resolve(); + +self.onmessage = function (event) { + var message = event.data; + var current = operationQueue.then(function () { + return handleMessage(message); + }); + operationQueue = current.catch(function () {}); + current.then( + function (payload) { + self.postMessage({ + protocolVersion: BRIDGE_PROTOCOL_VERSION, + requestId: message && message.requestId, + ok: true, + payload: payload, + }); + }, + function (error) { + self.postMessage({ + protocolVersion: BRIDGE_PROTOCOL_VERSION, + requestId: message && message.requestId, + ok: false, + error: { + name: error instanceof Error ? error.name : "Error", + message: boundedRuntimeError(error), + }, + }); + }, + ); +}; diff --git a/engines/perl/regex_tools_bridge.pl b/engines/perl/regex_tools_bridge.pl new file mode 100644 index 0000000..22b760a --- /dev/null +++ b/engines/perl/regex_tools_bridge.pl @@ -0,0 +1,753 @@ +package RegexTools; + +use strict; +use warnings; +use utf8; +use Cpanel::JSON::XS (); +no re 'eval'; + +our $BRIDGE_ABI_VERSION = 1; +our $REQUEST_PATH = '/tmp/regex-tools-request.json'; +our $RESPONSE_PATH = '/tmp/regex-tools-response.json'; +our $OUTPUT_PATH = '/tmp/regex-tools-output.bin'; + +my $JSON = Cpanel::JSON::XS->new->utf8->canonical; +my $TRUE = Cpanel::JSON::XS::true; +my $FALSE = Cpanel::JSON::XS::false; + +my $MAXIMUM_PATTERN_CHARACTERS = 64 * 1024; +my $MAXIMUM_SUBJECT_BYTES = 16 * 1024 * 1024; +my $MAXIMUM_REPLACEMENT_CHARACTERS = 64 * 1024; +my $MAXIMUM_MATCHES = 10_000; +my $MAXIMUM_CAPTURE_ROWS = 100_000; +my $MAXIMUM_CAPTURE_GROUPS = 1_000; +my $MAXIMUM_OUTPUT_BYTES = 64 * 1024 * 1024; +my $MAXIMUM_ERROR_CHARACTERS = 1_024; +my $OUTPUT_CHUNK_CHARACTERS = 4_096; +my $MAXIMUM_REQUEST_BYTES = 6 * ( + $MAXIMUM_SUBJECT_BYTES + + $MAXIMUM_PATTERN_CHARACTERS + + $MAXIMUM_REPLACEMENT_CHARACTERS +) + 16 * 1024; +my $MAXIMUM_RESPONSE_BYTES = 8 * 1024 * 1024; + +sub _bounded_message { + my ($value) = @_; + $value = defined($value) ? "$value" : 'Unknown Perl bridge error'; + $value =~ s/\s+at \Q@{[$0]}\E line \d+\.?\s*\z//; + return length($value) <= $MAXIMUM_ERROR_CHARACTERS + ? $value + : substr($value, 0, $MAXIMUM_ERROR_CHARACTERS - 1) . "\x{2026}"; +} + +sub _utf8_bytes { + my ($value) = @_; + my $encoded = $value; + utf8::encode($encoded); + return $encoded; +} + +sub _failure { + my ($phase, $code, $message) = @_; + return { + abi => $BRIDGE_ABI_VERSION, + ok => $FALSE, + phase => $phase, + code => $code, + message => _bounded_message($message), + }; +} + +sub _is_plain_hash { + my ($value) = @_; + return ref($value) eq 'HASH'; +} + +sub _has_exact_keys { + my ($value, @expected) = @_; + return 0 if !_is_plain_hash($value); + return join("\0", sort keys %$value) + eq join("\0", sort @expected); +} + +sub _is_integer_in_range { + my ($value, $minimum, $maximum) = @_; + return defined($value) + && !ref($value) + && "$value" =~ /\A(?:0|[1-9][0-9]*)\z/ + && $value >= $minimum + && $value <= $maximum; +} + +sub _read_request { + open my $input, '<:raw', $REQUEST_PATH + or die "Unable to open the fixed bridge request file: $!"; + local $/; + my $encoded = <$input>; + close $input or die "Unable to close the fixed bridge request file: $!"; + die 'The fixed bridge request exceeds its byte limit.' + if !defined($encoded) || length($encoded) > $MAXIMUM_REQUEST_BYTES; + return $JSON->decode($encoded); +} + +sub _write_response { + my ($response) = @_; + my $encoded = $JSON->encode($response); + die 'The fixed bridge response exceeds its byte limit.' + if length($encoded) > $MAXIMUM_RESPONSE_BYTES; + open my $output, '>:raw', $RESPONSE_PATH + or die "Unable to open the fixed bridge response file: $!"; + print {$output} $encoded + or die "Unable to write the fixed bridge response file: $!"; + close $output + or die "Unable to close the fixed bridge response file: $!"; +} + +sub _contains_code_assertion { + my ($pattern) = @_; + my $escaped = 0; + my $character_class = 0; + my $quoted = 0; + for (my $index = 0; $index < length($pattern); $index++) { + my $current = substr($pattern, $index, 1); + if ($quoted) { + if ($current eq '\\' + && substr($pattern, $index + 1, 1) eq 'E') { + $quoted = 0; + $index++; + } + next; + } + if ($escaped) { + $escaped = 0; + next; + } + if ($current eq '\\') { + if (substr($pattern, $index + 1, 1) eq 'Q') { + $quoted = 1; + $index++; + } + else { + $escaped = 1; + } + next; + } + if ($current eq '[' && !$character_class) { + $character_class = 1; + next; + } + if ($current eq ']' && $character_class) { + $character_class = 0; + next; + } + next if $character_class; + return 1 if substr($pattern, $index, 3) eq '(?{'; + return 1 if substr($pattern, $index, 4) eq '(??{'; + } + return 0; +} + +sub _validate_flags { + my ($flags) = @_; + return 'Flags must be a string.' if !defined($flags) || ref($flags); + my %seen; + for my $flag (split //, $flags) { + return 'The request contains an unsupported or duplicate Perl flag.' + if $flag !~ /\A[gimsxnadlu]\z/ || $seen{$flag}++; + } + my $character_rules = grep { $seen{$_} } qw(a d l u); + return 'Perl character-set flags a, d, l and u are mutually exclusive.' + if $character_rules > 1; + return; +} + +sub _validate_request { + my ($request) = @_; + return _failure('bridge', 'invalid-request', 'The request must be a JSON object.') + if !_is_plain_hash($request); + return _failure('bridge', 'abi-mismatch', 'The bridge ABI version is unsupported.') + if !defined($request->{abi}) + || ref($request->{abi}) + || $request->{abi} != $BRIDGE_ABI_VERSION; + if (defined($request->{operation}) + && !ref($request->{operation}) + && $request->{operation} eq 'identity') { + return _failure( + 'bridge', + 'invalid-request', + 'The identity request contains missing or unexpected fields.', + ) if !_has_exact_keys($request, qw(abi operation)); + return; + } + return _failure('bridge', 'invalid-operation', 'The bridge operation is unsupported.') + if !defined($request->{operation}) + || ref($request->{operation}) + || ($request->{operation} ne 'execute' + && $request->{operation} ne 'replace'); + my @request_fields = qw( + abi + flags + maximumCaptureRows + maximumMatches + operation + options + pattern + scanAll + subject + ); + push @request_fields, qw(maximumOutputBytes replacement) + if $request->{operation} eq 'replace'; + return _failure( + 'bridge', + 'invalid-request', + 'The request contains missing or unexpected fields.', + ) if !_has_exact_keys($request, @request_fields); + return _failure('bridge', 'invalid-request', 'Pattern and subject must be strings.') + if !defined($request->{pattern}) + || ref($request->{pattern}) + || !defined($request->{subject}) + || ref($request->{subject}); + return _failure('bridge', 'pattern-limit', 'The pattern exceeds the bridge limit.') + if length($request->{pattern}) > $MAXIMUM_PATTERN_CHARACTERS; + return _failure('bridge', 'subject-limit', 'The subject exceeds the bridge limit.') + if length(_utf8_bytes($request->{subject})) > $MAXIMUM_SUBJECT_BYTES; + return _failure('bridge', 'unsupported-option', 'Perl does not accept engine options.') + if !_is_plain_hash($request->{options}) + || keys(%{$request->{options}}); + my $flag_error = _validate_flags($request->{flags}); + return _failure('bridge', 'unsupported-flag', $flag_error) if $flag_error; + return _failure( + 'bridge', + 'result-limit', + 'The requested result bounds are outside the bridge contract.', + ) if !_is_integer_in_range( + $request->{maximumMatches}, + 1, + $MAXIMUM_MATCHES, + ) || !_is_integer_in_range( + $request->{maximumCaptureRows}, + 1, + $MAXIMUM_CAPTURE_ROWS, + ); + return _failure( + 'compile', + 'code-assertion-disabled', + 'Perl code assertions (?{...}) and (??{...}) are disabled.', + ) if _contains_code_assertion($request->{pattern}); + if ($request->{operation} eq 'execute') { + return _failure( + 'bridge', + 'invalid-request', + 'Execution requests cannot contain replacement fields.', + ) if exists($request->{replacement}) + || exists($request->{maximumOutputBytes}); + return; + } + return _failure( + 'bridge', + 'invalid-request', + 'Replacement requests require a string template and output bound.', + ) if !defined($request->{replacement}) + || ref($request->{replacement}) + || !_is_integer_in_range( + $request->{maximumOutputBytes}, + 1, + $MAXIMUM_OUTPUT_BYTES, + ); + return _failure( + 'bridge', + 'replacement-limit', + 'The replacement template exceeds the bridge limit.', + ) if length($request->{replacement}) > $MAXIMUM_REPLACEMENT_CHARACTERS; + return; +} + +sub _compile_pattern { + my ($pattern, $flags) = @_; + my $modifiers = join '', grep { index($flags, $_) >= 0 } + qw(i m s x n a d l u); + my $wrapped = length($modifiers) + ? "(?$modifiers:$pattern)" + : "(?:$pattern)"; + my $compiled; + my $error; + { + local $SIG{__WARN__} = sub { }; + local $@; + $compiled = eval { qr/$wrapped/ }; + $error = $@; + } + return ($compiled, $error); +} + +sub _capture_group_count { + my ($compiled) = @_; + my $probe = qr/(?:$compiled)|()/; + '' =~ $probe; + return $#- - 1; +} + +sub _snapshot_match { + my ($group_count, $starts, $ends) = @_; + my @captures; + for my $group (1 .. $group_count) { + push @captures, defined($starts->[$group]) + && $starts->[$group] >= 0 + ? [0 + $starts->[$group], 0 + $ends->[$group]] + : undef; + } + return { + span => [0 + $starts->[0], 0 + $ends->[0]], + captures => \@captures, + }; +} + +sub _push_literal_token { + my ($tokens, $literal) = @_; + return if !length($$literal); + push @$tokens, ['literal', $$literal]; + $$literal = ''; +} + +sub _tokenize_replacement { + my ($template, $group_count) = @_; + my @tokens; + my $literal = ''; + my $cursor = 0; + while ($cursor < length($template)) { + my $current = substr($template, $cursor, 1); + if ($current ne '$') { + $literal .= $current; + $cursor++; + next; + } + my $next = substr($template, $cursor + 1, 1); + if ($next eq '$') { + _push_literal_token(\@tokens, \$literal); + push @tokens, ['literal', '$']; + $cursor += 2; + next; + } + if (substr($template, $cursor + 1) =~ /\A([0-9]+)/) { + my $digits = $1; + my $canonical = $digits; + $canonical =~ s/\A0+(?=[0-9])//; + my $number = length($canonical) <= length("$group_count") + && $canonical <= $group_count + ? 0 + $canonical + : undef; + _push_literal_token(\@tokens, \$literal); + push @tokens, ['capture', $number]; + $cursor += 1 + length($digits); + next; + } + if (substr($template, $cursor + 1) + =~ /\A\{([A-Za-z_][A-Za-z0-9_]*)\}/) { + my $name = $1; + _push_literal_token(\@tokens, \$literal); + push @tokens, ['named', $name]; + $cursor += 3 + length($name); + next; + } + $literal .= '$'; + $cursor++; + } + _push_literal_token(\@tokens, \$literal); + return \@tokens; +} + +sub _write_encoded { + my ($state, $encoded) = @_; + return if !length($encoded); + print {$state->{handle}} $encoded + or die "Unable to write the fixed bridge output file: $!"; + $state->{bytes} += length($encoded); +} + +sub _append_piece { + my ($state, $value) = @_; + return 0 if $state->{truncated}; + return 1 if !length($value); + my $encoded = _utf8_bytes($value); + my $remaining = $state->{maximum} - $state->{bytes}; + if (length($encoded) <= $remaining) { + _write_encoded($state, $encoded); + return 1; + } + my ($low, $high) = (0, length($value)); + while ($low < $high) { + my $middle = int(($low + $high + 1) / 2); + my $prefix_bytes = length(_utf8_bytes(substr($value, 0, $middle))); + if ($prefix_bytes <= $remaining) { + $low = $middle; + } + else { + $high = $middle - 1; + } + } + _write_encoded($state, _utf8_bytes(substr($value, 0, $low))) + if $low > 0; + $state->{truncated} = $TRUE; + return 0; +} + +sub _append_text { + my ($state, $value) = @_; + return 0 if $state->{truncated}; + my $cursor = 0; + while ($cursor < length($value)) { + my $length = length($value) - $cursor; + $length = $OUTPUT_CHUNK_CHARACTERS + if $length > $OUTPUT_CHUNK_CHARACTERS; + return 0 + if !_append_piece($state, substr($value, $cursor, $length)); + $cursor += $length; + } + return 1; +} + +sub _append_span { + my ($state, $subject, $start, $end) = @_; + return 0 if $state->{truncated}; + my $cursor = $start; + while ($cursor < $end) { + my $length = $end - $cursor; + $length = $OUTPUT_CHUNK_CHARACTERS + if $length > $OUTPUT_CHUNK_CHARACTERS; + return 0 + if !_append_piece($state, substr($subject, $cursor, $length)); + $cursor += $length; + } + return 1; +} + +sub _resolve_named_spans { + my ($tokens, $subject, $starts, $ends, $named_values) = @_; + my %resolved; + for my $token (@$tokens) { + my ($kind, $name) = @$token; + next if $kind ne 'named' + || exists($resolved{$name}) + || !exists($named_values->{$name}) + || !defined($named_values->{$name}); + my $captured = $named_values->{$name}; + for my $group (1 .. $#$ends) { + next if !defined($starts->[$group]) + || $starts->[$group] < 0 + || $ends->[$group] - $starts->[$group] != length($captured) + || index($subject, $captured, $starts->[$group]) + != $starts->[$group]; + $resolved{$name} = [ + 0 + $starts->[$group], + 0 + $ends->[$group], + ]; + last; + } + die "Unable to resolve native span for named capture $name." + if !exists($resolved{$name}); + } + return \%resolved; +} + +sub _append_replacement_tokens { + my ($state, $tokens, $subject, $starts, $ends, $named_spans) = @_; + for my $token (@$tokens) { + return 0 if $state->{truncated}; + my ($kind, $value) = @$token; + if ($kind eq 'literal') { + _append_text($state, $value); + } + elsif ($kind eq 'capture') { + _append_span( + $state, + $subject, + $starts->[$value], + $ends->[$value], + ) if defined($value) + && defined($starts->[$value]) + && $starts->[$value] >= 0; + } + elsif ($kind eq 'named') { + _append_span( + $state, + $subject, + $named_spans->{$value}->[0], + $named_spans->{$value}->[1], + ) if exists($named_spans->{$value}); + } + else { + die 'The fixed replacement tokenizer produced an invalid token.'; + } + } + return !$state->{truncated}; +} + +sub _open_output { + my ($maximum, $path) = @_; + open my $handle, '>:raw', $path + or die "Unable to open the fixed bridge output file: $!"; + return { + handle => $handle, + bytes => 0, + maximum => 0 + $maximum, + truncated => $FALSE, + }; +} + +sub _close_output { + my ($state) = @_; + close $state->{handle} + or die "Unable to close the fixed bridge output file: $!"; + delete $state->{handle}; +} + +sub _run_regex { + my ($request) = @_; + my ($compiled, $compile_error) = _compile_pattern( + $request->{pattern}, + $request->{flags}, + ); + return _failure('compile', 'compile-error', $compile_error) + if !defined($compiled); + my $group_count = _capture_group_count($compiled); + return _failure( + 'compile', + 'capture-group-limit', + "The pattern declares $group_count capture groups; " + . "the bridge limit is $MAXIMUM_CAPTURE_GROUPS.", + ) if $group_count > $MAXIMUM_CAPTURE_GROUPS; + + my $rows_per_match = $group_count > 0 ? $group_count : 1; + my $allowed_matches = $request->{maximumMatches}; + my $row_bound = int($request->{maximumCaptureRows} / $rows_per_match); + $allowed_matches = $row_bound if $row_bound < $allowed_matches; + + my $subject = $request->{subject}; + my $global = index($request->{flags}, 'g') >= 0; + my $replacement_tokens = $request->{operation} eq 'replace' + ? _tokenize_replacement($request->{replacement}, $group_count) + : undef; + my @matches; + my $results_truncated = $FALSE; + my $replacement_state = defined($replacement_tokens) + ? _open_output($request->{maximumOutputBytes}, $OUTPUT_PATH) + : undef; + $replacement_state->{cursor} = 0 if defined($replacement_state); + + pos($subject) = 0; + while ($subject =~ /$compiled/g) { + my @starts = @-; + my @ends = @+; + if (@matches >= $allowed_matches) { + $results_truncated = $TRUE; + last; + } + push @matches, _snapshot_match( + $group_count, + \@starts, + \@ends, + ); + + if (defined($replacement_state)) { + _append_span( + $replacement_state, + $subject, + $replacement_state->{cursor}, + $starts[0], + ); + if (!$replacement_state->{truncated}) { + my $named_spans = _resolve_named_spans( + $replacement_tokens, + $subject, + \@starts, + \@ends, + \%+, + ); + _append_replacement_tokens( + $replacement_state, + $replacement_tokens, + $subject, + \@starts, + \@ends, + $named_spans, + ); + } + $replacement_state->{cursor} = $ends[0]; + if ($replacement_state->{truncated}) { + $results_truncated = $TRUE; + last; + } + } + last if !$global; + } + + my $response = { + abi => $BRIDGE_ABI_VERSION, + ok => $TRUE, + groupCount => 0 + $group_count, + groupNames => [], + matches => \@matches, + resultsTruncated => $results_truncated, + }; + if (defined($replacement_state)) { + _append_span( + $replacement_state, + $subject, + $replacement_state->{cursor}, + length($subject), + ); + _close_output($replacement_state); + $response->{outputBytes} = 0 + $replacement_state->{bytes}; + $response->{outputTruncated} = $replacement_state->{truncated}; + } + return $response; +} + +sub _render_self_test_replacement { + my ($compiled, $subject, $template, $maximum) = @_; + my $group_count = _capture_group_count($compiled); + my $tokens = _tokenize_replacement($template, $group_count); + return if $subject !~ /$compiled/; + my @starts = @-; + my @ends = @+; + my $named_spans = _resolve_named_spans( + $tokens, + $subject, + \@starts, + \@ends, + \%+, + ); + my $encoded = ''; + my $state = _open_output($maximum, \$encoded); + _append_span($state, $subject, 0, $starts[0]); + _append_replacement_tokens( + $state, + $tokens, + $subject, + \@starts, + \@ends, + $named_spans, + ); + _append_span($state, $subject, $ends[0], length($subject)); + _close_output($state); + my $decoded = $encoded; + return if !utf8::decode($decoded); + return ($decoded, 0 + $state->{bytes}, $state->{truncated}); +} + +sub _self_test { + return $FALSE if "$^V" ne 'v5.28.1'; + my ($compiled, $error) = _compile_pattern( + '(?\x{1F600}+)', + 'u', + ); + return $FALSE if $error || !defined($compiled); + my $subject = "x\x{1F600}\x{1F600}"; + return $FALSE if $subject !~ /$compiled/; + return $FALSE if $-[0] != 1 || $+[0] != 3; + return $FALSE if $+{word} ne "\x{1F600}\x{1F600}"; + my ($named, $named_bytes, $named_truncated) = + _render_self_test_replacement( + $compiled, + $subject, + '<${word}>', + 1_024, + ); + return $FALSE if !defined($named) + || $named ne "x<\x{1F600}\x{1F600}>" + || $named_bytes != 11 + || $named_truncated; + my $native_named = $subject; + $native_named =~ s/$compiled/<$+{word}>/; + return $FALSE if $named ne $native_named; + my $numbered_compiled = qr/(a)(b)/; + my ($numbered, $numbered_bytes, $numbered_truncated) = + _render_self_test_replacement( + $numbered_compiled, + 'ab', + '$1-$$', + 1_024, + ); + my $native_numbered = 'ab'; + $native_numbered =~ s/$numbered_compiled/$1-\$/; + return $FALSE if !defined($numbered) + || $numbered ne $native_numbered + || $numbered_bytes != 3 + || $numbered_truncated; + my ($greedy, $greedy_bytes, $greedy_truncated) = + _render_self_test_replacement( + qr/(a)(b)/, + 'ab', + '$12/$1/$$/${missing}/$', + 1_024, + ); + return $FALSE if !defined($greedy) + || $greedy ne '/a/$//$' + || $greedy_bytes != 7 + || $greedy_truncated; + my ($bounded, $bounded_bytes, $bounded_truncated) = + _render_self_test_replacement( + $compiled, + $subject, + '<${word}>', + 5, + ); + return $FALSE if !defined($bounded) + || $bounded ne 'x<' + || $bounded_bytes != 2 + || !$bounded_truncated; + return $TRUE; +} + +sub _identity { + return { + abi => $BRIDGE_ABI_VERSION, + ok => $TRUE, + identity => { + bridge => 'regex-tools-webperl-json', + bridgeVersion => $BRIDGE_ABI_VERSION, + engine => 'Perl regular expressions', + engineVersion => '5.28.1', + perlVersion => "$^V", + webPerlVersion => '0.09-beta', + offsetUnit => 'code-point', + replacementGrammar => 'literal + $$ + $n + ${name}', + replacementTransport => 'fixed MEMFS binary output file', + replacementParityOracle => 'fixed native s/// fixtures', + legacy => $TRUE, + beta => $TRUE, + selfTest => _self_test(), + }, + }; +} + +sub run_request { + my $response; + my $ok = eval { + my $request = _read_request(); + my $validation_failure = _validate_request($request); + $response = $validation_failure + || ($request->{operation} eq 'identity' + ? _identity() + : _run_regex($request)); + 1; + }; + if (!$ok) { + $response = _failure( + 'bridge', + 'bridge-error', + $@ || 'Unknown fixed Perl bridge failure', + ); + } + eval { _write_response($response); 1 } or do { + my $fallback = _failure( + 'bridge', + 'serialization-error', + $@ || 'The fixed Perl bridge could not serialize its response.', + ); + _write_response($fallback); + }; + return 'ok'; +} + +1; diff --git a/engines/php/LICENSE.Emscripten-4.0.19.txt b/engines/php/LICENSE.Emscripten-4.0.19.txt new file mode 100644 index 0000000..70cabe3 --- /dev/null +++ b/engines/php/LICENSE.Emscripten-4.0.19.txt @@ -0,0 +1,102 @@ +Emscripten is available under 2 licenses, the MIT license and the +University of Illinois/NCSA Open Source License. + +Both are permissive open source licenses, with little if any +practical difference between them. + +The reason for offering both is that (1) the MIT license is +well-known, while (2) the University of Illinois/NCSA Open Source +License allows Emscripten's code to be integrated upstream into +LLVM, which uses that license, should the opportunity arise. + +The full text of both licenses follows. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following disclaimers + in the documentation and/or other materials provided with the + distribution. + + Neither the names of Mozilla, + nor the names of its contributors may be used to endorse + or promote products derived from this Software without specific prior + written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + +============================================================================== + +This program uses portions of Node.js source code located in src/library_path.js, +in accordance with the terms of the MIT license. Node's license follows: + + """ + Copyright Joyent, Inc. and other Node contributors. All rights reserved. + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. + """ + +The musl libc project is bundled in this repo, and it has the MIT license, see +system/lib/libc/musl/COPYRIGHT + +The third_party/ subdirectory contains code with other licenses. None of it is +used by default, but certain options use it (e.g., the optional closure compiler +flag will run closure compiler from third_party/). + diff --git a/engines/php/LICENSE.Oniguruma-6.9.10.txt b/engines/php/LICENSE.Oniguruma-6.9.10.txt new file mode 100644 index 0000000..ee4d7cf --- /dev/null +++ b/engines/php/LICENSE.Oniguruma-6.9.10.txt @@ -0,0 +1,26 @@ +Oniguruma LICENSE +----------------- + +Copyright (c) 2002-2021 K.Kosako +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/engines/php/LICENSE.OpenSSL-1.1.1t.txt b/engines/php/LICENSE.OpenSSL-1.1.1t.txt new file mode 100644 index 0000000..9601ab4 --- /dev/null +++ b/engines/php/LICENSE.OpenSSL-1.1.1t.txt @@ -0,0 +1,125 @@ + + LICENSE ISSUES + ============== + + The OpenSSL toolkit stays under a double license, i.e. both the conditions of + the OpenSSL License and the original SSLeay license apply to the toolkit. + See below for the actual license texts. + + OpenSSL License + --------------- + +/* ==================================================================== + * Copyright (c) 1998-2019 The OpenSSL Project. All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in + * the documentation and/or other materials provided with the + * distribution. + * + * 3. All advertising materials mentioning features or use of this + * software must display the following acknowledgment: + * "This product includes software developed by the OpenSSL Project + * for use in the OpenSSL Toolkit. (http://www.openssl.org/)" + * + * 4. The names "OpenSSL Toolkit" and "OpenSSL Project" must not be used to + * endorse or promote products derived from this software without + * prior written permission. For written permission, please contact + * openssl-core@openssl.org. + * + * 5. Products derived from this software may not be called "OpenSSL" + * nor may "OpenSSL" appear in their names without prior written + * permission of the OpenSSL Project. + * + * 6. Redistributions of any form whatsoever must retain the following + * acknowledgment: + * "This product includes software developed by the OpenSSL Project + * for use in the OpenSSL Toolkit (http://www.openssl.org/)" + * + * THIS SOFTWARE IS PROVIDED BY THE OpenSSL PROJECT ``AS IS'' AND ANY + * EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR + * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE OpenSSL PROJECT OR + * ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; + * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, + * STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED + * OF THE POSSIBILITY OF SUCH DAMAGE. + * ==================================================================== + * + * This product includes cryptographic software written by Eric Young + * (eay@cryptsoft.com). This product includes software written by Tim + * Hudson (tjh@cryptsoft.com). + * + */ + + Original SSLeay License + ----------------------- + +/* Copyright (C) 1995-1998 Eric Young (eay@cryptsoft.com) + * All rights reserved. + * + * This package is an SSL implementation written + * by Eric Young (eay@cryptsoft.com). + * The implementation was written so as to conform with Netscapes SSL. + * + * This library is free for commercial and non-commercial use as long as + * the following conditions are aheared to. The following conditions + * apply to all code found in this distribution, be it the RC4, RSA, + * lhash, DES, etc., code; not just the SSL code. The SSL documentation + * included with this distribution is covered by the same copyright terms + * except that the holder is Tim Hudson (tjh@cryptsoft.com). + * + * Copyright remains Eric Young's, and as such any Copyright notices in + * the code are not to be removed. + * If this package is used in a product, Eric Young should be given attribution + * as the author of the parts of the library used. + * This can be in the form of a textual message at program startup or + * in documentation (online or textual) provided with the package. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * 3. All advertising materials mentioning features or use of this software + * must display the following acknowledgement: + * "This product includes cryptographic software written by + * Eric Young (eay@cryptsoft.com)" + * The word 'cryptographic' can be left out if the rouines from the library + * being used are not cryptographic related :-). + * 4. If you include any Windows specific code (or a derivative thereof) from + * the apps directory (application code) you must include an acknowledgement: + * "This product includes software written by Tim Hudson (tjh@cryptsoft.com)" + * + * THIS SOFTWARE IS PROVIDED BY ERIC YOUNG ``AS IS'' AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + * SUCH DAMAGE. + * + * The licence and distribution terms for any publically available version or + * derivative of this code cannot be changed. i.e. this code cannot simply be + * copied and put under another distribution licence + * [including the GNU Public Licence.] + */ + diff --git a/engines/php/LICENSE.PCRE2-10.44.txt b/engines/php/LICENSE.PCRE2-10.44.txt new file mode 100644 index 0000000..3c1ef03 --- /dev/null +++ b/engines/php/LICENSE.PCRE2-10.44.txt @@ -0,0 +1,94 @@ +PCRE2 LICENCE +------------- + +PCRE2 is a library of functions to support regular expressions whose syntax +and semantics are as close as possible to those of the Perl 5 language. + +Releases 10.00 and above of PCRE2 are distributed under the terms of the "BSD" +licence, as specified below, with one exemption for certain binary +redistributions. The documentation for PCRE2, supplied in the "doc" directory, +is distributed under the same terms as the software itself. The data in the +testdata directory is not copyrighted and is in the public domain. + +The basic library functions are written in C and are freestanding. Also +included in the distribution is a just-in-time compiler that can be used to +optimize pattern matching. This is an optional feature that can be omitted when +the library is built. + + +THE BASIC LIBRARY FUNCTIONS +--------------------------- + +Written by: Philip Hazel +Email local part: Philip.Hazel +Email domain: gmail.com + +Retired from University of Cambridge Computing Service, +Cambridge, England. + +Copyright (c) 1997-2024 University of Cambridge +All rights reserved. + + +PCRE2 JUST-IN-TIME COMPILATION SUPPORT +-------------------------------------- + +Written by: Zoltan Herczeg +Email local part: hzmester +Email domain: freemail.hu + +Copyright(c) 2010-2024 Zoltan Herczeg +All rights reserved. + + +STACK-LESS JUST-IN-TIME COMPILER +-------------------------------- + +Written by: Zoltan Herczeg +Email local part: hzmester +Email domain: freemail.hu + +Copyright(c) 2009-2024 Zoltan Herczeg +All rights reserved. + + +THE "BSD" LICENCE +----------------- + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notices, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notices, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the University of Cambridge nor the names of any + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + + +EXEMPTION FOR BINARY LIBRARY-LIKE PACKAGES +------------------------------------------ + +The second condition in the BSD licence (covering binary redistributions) does +not apply all the way down a chain of software. If binary package A includes +PCRE2, it must respect the condition, but if package B is software that +includes package A, the condition is not imposed on package B unless it uses +PCRE2 independently. + +End diff --git a/engines/php/LICENSE.PHP-4.0.txt b/engines/php/LICENSE.PHP-4.0.txt new file mode 100644 index 0000000..e64f664 --- /dev/null +++ b/engines/php/LICENSE.PHP-4.0.txt @@ -0,0 +1,27 @@ +Copyright © The PHP Group and Contributors. +Copyright © Zend Technologies Ltd., a subsidiary company of Perforce Software, Inc. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.PHP-CLI-http-parser-MIT.txt b/engines/php/LICENSE.PHP-CLI-http-parser-MIT.txt new file mode 100644 index 0000000..320d91c --- /dev/null +++ b/engines/php/LICENSE.PHP-CLI-http-parser-MIT.txt @@ -0,0 +1,19 @@ +Copyright 2009,2010 Ryan Dahl + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +sell copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.PHP-Lexbor-Apache-2.0.txt b/engines/php/LICENSE.PHP-Lexbor-Apache-2.0.txt new file mode 100644 index 0000000..f433b1a --- /dev/null +++ b/engines/php/LICENSE.PHP-Lexbor-Apache-2.0.txt @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/engines/php/LICENSE.PHP-Zend-2.0.txt b/engines/php/LICENSE.PHP-Zend-2.0.txt new file mode 100644 index 0000000..51f5ccc --- /dev/null +++ b/engines/php/LICENSE.PHP-Zend-2.0.txt @@ -0,0 +1,56 @@ +-------------------------------------------------------------------- + The Zend Engine License, Version 2.00 +Copyright (c) 1999-2006 Zend Technologies Ltd. All rights reserved. +-------------------------------------------------------------------- + +Redistribution and use in source and binary forms, with or without +modification, is permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. The names "Zend" and "Zend Engine" must not be used to endorse + or promote products derived from this software without prior + permission from Zend Technologies Ltd. For written permission, + please contact license@zend.com. + + 4. Zend Technologies Ltd. may publish revised and/or new versions + of the license from time to time. Each version will be given a + distinguishing version number. + Once covered code has been published under a particular version + of the license, you may always continue to use it under the + terms of that version. You may also choose to use such covered + code under the terms of any subsequent version of the license + published by Zend Technologies Ltd. No one other than Zend + Technologies Ltd. has the right to modify the terms applicable + to covered code created under this License. + + 5. Redistributions of any form whatsoever must retain the following + acknowledgment: + "This product includes the Zend Engine, freely available at + http://www.zend.com" + + 6. All advertising materials mentioning features or use of this + software must display the following acknowledgment: + "The Zend Engine is freely available at http://www.zend.com" + +THIS SOFTWARE IS PROVIDED BY ZEND TECHNOLOGIES LTD. ``AS IS'' AND +ANY EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ZEND +TECHNOLOGIES LTD. BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +-------------------------------------------------------------------- diff --git a/engines/php/LICENSE.PHP-bcmath-LGPL-2.1.txt b/engines/php/LICENSE.PHP-bcmath-LGPL-2.1.txt new file mode 100644 index 0000000..bb5d10d --- /dev/null +++ b/engines/php/LICENSE.PHP-bcmath-LGPL-2.1.txt @@ -0,0 +1,512 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations +below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it +becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control +compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply, and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License +may add an explicit geographical distribution limitation excluding those +countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms +of the ordinary General Public License). + + To apply these terms, attach the following notices to the library. +It is safest to attach them to the start of each source file to most +effectively convey the exclusion of warranty; and each file should +have at least the "copyright" line and a pointer to where the full +notice is found. + + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper +mail. + +You should also get your employer (if you work as a programmer) or +your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James +Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/engines/php/LICENSE.PHP-libavifinfo-BSD-2-Clause.txt b/engines/php/LICENSE.PHP-libavifinfo-BSD-2-Clause.txt new file mode 100644 index 0000000..330b6b8 --- /dev/null +++ b/engines/php/LICENSE.PHP-libavifinfo-BSD-2-Clause.txt @@ -0,0 +1,26 @@ +Copyright (c) 2021, Alliance for Open Media. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.PHP-libmagic-BSD.txt b/engines/php/LICENSE.PHP-libmagic-BSD.txt new file mode 100644 index 0000000..16410a1 --- /dev/null +++ b/engines/php/LICENSE.PHP-libmagic-BSD.txt @@ -0,0 +1,29 @@ +$File: COPYING,v 1.2 2018/09/09 20:33:28 christos Exp $ +Copyright (c) Ian F. Darwin 1986, 1987, 1989, 1990, 1991, 1992, 1994, 1995. +Software written by Ian F. Darwin and others; +maintained 1994- Christos Zoulas. + +This software is not subject to any export provision of the United States +Department of Commerce, and may be exported to any country or planet. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice immediately at the beginning of the file, without modification, + this list of conditions, and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/engines/php/LICENSE.PHP-libmbfl-LGPL-2.1.txt b/engines/php/LICENSE.PHP-libmbfl-LGPL-2.1.txt new file mode 100644 index 0000000..78192cd --- /dev/null +++ b/engines/php/LICENSE.PHP-libmbfl-LGPL-2.1.txt @@ -0,0 +1,516 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + +"streamable kanji code filter and converter" + +Copyright (c) 1998,1999,2000,2001 HappySize, Inc. All rights reserved. + +This software is released under the GNU Lesser General Public License. +(Version 2.1, February 1999) +Please read the following detail of the licence (in japanese). + +◆使用許諾条件◆ + +このソフトウェアは株式会社ハッピーサイズによって開発されました。株式会社ハッ +ピーサイズは、著作権法および万国著作権条約の定めにより、このソフトウェアに関 +するすべての権利を留保する権利を持ち、ここに行使します。株式会社ハッピーサイ +ズは以下に明記した条件に従って、このソフトウェアを使用する排他的ではない権利 +をお客様に許諾します。何人たりとも、以下の条件に反してこのソフトウェアを使用 +することはできません。 + +このソフトウェアを「GNU Lesser General Public License (Version 2.1, February +1999)」に示された条件で使用することを、全ての方に許諾します。「GNU Lesser +General Public License」を満たさない使用には、株式会社ハッピーサイズから書面 +による許諾を得る必要があります。 + +「GNU Lesser General Public License」の全文は以下のウェブページから取得でき +ます。「GNU Lesser General Public License」とは、これまでLibrary General +Public Licenseと呼ばれていたものです。 + http://www.gnu.org/ --- GNUウェブサイト + http://www.gnu.org/copyleft/lesser.html --- ライセンス文面 +このライセンスの内容がわからない方、守れない方には使用を許諾しません。 + +しかしながら、当社とGNUプロジェクトとの特定の関係を示唆または主張するもので +はありません。 + +◆保証内容◆ + +このソフトウェアは、期待された動作・機能・性能を持つことを目標として設計され +開発されていますが、これを保証するものではありません。このソフトウェアは「こ +のまま」の状態で提供されており、たとえばこのソフトウェアの有用性ないし特定の +目的に合致することといった、何らかの保証内容が、明示されたり暗黙に示されてい +る場合であっても、その保証は無効です。このソフトウェアを使用した結果ないし使 +用しなかった結果によって、直接あるいは間接に受けた身体的な傷害、財産上の損害 +、データの損失あるいはその他の全ての損害については、その損害の可能性が使用者 +、当社あるいは第三者によって警告されていた場合であっても、当社はその損害の賠 +償および補填を行いません。この規定は他の全ての、書面上または書面に無い保証・ +契約・規定に優先します。 + +◆著作権者の連絡先および使用条件についての問い合わせ先◆ + +〒102-0073 +東京都千代田区九段北1-13-5日本地所第一ビル4F +株式会社ハッピーサイズ +Phone: 03-3512-3655, Fax: 03-3512-3656 +Email: sales@happysize.co.jp +Web: http://happysize.com/ + +◆著者◆ + +金本　茂 diff --git a/engines/php/LICENSE.PHP-timelib-MIT.txt b/engines/php/LICENSE.PHP-timelib-MIT.txt new file mode 100644 index 0000000..7ba6002 --- /dev/null +++ b/engines/php/LICENSE.PHP-timelib-MIT.txt @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2015-2021 Derick Rethans +Copyright (c) 2017-2019,2021 MongoDB, Inc. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.PHP-uriparser-BSD-3-Clause.txt b/engines/php/LICENSE.PHP-uriparser-BSD-3-Clause.txt new file mode 100644 index 0000000..261c741 --- /dev/null +++ b/engines/php/LICENSE.PHP-uriparser-BSD-3-Clause.txt @@ -0,0 +1,36 @@ +uriparser - RFC 3986 URI parsing library + +Copyright (C) 2007, Weijia Song +Copyright (C) 2007, Sebastian Pipping +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above + copyright notice, this list of conditions and the following + disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials + provided with the distribution. + + 3. Neither the name of the copyright holder nor the names of + its contributors may be used to endorse or promote products + derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.curl-7.69.1.txt b/engines/php/LICENSE.curl-7.69.1.txt new file mode 100644 index 0000000..9d9e4af --- /dev/null +++ b/engines/php/LICENSE.curl-7.69.1.txt @@ -0,0 +1,22 @@ +COPYRIGHT AND PERMISSION NOTICE + +Copyright (c) 1996 - 2020, Daniel Stenberg, , and many +contributors, see the THANKS file. + +All rights reserved. + +Permission to use, copy, modify, and distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright +notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF THIRD PARTY RIGHTS. IN +NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE +OR OTHER DEALINGS IN THE SOFTWARE. + +Except as contained in this notice, the name of a copyright holder shall not +be used in advertising or otherwise to promote the sale, use or other dealings +in this Software without prior written authorization of the copyright holder. diff --git a/engines/php/LICENSE.libaom-3.12.1.txt b/engines/php/LICENSE.libaom-3.12.1.txt new file mode 100644 index 0000000..fc340c3 --- /dev/null +++ b/engines/php/LICENSE.libaom-3.12.1.txt @@ -0,0 +1,27 @@ +Copyright (c) 2016, Alliance for Open Media. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + diff --git a/engines/php/LICENSE.libavif-1.3.0.txt b/engines/php/LICENSE.libavif-1.3.0.txt new file mode 100644 index 0000000..350eb9d --- /dev/null +++ b/engines/php/LICENSE.libavif-1.3.0.txt @@ -0,0 +1,387 @@ +Copyright 2019 Joe Drago. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------ + +Files: src/obu.c + +Copyright © 2018-2019, VideoLAN and dav1d authors +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------ + +Files: third_party/iccjpeg/* + +In plain English: + +1. We don't promise that this software works. (But if you find any bugs, + please let us know!) +2. You can use this software for whatever you want. You don't have to pay us. +3. You may not pretend that you wrote this software. If you use it in a + program, you must acknowledge somewhere in your documentation that + you've used the IJG code. + +In legalese: + +The authors make NO WARRANTY or representation, either express or implied, +with respect to this software, its quality, accuracy, merchantability, or +fitness for a particular purpose. This software is provided "AS IS", and you, +its user, assume the entire risk as to its quality and accuracy. + +This software is copyright (C) 1991-2013, Thomas G. Lane, Guido Vollbeding. +All Rights Reserved except as specified below. + +Permission is hereby granted to use, copy, modify, and distribute this +software (or portions thereof) for any purpose, without fee, subject to these +conditions: +(1) If any part of the source code for this software is distributed, then this +README file must be included, with this copyright and no-warranty notice +unaltered; and any additions, deletions, or changes to the original files +must be clearly indicated in accompanying documentation. +(2) If only executable code is distributed, then the accompanying +documentation must state that "this software is based in part on the work of +the Independent JPEG Group". +(3) Permission for use of this software is granted only if the user accepts +full responsibility for any undesirable consequences; the authors accept +NO LIABILITY for damages of any kind. + +These conditions apply to any software derived from or based on the IJG code, +not just to the unmodified library. If you use our work, you ought to +acknowledge us. + +Permission is NOT granted for the use of any IJG author's name or company name +in advertising or publicity relating to this software or products derived from +it. This software may be referred to only as "the Independent JPEG Group's +software". + +We specifically permit and encourage the use of this software as the basis of +commercial products, provided that all warranty or liability claims are +assumed by the product vendor. + + +The Unix configuration script "configure" was produced with GNU Autoconf. +It is copyright by the Free Software Foundation but is freely distributable. +The same holds for its supporting scripts (config.guess, config.sub, +ltmain.sh). Another support script, install-sh, is copyright by X Consortium +but is also freely distributable. + +The IJG distribution formerly included code to read and write GIF files. +To avoid entanglement with the Unisys LZW patent, GIF reading support has +been removed altogether, and the GIF writer has been simplified to produce +"uncompressed GIFs". This technique does not use the LZW algorithm; the +resulting GIF files are larger than usual, but are readable by all standard +GIF decoders. + +We are required to state that + "The Graphics Interchange Format(c) is the Copyright property of + CompuServe Incorporated. GIF(sm) is a Service Mark property of + CompuServe Incorporated." + +------------------------------------------------------------------------------ + +Files: contrib/gdk-pixbuf/* + +Copyright 2020 Emmanuel Gil Peyrot. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +------------------------------------------------------------------------------ + +Files: android_jni/gradlew* + + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + +------------------------------------------------------------------------------ + +Files: third_party/libyuv/* + +Copyright 2011 The LibYuv Project Authors. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Google nor the names of its contributors may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.libcxx.txt b/engines/php/LICENSE.libcxx.txt new file mode 100644 index 0000000..e159d28 --- /dev/null +++ b/engines/php/LICENSE.libcxx.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The libc++ library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2014 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.libcxxabi.txt b/engines/php/LICENSE.libcxxabi.txt new file mode 100644 index 0000000..b75c044 --- /dev/null +++ b/engines/php/LICENSE.libcxxabi.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The libc++abi library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2014 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.libgd-2.3.3.txt b/engines/php/LICENSE.libgd-2.3.3.txt new file mode 100644 index 0000000..8fae49b --- /dev/null +++ b/engines/php/LICENSE.libgd-2.3.3.txt @@ -0,0 +1,73 @@ +Title: License +Credits and license terms: + +In order to resolve any possible confusion regarding the authorship of +gd, the following copyright statement covers all of the authors who +have required such a statement. If you are aware of any oversights in +this copyright notice, please contact Pierre-A. Joye who will be +pleased to correct them. + +* Portions copyright 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + 2002, 2003, 2004 by Cold Spring Harbor Laboratory. Funded under + Grant P41-RR02188 by the National Institutes of Health. + +* Portions copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + 2004 by Boutell.Com, Inc. + +* Portions relating to GD2 format copyright 1999, 2000, 2001, 2002, + 2003, 2004 Philip Warner. + +* Portions relating to PNG copyright 1999, 2000, 2001, 2002, 2003, + 2004 Greg Roelofs. + +* Portions relating to gdttf.c copyright 1999, 2000, 2001, 2002, + 2003, 2004 John Ellson (ellson@graphviz.org). + +* Portions relating to gdft.c copyright 2001, 2002, 2003, 2004 John + Ellson (ellson@graphviz.org). + +* Portions copyright 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, + 2008 Pierre-Alain Joye (pierre@libgd.org). + +* Portions relating to JPEG and to color quantization copyright + 2000, 2001, 2002, 2003, 2004, Doug Becker and copyright (C) 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 Thomas + G. Lane. This software is based in part on the work of the + Independent JPEG Group. See the file README-JPEG.TXT for more + information. + +* Portions relating to GIF compression copyright 1989 by Jef + Poskanzer and David Rowley, with modifications for thread safety + by Thomas Boutell. + +* Portions relating to GIF decompression copyright 1990, 1991, 1993 + by David Koblas, with modifications for thread safety by Thomas + Boutell. + +* Portions relating to WBMP copyright 2000, 2001, 2002, 2003, 2004 + Maurice Szmurlo and Johan Van den Brande. + +* Portions relating to GIF animations copyright 2004 Jaakko Hyvätti + (jaakko.hyvatti@iki.fi) + +Permission has been granted to copy, distribute and modify gd in +any context without fee, including a commercial application, +provided that this notice is present in user-accessible supporting +documentation. + +This does not affect your ownership of the derived work itself, +and the intent is to assure proper credit for the authors of gd, +not to interfere with your productive use of gd. If you have +questions, ask. "Derived works" includes all programs that utilize +the library. Credit must be given in user-accessible +documentation. + +This software is provided "AS IS." The copyright holders disclaim +all warranties, either express or implied, including but not +limited to implied warranties of merchantability and fitness for a +particular purpose, with respect to this code and accompanying +documentation. + +Although their code does not appear in the current release, the +authors wish to thank David Koblas, David Rowley, and Hutchison +Avenue Software Corporation for their prior contributions. diff --git a/engines/php/LICENSE.libiconv-1.17-LGPL-2.1.txt b/engines/php/LICENSE.libiconv-1.17-LGPL-2.1.txt new file mode 100644 index 0000000..4362b49 --- /dev/null +++ b/engines/php/LICENSE.libiconv-1.17-LGPL-2.1.txt @@ -0,0 +1,502 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/engines/php/LICENSE.libjpeg-turbo-3.0.3.txt b/engines/php/LICENSE.libjpeg-turbo-3.0.3.txt new file mode 100644 index 0000000..2204864 --- /dev/null +++ b/engines/php/LICENSE.libjpeg-turbo-3.0.3.txt @@ -0,0 +1,135 @@ +libjpeg-turbo Licenses +====================== + +libjpeg-turbo is covered by two compatible BSD-style open source licenses: + +- The IJG (Independent JPEG Group) License, which is listed in + [README.ijg](README.ijg) + + This license applies to the libjpeg API library and associated programs, + including any code inherited from libjpeg and any modifications to that + code. Note that the libjpeg-turbo SIMD source code bears the + [zlib License](https://opensource.org/licenses/Zlib), but in the context of + the overall libjpeg API library, the terms of the zlib License are subsumed + by the terms of the IJG License. + +- The Modified (3-clause) BSD License, which is listed below + + This license applies to the TurboJPEG API library and associated programs, as + well as the build system. Note that the TurboJPEG API library wraps the + libjpeg API library, so in the context of the overall TurboJPEG API library, + both the terms of the IJG License and the terms of the Modified (3-clause) + BSD License apply. + + +Complying with the libjpeg-turbo Licenses +========================================= + +This section provides a roll-up of the libjpeg-turbo licensing terms, to the +best of our understanding. This is not a license in and of itself. It is +intended solely for clarification. + +1. If you are distributing a modified version of the libjpeg-turbo source, + then: + + 1. You cannot alter or remove any existing copyright or license notices + from the source. + + **Origin** + - Clause 1 of the IJG License + - Clause 1 of the Modified BSD License + - Clauses 1 and 3 of the zlib License + + 2. You must add your own copyright notice to the header of each source + file you modified, so others can tell that you modified that file. (If + there is not an existing copyright header in that file, then you can + simply add a notice stating that you modified the file.) + + **Origin** + - Clause 1 of the IJG License + - Clause 2 of the zlib License + + 3. You must include the IJG README file, and you must not alter any of the + copyright or license text in that file. + + **Origin** + - Clause 1 of the IJG License + +2. If you are distributing only libjpeg-turbo binaries without the source, or + if you are distributing an application that statically links with + libjpeg-turbo, then: + + 1. Your product documentation must include a message stating: + + This software is based in part on the work of the Independent JPEG + Group. + + **Origin** + - Clause 2 of the IJG license + + 2. If your binary distribution includes or uses the TurboJPEG API, then + your product documentation must include the text of the Modified BSD + License (see below.) + + **Origin** + - Clause 2 of the Modified BSD License + +3. You cannot use the name of the IJG or The libjpeg-turbo Project or the + contributors thereof in advertising, publicity, etc. + + **Origin** + - IJG License + - Clause 3 of the Modified BSD License + +4. The IJG and The libjpeg-turbo Project do not warrant libjpeg-turbo to be + free of defects, nor do we accept any liability for undesirable + consequences resulting from your use of the software. + + **Origin** + - IJG License + - Modified BSD License + - zlib License + + +The Modified (3-clause) BSD License +=================================== + +Copyright (C)2009-2023 D. R. Commander. All Rights Reserved.
+Copyright (C)2015 Viktor Szathmáry. All Rights Reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +- Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. +- Neither the name of the libjpeg-turbo Project nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS", +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + + +Why Two Licenses? +================= + +The zlib License could have been used instead of the Modified (3-clause) BSD +License, and since the IJG License effectively subsumes the distribution +conditions of the zlib License, this would have effectively placed +libjpeg-turbo binary distributions under the IJG License. However, the IJG +License specifically refers to the Independent JPEG Group and does not extend +attribution and endorsement protections to other entities. Thus, it was +desirable to choose a license that granted us the same protections for new code +that were granted to the IJG for code derived from their software. diff --git a/engines/php/LICENSE.libpng-1.6.39.txt b/engines/php/LICENSE.libpng-1.6.39.txt new file mode 100644 index 0000000..c8ad24e --- /dev/null +++ b/engines/php/LICENSE.libpng-1.6.39.txt @@ -0,0 +1,134 @@ +COPYRIGHT NOTICE, DISCLAIMER, and LICENSE +========================================= + +PNG Reference Library License version 2 +--------------------------------------- + + * Copyright (c) 1995-2022 The PNG Reference Library Authors. + * Copyright (c) 2018-2022 Cosmin Truta. + * Copyright (c) 2000-2002, 2004, 2006-2018 Glenn Randers-Pehrson. + * Copyright (c) 1996-1997 Andreas Dilger. + * Copyright (c) 1995-1996 Guy Eric Schalnat, Group 42, Inc. + +The software is supplied "as is", without warranty of any kind, +express or implied, including, without limitation, the warranties +of merchantability, fitness for a particular purpose, title, and +non-infringement. In no event shall the Copyright owners, or +anyone distributing the software, be liable for any damages or +other liability, whether in contract, tort or otherwise, arising +from, out of, or in connection with the software, or the use or +other dealings in the software, even if advised of the possibility +of such damage. + +Permission is hereby granted to use, copy, modify, and distribute +this software, or portions hereof, for any purpose, without fee, +subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you + must not claim that you wrote the original software. If you + use this software in a product, an acknowledgment in the product + documentation would be appreciated, but is not required. + + 2. Altered source versions must be plainly marked as such, and must + not be misrepresented as being the original software. + + 3. This Copyright notice may not be removed or altered from any + source or altered source distribution. + + +PNG Reference Library License version 1 (for libpng 0.5 through 1.6.35) +----------------------------------------------------------------------- + +libpng versions 1.0.7, July 1, 2000, through 1.6.35, July 15, 2018 are +Copyright (c) 2000-2002, 2004, 2006-2018 Glenn Randers-Pehrson, are +derived from libpng-1.0.6, and are distributed according to the same +disclaimer and license as libpng-1.0.6 with the following individuals +added to the list of Contributing Authors: + + Simon-Pierre Cadieux + Eric S. Raymond + Mans Rullgard + Cosmin Truta + Gilles Vollant + James Yu + Mandar Sahastrabuddhe + Google Inc. + Vadim Barkov + +and with the following additions to the disclaimer: + + There is no warranty against interference with your enjoyment of + the library or against infringement. There is no warranty that our + efforts or the library will fulfill any of your particular purposes + or needs. This library is provided with all faults, and the entire + risk of satisfactory quality, performance, accuracy, and effort is + with the user. + +Some files in the "contrib" directory and some configure-generated +files that are distributed with libpng have other copyright owners, and +are released under other open source licenses. + +libpng versions 0.97, January 1998, through 1.0.6, March 20, 2000, are +Copyright (c) 1998-2000 Glenn Randers-Pehrson, are derived from +libpng-0.96, and are distributed according to the same disclaimer and +license as libpng-0.96, with the following individuals added to the +list of Contributing Authors: + + Tom Lane + Glenn Randers-Pehrson + Willem van Schaik + +libpng versions 0.89, June 1996, through 0.96, May 1997, are +Copyright (c) 1996-1997 Andreas Dilger, are derived from libpng-0.88, +and are distributed according to the same disclaimer and license as +libpng-0.88, with the following individuals added to the list of +Contributing Authors: + + John Bowler + Kevin Bracey + Sam Bushell + Magnus Holmgren + Greg Roelofs + Tom Tanner + +Some files in the "scripts" directory have other copyright owners, +but are released under this license. + +libpng versions 0.5, May 1995, through 0.88, January 1996, are +Copyright (c) 1995-1996 Guy Eric Schalnat, Group 42, Inc. + +For the purposes of this copyright and license, "Contributing Authors" +is defined as the following set of individuals: + + Andreas Dilger + Dave Martindale + Guy Eric Schalnat + Paul Schmidt + Tim Wegner + +The PNG Reference Library is supplied "AS IS". The Contributing +Authors and Group 42, Inc. disclaim all warranties, expressed or +implied, including, without limitation, the warranties of +merchantability and of fitness for any purpose. The Contributing +Authors and Group 42, Inc. assume no liability for direct, indirect, +incidental, special, exemplary, or consequential damages, which may +result from the use of the PNG Reference Library, even if advised of +the possibility of such damage. + +Permission is hereby granted to use, copy, modify, and distribute this +source code, or portions hereof, for any purpose, without fee, subject +to the following restrictions: + + 1. The origin of this source code must not be misrepresented. + + 2. Altered versions must be plainly marked as such and must not + be misrepresented as being the original source. + + 3. This Copyright notice may not be removed or altered from any + source or altered source distribution. + +The Contributing Authors and Group 42, Inc. specifically permit, +without fee, and encourage the use of this source code as a component +to supporting the PNG file format in commercial products. If you use +this source code in a product, acknowledgment is not required but would +be appreciated. diff --git a/engines/php/LICENSE.libwebp.txt b/engines/php/LICENSE.libwebp.txt new file mode 100644 index 0000000..7a6f995 --- /dev/null +++ b/engines/php/LICENSE.libwebp.txt @@ -0,0 +1,30 @@ +Copyright (c) 2010, Google Inc. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Google nor the names of its contributors may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/engines/php/LICENSE.libxml2-2.9.10.txt b/engines/php/LICENSE.libxml2-2.9.10.txt new file mode 100644 index 0000000..d613185 --- /dev/null +++ b/engines/php/LICENSE.libxml2-2.9.10.txt @@ -0,0 +1,23 @@ +Except where otherwise noted in the source code (e.g. the files hash.c, +list.c and the trio files, which are covered by a similar licence but +with different Copyright notices) all the files are: + + Copyright (C) 1998-2012 Daniel Veillard. All Rights Reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is fur- +nished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FIT- +NESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.libyuv.txt b/engines/php/LICENSE.libyuv.txt new file mode 100644 index 0000000..c911747 --- /dev/null +++ b/engines/php/LICENSE.libyuv.txt @@ -0,0 +1,29 @@ +Copyright 2011 The LibYuv Project Authors. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Google nor the names of its contributors may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.libzip-1.9.2.txt b/engines/php/LICENSE.libzip-1.9.2.txt new file mode 100644 index 0000000..fa70609 --- /dev/null +++ b/engines/php/LICENSE.libzip-1.9.2.txt @@ -0,0 +1,31 @@ +Copyright (C) 1999-2020 Dieter Baron and Thomas Klausner + +The authors can be contacted at + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +3. The names of the authors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/engines/php/LICENSE.llvm-compiler-rt.txt b/engines/php/LICENSE.llvm-compiler-rt.txt new file mode 100644 index 0000000..5a79a1b --- /dev/null +++ b/engines/php/LICENSE.llvm-compiler-rt.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The compiler_rt library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2015 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/engines/php/LICENSE.musl.txt b/engines/php/LICENSE.musl.txt new file mode 100644 index 0000000..c1628e9 --- /dev/null +++ b/engines/php/LICENSE.musl.txt @@ -0,0 +1,193 @@ +musl as a whole is licensed under the following standard MIT license: + +---------------------------------------------------------------------- +Copyright © 2005-2020 Rich Felker, et al. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +---------------------------------------------------------------------- + +Authors/contributors include: + +A. Wilcox +Ada Worcester +Alex Dowad +Alex Suykov +Alexander Monakov +Andre McCurdy +Andrew Kelley +Anthony G. Basile +Aric Belsito +Arvid Picciani +Bartosz Brachaczek +Benjamin Peterson +Bobby Bingham +Boris Brezillon +Brent Cook +Chris Spiegel +Clément Vasseur +Daniel Micay +Daniel Sabogal +Daurnimator +David Carlier +David Edelsohn +Denys Vlasenko +Dmitry Ivanov +Dmitry V. Levin +Drew DeVault +Emil Renner Berthing +Fangrui Song +Felix Fietkau +Felix Janda +Gianluca Anzolin +Hauke Mehrtens +He X +Hiltjo Posthuma +Isaac Dunham +Jaydeep Patil +Jens Gustedt +Jeremy Huntwork +Jo-Philipp Wich +Joakim Sindholt +John Spencer +Julien Ramseier +Justin Cormack +Kaarle Ritvanen +Khem Raj +Kylie McClain +Leah Neukirchen +Luca Barbato +Luka Perkov +M Farkas-Dyck (Strake) +Mahesh Bodapati +Markus Wichmann +Masanori Ogino +Michael Clark +Michael Forney +Mikhail Kremnyov +Natanael Copa +Nicholas J. Kain +orc +Pascal Cuoq +Patrick Oppenlander +Petr Hosek +Petr Skocik +Pierre Carrier +Reini Urban +Rich Felker +Richard Pennington +Ryan Fairfax +Samuel Holland +Segev Finer +Shiz +sin +Solar Designer +Stefan Kristiansson +Stefan O'Rear +Szabolcs Nagy +Timo Teräs +Trutz Behn +Valentin Ochs +Will Dietz +William Haddon +William Pitcock + +Portions of this software are derived from third-party works licensed +under terms compatible with the above MIT license: + +The TRE regular expression implementation (src/regex/reg* and +src/regex/tre*) is Copyright © 2001-2008 Ville Laurikari and licensed +under a 2-clause BSD license (license text in the source files). The +included version has been heavily modified by Rich Felker in 2012, in +the interests of size, simplicity, and namespace cleanliness. + +Much of the math library code (src/math/* and src/complex/*) is +Copyright © 1993,2004 Sun Microsystems or +Copyright © 2003-2011 David Schultz or +Copyright © 2003-2009 Steven G. Kargl or +Copyright © 2003-2009 Bruce D. Evans or +Copyright © 2008 Stephen L. Moshier or +Copyright © 2017-2018 Arm Limited +and labelled as such in comments in the individual source files. All +have been licensed under extremely permissive terms. + +The ARM memcpy code (src/string/arm/memcpy.S) is Copyright © 2008 +The Android Open Source Project and is licensed under a two-clause BSD +license. It was taken from Bionic libc, used on Android. + +The AArch64 memcpy and memset code (src/string/aarch64/*) are +Copyright © 1999-2019, Arm Limited. + +The implementation of DES for crypt (src/crypt/crypt_des.c) is +Copyright © 1994 David Burren. It is licensed under a BSD license. + +The implementation of blowfish crypt (src/crypt/crypt_blowfish.c) was +originally written by Solar Designer and placed into the public +domain. The code also comes with a fallback permissive license for use +in jurisdictions that may not recognize the public domain. + +The smoothsort implementation (src/stdlib/qsort.c) is Copyright © 2011 +Valentin Ochs and is licensed under an MIT-style license. + +The x86_64 port was written by Nicholas J. Kain and is licensed under +the standard MIT terms. + +The mips and microblaze ports were originally written by Richard +Pennington for use in the ellcc project. The original code was adapted +by Rich Felker for build system and code conventions during upstream +integration. It is licensed under the standard MIT terms. + +The mips64 port was contributed by Imagination Technologies and is +licensed under the standard MIT terms. + +The powerpc port was also originally written by Richard Pennington, +and later supplemented and integrated by John Spencer. It is licensed +under the standard MIT terms. + +All other files which have no copyright comments are original works +produced specifically for use as part of this library, written either +by Rich Felker, the main author of the library, or by one or more +contibutors listed above. Details on authorship of individual files +can be found in the git version control history of the project. The +omission of copyright and license comments in each file is in the +interest of source tree size. + +In addition, permission is hereby granted for all public header files +(include/* and arch/*/bits/*) and crt files intended to be linked into +applications (crt/*, ldso/dlstart.c, and arch/*/crt_arch.h) to omit +the copyright notice and permission notice otherwise required by the +license, and to use these files without any requirement of +attribution. These files include substantial contributions from: + +Bobby Bingham +John Spencer +Nicholas J. Kain +Rich Felker +Richard Pennington +Stefan Kristiansson +Szabolcs Nagy + +all of whom have explicitly granted such permission. + +This file previously contained text expressing a belief that most of +the files covered by the above exception were sufficiently trivial not +to be subject to copyright, resulting in confusion over whether it +negated the permissions granted in the license. In the spirit of +permissive licensing, and of not having licensing issues being an +obstacle to adoption, that text has been removed. diff --git a/engines/php/LICENSE.zlib-1.2.13.txt b/engines/php/LICENSE.zlib-1.2.13.txt new file mode 100644 index 0000000..ab8ee6f --- /dev/null +++ b/engines/php/LICENSE.zlib-1.2.13.txt @@ -0,0 +1,22 @@ +Copyright notice: + + (C) 1995-2022 Jean-loup Gailly and Mark Adler + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + 3. This notice may not be removed or altered from any source distribution. + + Jean-loup Gailly Mark Adler + jloup@gzip.org madler@alumni.caltech.edu diff --git a/engines/php/NOTICE.IANA-TZDATA-2026.1.txt b/engines/php/NOTICE.IANA-TZDATA-2026.1.txt new file mode 100644 index 0000000..cb83c55 --- /dev/null +++ b/engines/php/NOTICE.IANA-TZDATA-2026.1.txt @@ -0,0 +1,12 @@ +IANA Time Zone Database 2026.1 +============================== + +PHP 8.5.8 embeds IANA Time Zone Database version 2026.1 in: + +https://github.com/php/php-src/blob/26b97507444c4fbda072f57dda1820f7b7d5e467/ext/date/lib/timezonedb.h + +The IANA Time Zone Database is public-domain material. Its authoritative +source and public-domain notice are available at: + +https://www.iana.org/time-zones +https://data.iana.org/time-zones/tz-link.html diff --git a/engines/php/NOTICE.PHP-Lexbor.txt b/engines/php/NOTICE.PHP-Lexbor.txt new file mode 100644 index 0000000..f9b79e5 --- /dev/null +++ b/engines/php/NOTICE.PHP-Lexbor.txt @@ -0,0 +1,16 @@ + + Lexbor. + + Copyright 2018-2020 Alexander Borisov + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/engines/php/NOTICE.PHP-REDIST-BINS.txt b/engines/php/NOTICE.PHP-REDIST-BINS.txt new file mode 100644 index 0000000..37f41fd --- /dev/null +++ b/engines/php/NOTICE.PHP-REDIST-BINS.txt @@ -0,0 +1,682 @@ + 1. libmagic (ext/fileinfo) see ext/fileinfo/libmagic/LICENSE + 2. libmbfl (ext/mbstring) see ext/mbstring/libmbfl/LICENSE + 3. pcre2lib (ext/pcre) + 4. ext/standard crypt + 5. ext/standard crypt's blowfish implementation + 6. ext/standard/rand + 7. ext/standard/scanf + 8. ext/standard/strnatcmp.c + 9. ext/standard/uuencode +10. main/snprintf.c +11. main/strlcat +12. main/strlcpy +13. libgd (ext/gd) +14. ext/phar portions of tar implementations +15. ext/phar/zip.c portion extracted from libzip +16. libbcmath (ext/bcmath) see ext/bcmath/libbcmath/LICENSE +17. ext/mbstring/ucgendat portions based on the ucgendat.c from the OpenLDAP +18. avifinfo (ext/standard/libavifinfo) see ext/standard/libavifinfo/LICENSE +19. xxHash (ext/hash/xxhash) +20. Lexbor (ext/lexbor/lexbor) see ext/lexbor/LICENSE +21. Portions of libcperciva (ext/hash/hash_sha_{ni,sse2}.c) see the header in the source file +22. uriparser (ext/uri/uriparser) see ext/uri/uriparser/COPYING + +3. pcre2lib (ext/pcre) + +PCRE2 LICENCE +------------- + +PCRE2 is a library of functions to support regular expressions whose syntax +and semantics are as close as possible to those of the Perl 5 language. + +Releases 10.00 and above of PCRE2 are distributed under the terms of the "BSD" +licence, as specified below, with one exemption for certain binary +redistributions. The documentation for PCRE2, supplied in the "doc" directory, +is distributed under the same terms as the software itself. The data in the +testdata directory is not copyrighted and is in the public domain. + +The basic library functions are written in C and are freestanding. Also +included in the distribution is a just-in-time compiler that can be used to +optimize pattern matching. This is an optional feature that can be omitted when +the library is built. + + +THE BASIC LIBRARY FUNCTIONS +--------------------------- + +Written by: Philip Hazel +Email local part: ph10 +Email domain: cam.ac.uk + +University of Cambridge Computing Service, +Cambridge, England. + +Copyright (c) 1997-2019 University of Cambridge +All rights reserved. + + +PCRE2 JUST-IN-TIME COMPILATION SUPPORT +-------------------------------------- + +Written by: Zoltan Herczeg +Email local part: hzmester +Email domain: freemail.hu + +Copyright(c) 2010-2019 Zoltan Herczeg +All rights reserved. + + +STACK-LESS JUST-IN-TIME COMPILER +-------------------------------- + +Written by: Zoltan Herczeg +Email local part: hzmester +Email domain: freemail.hu + +Copyright(c) 2009-2019 Zoltan Herczeg +All rights reserved. + + +THE "BSD" LICENCE +----------------- + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notices, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notices, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + * Neither the name of the University of Cambridge nor the names of any + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + + +EXEMPTION FOR BINARY LIBRARY-LIKE PACKAGES +------------------------------------------ + +The second condition in the BSD licence (covering binary redistributions) does +not apply all the way down a chain of software. If binary package A includes +PCRE2, it must respect the condition, but if package B is software that +includes package A, the condition is not imposed on package B unless it uses +PCRE2 independently. + +End + + +4. ext/standard crypt + +FreeSec: libcrypt for NetBSD + +Copyright (c) 1994 David Burren +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + + +5. ext/standard crypt's blowfish implementation + +The crypt_blowfish homepage is: + +http://www.openwall.com/crypt/ + +This code comes from John the Ripper password cracker, with reentrant +and crypt(3) interfaces added, but optimizations specific to password +cracking removed. + +Written by Solar Designer in 1998-2011. +No copyright is claimed, and the software is hereby placed in the public +domain. In case this attempt to disclaim copyright and place the software +in the public domain is deemed null and void, then the software is +Copyright (c) 1998-2011 Solar Designer and it is hereby released to the +general public under the following terms: + +Redistribution and use in source and binary forms, with or without +modification, are permitted. + +There's ABSOLUTELY NO WARRANTY, express or implied. + +It is my intent that you should be able to use this on your system, +as part of a software package, or anywhere else to improve security, +ensure compatibility, or for any other purpose. I would appreciate +it if you give credit where it is due and keep your modifications in +the public domain as well, but I don't require that in order to let +you place this code and any modifications you make under a license +of your choice. + +This implementation is mostly compatible with OpenBSD's bcrypt.c (prefix +"$2a$") by Niels Provos , and uses some of his +ideas. The password hashing algorithm was designed by David Mazieres +. For more information on the level of compatibility, +please refer to the comments in BF_set_key() and to the crypt(3) man page +included in the crypt_blowfish tarball. + +There's a paper on the algorithm that explains its design decisions: + +http://www.usenix.org/events/usenix99/provos.html + +Some of the tricks in BF_ROUND might be inspired by Eric Young's +Blowfish library (I can't be sure if I would think of something if I +hadn't seen his code). + + +6. ext/standard/rand + +The following php_mt_...() functions are based on a C++ class MTRand by +Richard J. Wagner. For more information see the web page at +http://www-personal.engin.umich.edu/~wagnerr/MersenneTwister.html + +Mersenne Twister random number generator -- a C++ class MTRand +Based on code by Makoto Matsumoto, Takuji Nishimura, and Shawn Cokus +Richard J. Wagner v1.0 15 May 2003 rjwagner@writeme.com + +The Mersenne Twister is an algorithm for generating random numbers. It +was designed with consideration of the flaws in various other generators. +The period, 2^19937-1, and the order of equidistribution, 623 dimensions, +are far greater. The generator is also fast; it avoids multiplication and +division, and it benefits from caches and pipelines. For more information +see the inventors' web page at http://www.math.keio.ac.jp/~matumoto/emt.html + +Reference +M. Matsumoto and T. Nishimura, "Mersenne Twister: A 623-Dimensionally +Equidistributed Uniform Pseudo-Random Number Generator", ACM Transactions on +Modeling and Computer Simulation, Vol. 8, No. 1, January 1998, pp 3-30. + +Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, +Copyright (C) 2000 - 2003, Richard J. Wagner +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. The names of its contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +7. ext/standard/scanf + +scanf.c -- + +This file contains the base code which implements sscanf and by extension +fscanf. Original code is from TCL8.3.0 and bears the following copyright: + +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., Scriptics Corporation, +and other parties. The following terms apply to all files associated +with the software unless explicitly disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. + + +8. ext/standard/strnatcmp.c + +strnatcmp.c -- Perform 'natural order' comparisons of strings in C. +Copyright (C) 2000 by Martin Pool + +This software is provided 'as-is', without any express or implied +warranty. In no event will the authors be held liable for any damages +arising from the use of this software. + +Permission is granted to anyone to use this software for any purpose, +including commercial applications, and to alter it and redistribute it +freely, subject to the following restrictions: + +1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. +2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. +3. This notice may not be removed or altered from any source distribution. + + +9. ext/standard/uuencode + +Portions of this code are based on Berkeley's uuencode/uudecode +implementation. + +Copyright (c) 1983, 1993 +The Regents of the University of California. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. All advertising materials mentioning features or use of this software + must display the following acknowledgement: +This product includes software developed by the University of +California, Berkeley and its contributors. +4. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + + +10. main/snprintf.c + +Copyright (c) 2002, 2006 Todd C. Miller + +Permission to use, copy, modify, and distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES +WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR +ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES +WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN +ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF +OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + +Sponsored in part by the Defense Advanced Research Projects +Agency (DARPA) and Air Force Research Laboratory, Air Force +Materiel Command, USAF, under agreement number F39502-99-1-0512. + +main/spprintf +Copyright (c) 1995-1998 The Apache Group. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +3. All advertising materials mentioning features or use of this + software must display the following acknowledgment: + "This product includes software developed by the Apache Group + for use in the Apache HTTP server project (http://www.apache.org/)." + +4. The names "Apache Server" and "Apache Group" must not be used to + endorse or promote products derived from this software without + prior written permission. + +5. Redistributions of any form whatsoever must retain the following + acknowledgment: + "This product includes software developed by the Apache Group + for use in the Apache HTTP server project (http://www.apache.org/)." + +THIS SOFTWARE IS PROVIDED BY THE APACHE GROUP ``AS IS'' AND ANY +EXPRESSED OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE APACHE GROUP OR +ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +OF THE POSSIBILITY OF SUCH DAMAGE. +==================================================================== + +This software consists of voluntary contributions made by many +individuals on behalf of the Apache Group and was originally based +on public domain software written at the National Center for +Supercomputing Applications, University of Illinois, Urbana-Champaign. +For more information on the Apache Group and the Apache HTTP server +project, please see . + +This code is based on, and used with the permission of, the +SIO stdio-replacement strx_* functions by Panos Tsirigotis + for xinetd. + + +11. main/strlcat +12. main/strlcpy + +Copyright (c) 1998 Todd C. Miller +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +13. libgd (ext/gd) + +* Portions copyright 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + 2002, 2003, 2004 by Cold Spring Harbor Laboratory. Funded under + Grant P41-RR02188 by the National Institutes of Health. + +* Portions copyright 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, + 2004 by Boutell.Com, Inc. + +* Portions relating to GD2 format copyright 1999, 2000, 2001, 2002, + 2003, 2004 Philip Warner. + +* Portions relating to PNG copyright 1999, 2000, 2001, 2002, 2003, + 2004 Greg Roelofs. + +* Portions relating to gdttf.c copyright 1999, 2000, 2001, 2002, + 2003, 2004 John Ellson (ellson@graphviz.org). + +* Portions relating to gdft.c copyright 2001, 2002, 2003, 2004 John + Ellson (ellson@graphviz.org). + +* Portions copyright 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 + Pierre-Alain Joye (pierre@libgd.org). + +* Portions relating to JPEG and to color quantization copyright + 2000, 2001, 2002, 2003, 2004, Doug Becker and copyright (C) 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 Thomas + G. Lane. This software is based in part on the work of the + Independent JPEG Group. See the file README-JPEG.TXT for more + information. + +* Portions relating to GIF compression copyright 1989 by Jef + Poskanzer and David Rowley, with modifications for thread safety + by Thomas Boutell. + +* Portions relating to GIF decompression copyright 1990, 1991, 1993 + by David Koblas, with modifications for thread safety by Thomas + Boutell. + +* Portions relating to WBMP copyright 2000, 2001, 2002, 2003, 2004 + Maurice Szmurlo and Johan Van den Brande. + +* Portions relating to GIF animations copyright 2004 Jaakko Hyvätti + (jaakko.hyvatti@iki.fi) + +Permission has been granted to copy, distribute and modify gd in +any context without fee, including a commercial application, +provided that this notice is present in user-accessible supporting +documentation. + +This does not affect your ownership of the derived work itself, +and the intent is to assure proper credit for the authors of gd, +not to interfere with your productive use of gd. If you have +questions, ask. "Derived works" includes all programs that utilize +the library. Credit must be given in user-accessible +documentation. + +This software is provided "AS IS." The copyright holders disclaim +all warranties, either express or implied, including but not +limited to implied warranties of merchantability and fitness for a +particular purpose, with respect to this code and accompanying +documentation. + +Although their code does not appear in the current release, the +authors wish to thank David Koblas, David Rowley, and Hutchison +Avenue Software Corporation for their prior contributions. + +END OF COPYRIGHT STATEMENT + + +14. ext/phar portions of tar implementations + +portions of tar implementations in ext/phar - phar_tar_octal() are based on an +implementation by Tim Kientzle from libarchive, licensed with this license: + + Copyright (c) 2003-2007 Tim Kientzle + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + IN NO EVENT SHALL THE AUTHOR(S) BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +15. ext/phar/zip.c portion extracted from libzip + +zip_dirent.c -- read directory entry (local or central), clean dirent +Copyright (C) 1999, 2003, 2004, 2005 Dieter Baron and Thomas Klausner + +This function is part of libzip, a library to manipulate ZIP archives. +The authors can be contacted at + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. +3. The names of the authors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN +IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +17. ext/mbstring/ucgendat portions based on the ucgendat.c from the OpenLDAP + +The OpenLDAP Public License + Version 2.8, 17 August 2003 + +Redistribution and use of this software and associated documentation +("Software"), with or without modification, are permitted provided +that the following conditions are met: + +1. Redistributions in source form must retain copyright statements + and notices, + +2. Redistributions in binary form must reproduce applicable copyright + statements and notices, this list of conditions, and the following + disclaimer in the documentation and/or other materials provided + with the distribution, and + +3. Redistributions must contain a verbatim copy of this document. + +The OpenLDAP Foundation may revise this license from time to time. +Each revision is distinguished by a version number. You may use +this Software under terms of this license revision or under the +terms of any subsequent revision of the license. + +THIS SOFTWARE IS PROVIDED BY THE OPENLDAP FOUNDATION AND ITS +CONTRIBUTORS ``AS IS'' AND ANY EXPRESSED OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT +SHALL THE OPENLDAP FOUNDATION, ITS CONTRIBUTORS, OR THE AUTHOR(S) +OR OWNER(S) OF THE SOFTWARE BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +The names of the authors and copyright holders must not be used in +advertising or otherwise to promote the sale, use or other dealing +in this Software without specific, written prior permission. Title +to copyright in this Software shall at all times remain with copyright +holders. + +OpenLDAP is a registered trademark of the OpenLDAP Foundation. + +Copyright 1999-2003 The OpenLDAP Foundation, Redwood City, +California, USA. All Rights Reserved. Permission to copy and +distribute verbatim copies of this document is granted. + + +19. xxHash + +xxHash - Extremely Fast Hash algorithm +Header File +Copyright (C) 2012-2020 Yann Collet + +BSD 2-Clause License (https://www.opensource.org/licenses/bsd-license.php) + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following disclaimer + in the documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +You can contact the author at: + - xxHash homepage: https://www.xxhash.com + - xxHash source repository: https://github.com/Cyan4973/xxHash diff --git a/engines/php/NOTICE.PHP-public-domain-hash-code.txt b/engines/php/NOTICE.PHP-public-domain-hash-code.txt new file mode 100644 index 0000000..cf64fdd --- /dev/null +++ b/engines/php/NOTICE.PHP-public-domain-hash-code.txt @@ -0,0 +1,45 @@ +PHP 8.5.8 bundled hashing notices +================================= + +Source identity: php-src commit 26b97507444c4fbda072f57dda1820f7b7d5e467. +The final PHP runtime exposes the corresponding MurmurHash3, SHA-3 and FNV +algorithms. The exact source-file identities and upstream statements follow. + +ext/hash/murmur/PMurHash.c +SHA-256: 1250fc4212bf980dfd97efb3dfae8fed0dac3bdcfec3f2605a1c19a65a0141ce + +MurmurHash3 was written by Austin Appleby, and is placed in the public +domain. + +This implementation was written by Shane Day, and is also public domain. + +ext/hash/murmur/PMurHash128.c +SHA-256: 09233b7dedf9c8d35da5ba3ffaa57f6e66fa89bb85b32cc9c69b3342d6c164cf + +MurmurHash3 was written by Austin Appleby, and is placed in the public +domain. + +This is a c++ implementation of MurmurHash3_128 with support for progressive +processing based on PMurHash implementation written by Shane Day. + +ext/hash/sha3/generic64lc/KeccakHash.c +SHA-256: 78f55671fa3eb01d6bdc11a22e1c2a58b94340983186733ac0fbce39a6065220 + +Implementation by the Keccak, Keyak and Ketje Teams, namely, Guido Bertoni, +Joan Daemen, Michaël Peeters, Gilles Van Assche and Ronny Van Keer, hereby +denoted as "the implementer". + +For more information, feedback or questions, please refer to our websites: +http://keccak.noekeon.org/ +http://keyak.noekeon.org/ +http://ketje.noekeon.org/ + +To the extent possible under law, the implementer has waived all copyright +and related or neighboring rights to the source code in this file. +http://creativecommons.org/publicdomain/zero/1.0/ + +ext/hash/hash_fnv.c +SHA-256: 7ed6c5a27cb567babb9202ed281f1c7446331f75e125bf11dc9d6f40f4a6266b + +Based on the public domain algorithm found at: +http://www.isthe.com/chongo/tech/comp/fnv/index.html diff --git a/engines/php/NOTICE.SQLite-3.51.0.txt b/engines/php/NOTICE.SQLite-3.51.0.txt new file mode 100644 index 0000000..daa16a8 --- /dev/null +++ b/engines/php/NOTICE.SQLite-3.51.0.txt @@ -0,0 +1,20 @@ +SQLite 3.51.0 public-domain notice +================================== + +Source archive: https://sqlite.org/2025/sqlite-autoconf-3510000.tar.gz +Source archive SHA-256: +42e26dfdd96aa2e6b1b1be5c88b0887f9959093f650d693cb02eb9c36d146ca5 +Amalgamation source identifier: +fb2c931ae597f8d00a37574ff67aeed3eced + +The exact sqlite3.c amalgamation in that archive states: + +The author disclaims copyright to this source code. In place of +a legal notice, here is a blessing: + + May you do good and not evil. + May you find forgiveness for yourself and forgive others. + May you share freely, never taking more than you give. + +Authoritative copyright and public-domain status: +https://sqlite.org/copyright.html diff --git a/engines/php/NOTICE.dlmalloc-2.8.6.txt b/engines/php/NOTICE.dlmalloc-2.8.6.txt new file mode 100644 index 0000000..1a62907 --- /dev/null +++ b/engines/php/NOTICE.dlmalloc-2.8.6.txt @@ -0,0 +1,14 @@ +dlmalloc 2.8.6 public-domain notice +==================================== + +The exact source bundled by Emscripten 4.0.19 is: + +https://github.com/emscripten-core/emscripten/blob/08e2de1031913e4ba7963b1c56f35f036a7d4d56/system/lib/dlmalloc.c + +Its source header states: + +This is a version (aka dlmalloc) of malloc/free/realloc written by +Doug Lea and released to the public domain, as explained at +http://creativecommons.org/publicdomain/zero/1.0/ + +Version 2.8.6, 29 August 2012. diff --git a/engines/php/PATENTS.PHP-libavifinfo.txt b/engines/php/PATENTS.PHP-libavifinfo.txt new file mode 100644 index 0000000..826644b --- /dev/null +++ b/engines/php/PATENTS.PHP-libavifinfo.txt @@ -0,0 +1,107 @@ +Alliance for Open Media Patent License 1.0 + +1. License Terms. + +1.1. Patent License. Subject to the terms and conditions of this License, each + Licensor, on behalf of itself and successors in interest and assigns, + grants Licensee a non-sublicensable, perpetual, worldwide, non-exclusive, + no-charge, royalty-free, irrevocable (except as expressly stated in this + License) patent license to its Necessary Claims to make, use, sell, offer + for sale, import or distribute any Implementation. + +1.2. Conditions. + +1.2.1. Availability. As a condition to the grant of rights to Licensee to make, + sell, offer for sale, import or distribute an Implementation under + Section 1.1, Licensee must make its Necessary Claims available under + this License, and must reproduce this License with any Implementation + as follows: + + a. For distribution in source code, by including this License in the + root directory of the source code with its Implementation. + + b. For distribution in any other form (including binary, object form, + and/or hardware description code (e.g., HDL, RTL, Gate Level Netlist, + GDSII, etc.)), by including this License in the documentation, legal + notices, and/or other written materials provided with the + Implementation. + +1.2.2. Additional Conditions. This license is directly from Licensor to + Licensee. Licensee acknowledges as a condition of benefiting from it + that no rights from Licensor are received from suppliers, distributors, + or otherwise in connection with this License. + +1.3. Defensive Termination. If any Licensee, its Affiliates, or its agents + initiates patent litigation or files, maintains, or voluntarily + participates in a lawsuit against another entity or any person asserting + that any Implementation infringes Necessary Claims, any patent licenses + granted under this License directly to the Licensee are immediately + terminated as of the date of the initiation of action unless 1) that suit + was in response to a corresponding suit regarding an Implementation first + brought against an initiating entity, or 2) that suit was brought to + enforce the terms of this License (including intervention in a third-party + action by a Licensee). + +1.4. Disclaimers. The Reference Implementation and Specification are provided + "AS IS" and without warranty. The entire risk as to implementing or + otherwise using the Reference Implementation or Specification is assumed + by the implementer and user. Licensor expressly disclaims any warranties + (express, implied, or otherwise), including implied warranties of + merchantability, non-infringement, fitness for a particular purpose, or + title, related to the material. IN NO EVENT WILL LICENSOR BE LIABLE TO + ANY OTHER PARTY FOR LOST PROFITS OR ANY FORM OF INDIRECT, SPECIAL, + INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY CHARACTER FROM ANY CAUSES OF + ACTION OF ANY KIND WITH RESPECT TO THIS LICENSE, WHETHER BASED ON BREACH + OF CONTRACT, TORT (INCLUDING NEGLIGENCE), OR OTHERWISE, AND WHETHER OR + NOT THE OTHER PARTRY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +2. Definitions. + +2.1. Affiliate. "Affiliate" means an entity that directly or indirectly + Controls, is Controlled by, or is under common Control of that party. + +2.2. Control. "Control" means direct or indirect control of more than 50% of + the voting power to elect directors of that corporation, or for any other + entity, the power to direct management of such entity. + +2.3. Decoder. "Decoder" means any decoder that conforms fully with all + non-optional portions of the Specification. + +2.4. Encoder. "Encoder" means any encoder that produces a bitstream that can + be decoded by a Decoder only to the extent it produces such a bitstream. + +2.5. Final Deliverable. "Final Deliverable" means the final version of a + deliverable approved by the Alliance for Open Media as a Final + Deliverable. + +2.6. Implementation. "Implementation" means any implementation, including the + Reference Implementation, that is an Encoder and/or a Decoder. An + Implementation also includes components of an Implementation only to the + extent they are used as part of an Implementation. + +2.7. License. "License" means this license. + +2.8. Licensee. "Licensee" means any person or entity who exercises patent + rights granted under this License. + +2.9. Licensor. "Licensor" means (i) any Licensee that makes, sells, offers + for sale, imports or distributes any Implementation, or (ii) a person + or entity that has a licensing obligation to the Implementation as a + result of its membership and/or participation in the Alliance for Open + Media working group that developed the Specification. + +2.10. Necessary Claims. "Necessary Claims" means all claims of patents or + patent applications, (a) that currently or at any time in the future, + are owned or controlled by the Licensor, and (b) (i) would be an + Essential Claim as defined by the W3C Policy as of February 5, 2004 + (https://www.w3.org/Consortium/Patent-Policy-20040205/#def-essential) + as if the Specification was a W3C Recommendation; or (ii) are infringed + by the Reference Implementation. + +2.11. Reference Implementation. "Reference Implementation" means an Encoder + and/or Decoder released by the Alliance for Open Media as a Final + Deliverable. + +2.12. Specification. "Specification" means the specification designated by + the Alliance for Open Media as a Final Deliverable for which this + License was issued. diff --git a/engines/php/PATENTS.libaom-3.12.1.txt b/engines/php/PATENTS.libaom-3.12.1.txt new file mode 100644 index 0000000..fc4de9e --- /dev/null +++ b/engines/php/PATENTS.libaom-3.12.1.txt @@ -0,0 +1,108 @@ +Alliance for Open Media Patent License 1.0 + +1. License Terms. + +1.1. Patent License. Subject to the terms and conditions of this License, each + Licensor, on behalf of itself and successors in interest and assigns, + grants Licensee a non-sublicensable, perpetual, worldwide, non-exclusive, + no-charge, royalty-free, irrevocable (except as expressly stated in this + License) patent license to its Necessary Claims to make, use, sell, offer + for sale, import or distribute any Implementation. + +1.2. Conditions. + +1.2.1. Availability. As a condition to the grant of rights to Licensee to make, + sell, offer for sale, import or distribute an Implementation under + Section 1.1, Licensee must make its Necessary Claims available under + this License, and must reproduce this License with any Implementation + as follows: + + a. For distribution in source code, by including this License in the + root directory of the source code with its Implementation. + + b. For distribution in any other form (including binary, object form, + and/or hardware description code (e.g., HDL, RTL, Gate Level Netlist, + GDSII, etc.)), by including this License in the documentation, legal + notices, and/or other written materials provided with the + Implementation. + +1.2.2. Additional Conditions. This license is directly from Licensor to + Licensee. Licensee acknowledges as a condition of benefiting from it + that no rights from Licensor are received from suppliers, distributors, + or otherwise in connection with this License. + +1.3. Defensive Termination. If any Licensee, its Affiliates, or its agents + initiates patent litigation or files, maintains, or voluntarily + participates in a lawsuit against another entity or any person asserting + that any Implementation infringes Necessary Claims, any patent licenses + granted under this License directly to the Licensee are immediately + terminated as of the date of the initiation of action unless 1) that suit + was in response to a corresponding suit regarding an Implementation first + brought against an initiating entity, or 2) that suit was brought to + enforce the terms of this License (including intervention in a third-party + action by a Licensee). + +1.4. Disclaimers. The Reference Implementation and Specification are provided + "AS IS" and without warranty. The entire risk as to implementing or + otherwise using the Reference Implementation or Specification is assumed + by the implementer and user. Licensor expressly disclaims any warranties + (express, implied, or otherwise), including implied warranties of + merchantability, non-infringement, fitness for a particular purpose, or + title, related to the material. IN NO EVENT WILL LICENSOR BE LIABLE TO + ANY OTHER PARTY FOR LOST PROFITS OR ANY FORM OF INDIRECT, SPECIAL, + INCIDENTAL, OR CONSEQUENTIAL DAMAGES OF ANY CHARACTER FROM ANY CAUSES OF + ACTION OF ANY KIND WITH RESPECT TO THIS LICENSE, WHETHER BASED ON BREACH + OF CONTRACT, TORT (INCLUDING NEGLIGENCE), OR OTHERWISE, AND WHETHER OR + NOT THE OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +2. Definitions. + +2.1. Affiliate. "Affiliate" means an entity that directly or indirectly + Controls, is Controlled by, or is under common Control of that party. + +2.2. Control. "Control" means direct or indirect control of more than 50% of + the voting power to elect directors of that corporation, or for any other + entity, the power to direct management of such entity. + +2.3. Decoder. "Decoder" means any decoder that conforms fully with all + non-optional portions of the Specification. + +2.4. Encoder. "Encoder" means any encoder that produces a bitstream that can + be decoded by a Decoder only to the extent it produces such a bitstream. + +2.5. Final Deliverable. "Final Deliverable" means the final version of a + deliverable approved by the Alliance for Open Media as a Final + Deliverable. + +2.6. Implementation. "Implementation" means any implementation, including the + Reference Implementation, that is an Encoder and/or a Decoder. An + Implementation also includes components of an Implementation only to the + extent they are used as part of an Implementation. + +2.7. License. "License" means this license. + +2.8. Licensee. "Licensee" means any person or entity who exercises patent + rights granted under this License. + +2.9. Licensor. "Licensor" means (i) any Licensee that makes, sells, offers + for sale, imports or distributes any Implementation, or (ii) a person + or entity that has a licensing obligation to the Implementation as a + result of its membership and/or participation in the Alliance for Open + Media working group that developed the Specification. + +2.10. Necessary Claims. "Necessary Claims" means all claims of patents or + patent applications, (a) that currently or at any time in the future, + are owned or controlled by the Licensor, and (b) (i) would be an + Essential Claim as defined by the W3C Policy as of February 5, 2004 + (https://www.w3.org/Consortium/Patent-Policy-20040205/#def-essential) + as if the Specification was a W3C Recommendation; or (ii) are infringed + by the Reference Implementation. + +2.11. Reference Implementation. "Reference Implementation" means an Encoder + and/or Decoder released by the Alliance for Open Media as a Final + Deliverable. + +2.12. Specification. "Specification" means the specification designated by + the Alliance for Open Media as a Final Deliverable for which this + License was issued. + diff --git a/engines/php/PATENTS.libwebp.txt b/engines/php/PATENTS.libwebp.txt new file mode 100644 index 0000000..caedf60 --- /dev/null +++ b/engines/php/PATENTS.libwebp.txt @@ -0,0 +1,23 @@ +Additional IP Rights Grant (Patents) +------------------------------------ + +"These implementations" means the copyrightable works that implement the WebM +codecs distributed by Google as part of the WebM Project. + +Google hereby grants to you a perpetual, worldwide, non-exclusive, no-charge, +royalty-free, irrevocable (except as stated in this section) patent license to +make, have made, use, offer to sell, sell, import, transfer, and otherwise +run, modify and propagate the contents of these implementations of WebM, where +such license applies only to those patent claims, both currently owned by +Google and acquired in the future, licensable by Google that are necessarily +infringed by these implementations of WebM. This grant does not include claims +that would be infringed only as a consequence of further modification of these +implementations. If you or your agent or exclusive licensee institute or order +or agree to the institution of patent litigation or any other patent +enforcement activity against any entity (including a cross-claim or +counterclaim in a lawsuit) alleging that any of these implementations of WebM +or any code incorporated within any of these implementations of WebM +constitute direct or contributory patent infringement, or inducement of +patent infringement, then any patent rights granted to you under this License +for these implementations of WebM shall terminate as of the date such +litigation is filed. diff --git a/engines/php/README.md b/engines/php/README.md new file mode 100644 index 0000000..5b33925 --- /dev/null +++ b/engines/php/README.md @@ -0,0 +1,83 @@ +# PHP preg regular-expression engine + +Regex Tools runs patterns in the actual PHP 8.5.8 `preg` implementation, +backed by PCRE2 10.44. The browser runtime is the Asyncify build from +`@php-wasm/web-8-5@3.1.46`; its host API is +`@php-wasm/universal@3.1.46`. + +The fixed `bridge.php` file is installed in PHP's private virtual filesystem. +Pattern, flags, subject, limits, and replacement are written separately as +JSON. No user-controlled value is evaluated or interpolated into PHP source. +The bridge selects a safe preg delimiter and passes only validated modifiers. + +PHP reports `PREG_OFFSET_CAPTURE` positions as UTF-8 bytes. The adapter retains +those native ranges and normalizes code-point boundaries to browser UTF-16. +Unpaired UTF-16 surrogates are rejected before entering the runtime. Without +the `u` modifier, a byte-oriented match that splits a UTF-8 character is +reported as unsupported because it cannot be represented losslessly in a +browser string. + +Replacement never asks `preg_replace` to materialize an unbounded result. +Native `preg_match` records remain authoritative; a fixed bridge parser mirrors +PHP 8.5.8's `preg_get_backref()` rules and streams literal/capture bytes into +the requested cap. The identity self-test compares that fixed implementation +with `preg_replace` only as a parity oracle. The bridge returns bounded bytes as +base64 so JSON escaping cannot unexpectedly multiply the transport envelope. +A timeout, cancellation, supersession, or crash terminates the dedicated +worker and its entire PHP WebAssembly heap. + +## Exact source and native-component boundary + +The shipped `php.wasm` is SHA-256 +`ed97ea5422dbf23e0687c98203cc8c6d7f2772a3d71b03d4991d2fdd93a048f0` +from `@php-wasm/web-8-5@3.1.46`. That npm package records WordPress Playground +commit `581c7c172428159eb4e6c5309054a568cd39a97a` (`v3.1.46`). The PHP source +base is tag `php-8.5.8`, tag object +`8a3b5a5124006c11a8fbfce838ec7dd53615cc77`, peeled commit +`26b97507444c4fbda072f57dda1820f7b7d5e467`; the final main module uses +Emscripten 4.0.19 at +`08e2de1031913e4ba7963b1c56f35f036a7d4d56`. + +`native-components.json` is the machine-readable inventory for this exact +binary. It records 32 linked source/component surfaces: + +- PHP and its bundled PCRE2, libbcmath, timelib/tzdata, libmagic, Lexbor, + libmbfl, uriparser and libavifinfo code; +- zlib, libzip, libxml2, SQLite, libgd, libjpeg-turbo, libpng, + libwebp/libsharpyuv, libavif, libaom/libyuv, OpenSSL, curl, libiconv and + Oniguruma; +- the WordPress Playground wrapper plus the Emscripten runtime, musl, + compiler-rt, libc++, libc++abi and dlmalloc surfaces. + +Every versioned external archive or Git route, available archive hash/commit, +runtime evidence, licence/notice route and patent notice is recorded there. +The Oniguruma recipe is the one upstream exception: it cloned its default +branch without a revision. The inventory therefore does not falsely identify +the release tag as the build commit. It pins the exact committed `libonig.a` +blob and SHA-256, its Emscripten 4.0.5 compiler provenance, the installed header +blob, runtime version 6.9.10, audited release source and the bounded upstream +source interval `005482a…3eb317d` before the header changed. + +The same inventory explicitly records why GMP, libsodium, tidy and ICU/intl +names found by a raw string scan are not linked extensions: those names are +Zend optimizer metadata or an unshipped side module, and the runtime verifier +asserts their absence. It also records that FreeType is disabled in the exact +libgd recipe even though the recipe's synthetic `gdlib-config --features` +string makes `gd_info()` report it, that ImageMagick/imagick is disabled, and +that libavif's local AOM 3.12.1—not the adjacent standalone AOM 3.13.1 +recipe—is linked. Positive extension/library versions, negative detections and +AOM/libjpeg binary markers are executable pack-verification gates. + +## Redistribution + +The pack explicitly elects PHP License version 4 (`BSD-3-Clause`) for the PHP +8.5.8 codebase through the earlier licence's later-version option. +The pack also carries the exact Zend Engine licence, php-src's official binary +redistribution notice, the CLI HTTP parser's MIT terms, and the +public-domain, CC0 and FNV permission statements for the linked hash +implementations. `@php-wasm` retains GPL-2.0-or-later. Linked LGPL, BSD, MIT, +Apache, zlib, public-domain and patent-notice obligations are carried in 42 +independently SHA-256-pinned legal files. The builder copies the inventory and +those exact files into the closed pack; `SHA256SUMS` and +`engine-metadata.json` cover them again, but cannot replace the independent +hashes in the verifier lock. diff --git a/engines/php/bridge.php b/engines/php/bridge.php new file mode 100644 index 0000000..0744640 --- /dev/null +++ b/engines/php/bridge.php @@ -0,0 +1,1082 @@ + + */ +function regex_tools_failure(Throwable $error): array +{ + $phase = $error instanceof RegexToolsFailure ? $error->phase : 'bridge'; + $code = $error instanceof RegexToolsFailure + ? $error->failureCode + : 'bridge-error'; + $message = $error->getMessage(); + if (preg_match('//u', $message) !== 1) { + $message = 'The PHP runtime reported a non-UTF-8 error.'; + } + if (strlen($message) > REGEX_TOOLS_MAX_ERROR_CHARACTERS) { + $message = substr($message, 0, REGEX_TOOLS_MAX_ERROR_CHARACTERS - 3); + while ($message !== '' && preg_match('//u', $message) !== 1) { + $message = substr($message, 0, -1); + } + $message .= '…'; + } + $result = [ + 'abi' => REGEX_TOOLS_ABI, + 'ok' => false, + 'phase' => $phase, + 'code' => $code, + 'message' => $message, + ]; + if ($error instanceof RegexToolsFailure && $error->patternOffset !== null) { + $result['position'] = $error->patternOffset; + } + return $result; +} + +function regex_tools_preg_warning( + int $severity, + string $message, + string $file, + int $line, +): never { + unset($file, $line); + $offset = null; + if (preg_match('/\\bat offset (\\d+)\\z/D', $message, $offsetMatch) === 1) { + $offset = (int) $offsetMatch[1]; + } + throw new RegexToolsFailure( + 'compile', + 'compile-error', + preg_replace('/^preg_[a-z_]+\\(\\):\\s*/', '', $message) ?? $message, + $offset, + ); +} + +set_error_handler( + static function ( + int $severity, + string $message, + string $file, + int $line, + ): never { + regex_tools_preg_warning($severity, $message, $file, $line); + }, +); +error_reporting(E_ALL); +ini_set('display_errors', '0'); +ini_set('html_errors', '0'); + +/** + * @param mixed $condition + */ +function regex_tools_require( + mixed $condition, + string $message, + string $code = 'invalid-request', +): void { + if (!$condition) { + throw new RegexToolsFailure('bridge', $code, $message); + } +} + +function regex_tools_within_utf16_limit( + string $value, + int $maximumUnits, +): bool { + $units = 0; + $length = strlen($value); + for ($index = 0; $index < $length;) { + $leadingByte = ord($value[$index]); + if ($leadingByte < 0x80) { + $index++; + $units++; + } elseif ($leadingByte < 0xE0) { + $index += 2; + $units++; + } elseif ($leadingByte < 0xF0) { + $index += 3; + $units++; + } else { + $index += 4; + $units += 2; + } + if ($units > $maximumUnits) { + return false; + } + } + return true; +} + +/** + * @return array + */ +function regex_tools_request(): array +{ + $encoded = file_get_contents(REGEX_TOOLS_REQUEST); + regex_tools_require( + is_string($encoded), + 'The PHP bridge request file could not be read.', + ); + try { + $request = json_decode( + $encoded, + true, + 64, + JSON_THROW_ON_ERROR | JSON_BIGINT_AS_STRING, + ); + } catch (JsonException $error) { + throw new RegexToolsFailure( + 'bridge', + 'invalid-json', + 'The PHP bridge request is not valid JSON: ' . $error->getMessage(), + ); + } + regex_tools_require( + is_array($request) && !array_is_list($request), + 'The PHP bridge request must be a JSON object.', + ); + regex_tools_require( + ($request['abi'] ?? null) === REGEX_TOOLS_ABI, + 'The PHP bridge ABI does not match.', + 'abi-mismatch', + ); + return $request; +} + +/** + * @param array $request + */ +function regex_tools_validate_request(array $request): void +{ + $operation = $request['operation'] ?? null; + regex_tools_require( + $operation === 'execute' || $operation === 'replace', + 'The PHP bridge operation is unsupported.', + 'invalid-operation', + ); + foreach (['pattern', 'flags', 'subject'] as $field) { + regex_tools_require( + isset($request[$field]) && is_string($request[$field]), + "The PHP bridge field {$field} must be text.", + ); + } + regex_tools_require( + preg_match('//u', $request['pattern']) === 1 + && preg_match('//u', $request['subject']) === 1, + 'PHP preg inputs must be valid UTF-8.', + 'invalid-utf8', + ); + regex_tools_require( + regex_tools_within_utf16_limit( + $request['pattern'], + REGEX_TOOLS_MAX_PATTERN_UTF16, + ), + 'The PHP pattern exceeds the UTF-16 limit.', + 'pattern-limit', + ); + $flags = $request['flags']; + regex_tools_require( + strspn($flags, REGEX_TOOLS_FLAGS) === strlen($flags) + && count(array_unique(str_split($flags))) === strlen($flags), + 'The PHP bridge flags are invalid.', + 'invalid-flags', + ); + $options = $request['options'] ?? []; + regex_tools_require( + is_array($options) && count($options) === 0, + 'The PHP preg engine does not accept options.', + 'invalid-options', + ); + regex_tools_require( + isset($request['maximumMatches']) + && is_int($request['maximumMatches']) + && $request['maximumMatches'] >= 1 + && $request['maximumMatches'] <= REGEX_TOOLS_MAX_MATCHES, + 'The PHP match limit is outside the bounded contract.', + ); + regex_tools_require( + isset($request['maximumCaptureRows']) + && is_int($request['maximumCaptureRows']) + && $request['maximumCaptureRows'] >= 1 + && $request['maximumCaptureRows'] + <= REGEX_TOOLS_MAX_CAPTURE_ROWS, + 'The PHP capture-row limit is outside the bounded contract.', + ); + regex_tools_require( + strlen($request['subject']) <= REGEX_TOOLS_MAX_SUBJECT_BYTES, + 'The PHP subject exceeds the UTF-8 byte limit.', + ); + if ($operation === 'replace') { + regex_tools_require( + isset($request['replacement']) + && is_string($request['replacement']) + && preg_match('//u', $request['replacement']) === 1, + 'The PHP replacement must be valid UTF-8 text.', + ); + regex_tools_require( + regex_tools_within_utf16_limit( + $request['replacement'], + REGEX_TOOLS_MAX_REPLACEMENT_UTF16, + ), + 'The PHP replacement exceeds the UTF-16 limit.', + 'replacement-limit', + ); + regex_tools_require( + isset($request['maximumOutputBytes']) + && is_int($request['maximumOutputBytes']) + && $request['maximumOutputBytes'] >= 1 + && $request['maximumOutputBytes'] + <= REGEX_TOOLS_MAX_OUTPUT_BYTES, + 'The PHP output limit is outside the bounded contract.', + ); + } +} + +function regex_tools_escape_delimiter(string $pattern, string $delimiter): string +{ + $escaped = ''; + $backslashes = 0; + $length = strlen($pattern); + for ($index = 0; $index < $length; $index++) { + $character = $pattern[$index]; + if ($character === $delimiter) { + if ($backslashes % 2 === 0) { + $escaped .= '\\'; + } + $escaped .= $character; + $backslashes = 0; + } else { + $escaped .= $character; + $backslashes = $character === '\\' ? $backslashes + 1 : 0; + } + } + return $escaped; +} + +function regex_tools_pattern(string $raw, string $flags): string +{ + $candidates = ['~', '#', '%', '!', '@', ';', ':', ',', '=', '`', '/']; + $delimiter = '~'; + $body = null; + foreach ($candidates as $candidate) { + if (!str_contains($raw, $candidate)) { + $delimiter = $candidate; + $body = $raw; + break; + } + } + if ($body === null) { + $body = regex_tools_escape_delimiter($raw, $delimiter); + } + $modifiers = str_replace('g', '', $flags); + return $delimiter . $body . $delimiter . $modifiers; +} + +/** + * PHP exposes the compiled numeric capture table, but duplicate named groups + * share one associative-array key. This conservative scanner recovers every + * duplicate declaration only when its capture count agrees with PHP's + * authoritative count; otherwise the native table below remains authoritative. + * + * @return array{ + * groupCount: int, + * groupNames: list + * } + */ +function regex_tools_lexical_capture_names( + string $raw, + string $flags, +): array { + $groupCount = 0; + $groupNames = []; + $inClass = false; + $inQuote = false; + $extended = str_contains($flags, 'x'); + $noAutoCapture = str_contains($flags, 'n'); + $length = strlen($raw); + for ($index = 0; $index < $length; $index++) { + $character = $raw[$index]; + if ($inQuote) { + if ( + $character === '\\' + && ($raw[$index + 1] ?? '') === 'E' + ) { + $inQuote = false; + $index++; + } + continue; + } + if ($character === '\\') { + if (($raw[$index + 1] ?? '') === 'Q') { + $inQuote = true; + } + $index++; + continue; + } + if ($inClass) { + if ($character === ']') { + $inClass = false; + } + continue; + } + if ($character === '[') { + $inClass = true; + continue; + } + if ($extended && $character === '#') { + while ( + $index + 1 < $length + && $raw[$index + 1] !== "\n" + && $raw[$index + 1] !== "\r" + ) { + $index++; + } + continue; + } + if ($character !== '(') { + continue; + } + if (($raw[$index + 1] ?? '') !== '?') { + if (!$noAutoCapture) { + $groupCount++; + } + continue; + } + + $marker = $raw[$index + 2] ?? ''; + $nameStart = null; + $nameEndMarker = null; + if ( + $marker === '<' + && ($raw[$index + 3] ?? '') !== '=' + && ($raw[$index + 3] ?? '') !== '!' + ) { + $nameStart = $index + 3; + $nameEndMarker = '>'; + } elseif ($marker === "'") { + $nameStart = $index + 3; + $nameEndMarker = "'"; + } elseif ( + $marker === 'P' + && ($raw[$index + 3] ?? '') === '<' + ) { + $nameStart = $index + 4; + $nameEndMarker = '>'; + } elseif ($marker === '#') { + while ( + $index + 1 < $length + && $raw[$index + 1] !== ')' + ) { + $index++; + } + continue; + } + if ($nameStart === null || $nameEndMarker === null) { + continue; + } + $nameEnd = strpos($raw, $nameEndMarker, $nameStart); + if ($nameEnd === false) { + continue; + } + $name = substr($raw, $nameStart, $nameEnd - $nameStart); + $groupCount++; + if ($name !== '') { + $groupNames[] = [$groupCount, $name]; + } + $index = $nameEnd; + } + return [ + 'groupCount' => $groupCount, + 'groupNames' => $groupNames, + ]; +} + +/** + * @return array{ + * groupCount: int, + * groupNames: list + * } + */ +function regex_tools_capture_metadata(string $raw, string $flags): array +{ + $pattern = regex_tools_pattern($raw, $flags); + try { + $compiled = preg_match($pattern, ''); + } catch (RegexToolsFailure $error) { + throw $error; + } catch (Throwable $error) { + throw new RegexToolsFailure( + 'compile', + 'compile-error', + $error->getMessage(), + ); + } + if ($compiled === false) { + throw new RegexToolsFailure( + 'compile', + 'compile-error', + preg_last_error_msg(), + ); + } + + /* + * Appending an empty top-level branch makes MatchData available even when + * the expression cannot match the empty string. It does not add a capture, + * so PHP's numeric keys remain the engine-authoritative group count. + */ + $probePattern = regex_tools_pattern($raw . '|(?:)', $flags); + $probe = []; + try { + $status = preg_match( + $probePattern, + '', + $probe, + PREG_OFFSET_CAPTURE | PREG_UNMATCHED_AS_NULL, + ); + } catch (RegexToolsFailure $error) { + throw $error; + } catch (Throwable $error) { + throw new RegexToolsFailure( + 'compile', + 'compile-error', + $error->getMessage(), + ); + } + if ($status !== 1) { + throw new RegexToolsFailure( + 'compile', + 'metadata-error', + 'PHP preg could not inspect the compiled capture table.', + ); + } + + $groupCount = 0; + $groupNames = []; + $pendingNames = []; + foreach ($probe as $key => $_value) { + if (is_string($key)) { + $pendingNames[] = $key; + continue; + } + if ($key <= 0) { + continue; + } + $groupCount = max($groupCount, $key); + foreach ($pendingNames as $name) { + $groupNames[] = [$key, $name]; + } + $pendingNames = []; + } + if ($groupCount > REGEX_TOOLS_MAX_CAPTURE_GROUPS) { + throw new RegexToolsFailure( + 'compile', + 'capture-group-limit', + "The pattern declares {$groupCount} capture groups; " + . 'the PHP bridge limit is ' + . REGEX_TOOLS_MAX_CAPTURE_GROUPS + . '.', + ); + } + $lexical = regex_tools_lexical_capture_names($raw, $flags); + if ($lexical['groupCount'] === $groupCount) { + $lexicalKeys = []; + foreach ($lexical['groupNames'] as [$number, $name]) { + $lexicalKeys[$number . "\0" . $name] = true; + } + $nativeNamesAreCovered = true; + foreach ($groupNames as [$number, $name]) { + if (!isset($lexicalKeys[$number . "\0" . $name])) { + $nativeNamesAreCovered = false; + break; + } + } + if ($nativeNamesAreCovered) { + $groupNames = $lexical['groupNames']; + } + } + return [ + 'groupCount' => $groupCount, + 'groupNames' => $groupNames, + ]; +} + +function regex_tools_is_utf8_boundary(string $subject, int $offset): bool +{ + if ($offset === 0 || $offset === strlen($subject)) { + return true; + } + $byte = ord($subject[$offset]); + return $byte < 0x80 || $byte > 0xBF; +} + +function regex_tools_next_utf8_offset(string $subject, int $offset): int +{ + $length = strlen($subject); + if ($offset >= $length) { + return $length + 1; + } + $offset++; + while ($offset < $length) { + $byte = ord($subject[$offset]); + if ($byte < 0x80 || $byte > 0xBF) { + break; + } + $offset++; + } + return $offset; +} + +/** + * @param array $match + * @return array{ + * span: array{0: int, 1: int}, + * captures: list + * } + */ +function regex_tools_match_record( + array $match, + int $groupCount, + string $subject, +): array { + $whole = $match[0] ?? null; + if ( + !is_array($whole) + || count($whole) !== 2 + || !is_string($whole[0]) + || !is_int($whole[1]) + || $whole[1] < 0 + ) { + throw new RegexToolsFailure( + 'match', + 'invalid-native-result', + 'PHP preg returned a malformed whole-match record.', + ); + } + $start = $whole[1]; + $end = $start + strlen($whole[0]); + if ( + !regex_tools_is_utf8_boundary($subject, $start) + || !regex_tools_is_utf8_boundary($subject, $end) + ) { + throw new RegexToolsFailure( + 'match', + 'unaligned-utf8-offset', + 'PHP preg returned a byte offset inside a UTF-8 character. ' + . 'Enable the u modifier for Unicode text.', + ); + } + $captures = []; + for ($number = 1; $number <= $groupCount; $number++) { + $capture = $match[$number] ?? null; + if ( + !is_array($capture) + || count($capture) !== 2 + || (!is_string($capture[0]) && $capture[0] !== null) + || !is_int($capture[1]) + ) { + throw new RegexToolsFailure( + 'match', + 'invalid-native-result', + 'PHP preg returned a malformed capture record.', + ); + } + if ($capture[0] === null || $capture[1] < 0) { + $captures[] = null; + continue; + } + $captureStart = $capture[1]; + $captureEnd = $captureStart + strlen($capture[0]); + if ( + !regex_tools_is_utf8_boundary($subject, $captureStart) + || !regex_tools_is_utf8_boundary($subject, $captureEnd) + ) { + throw new RegexToolsFailure( + 'match', + 'unaligned-utf8-offset', + 'PHP preg returned a capture offset inside a UTF-8 character. ' + . 'Enable the u modifier for Unicode text.', + ); + } + $captures[] = [$captureStart, $captureEnd]; + } + return [ + 'span' => [$start, $end], + 'captures' => $captures, + ]; +} + +/** + * @return array{ + * matches: list + * }>, + * resultsTruncated: bool + * } + */ +function regex_tools_collect( + string $pattern, + string $nonemptyPattern, + string $subject, + bool $global, + bool $unicode, + int $groupCount, + int $maximumMatches, + int $maximumCaptureRows, +): array { + $records = []; + $captureRows = 0; + $offset = 0; + $subjectBytes = strlen($subject); + $resultsTruncated = false; + $retryNonemptyAtStart = false; + + while ($offset <= $subjectBytes) { + $match = []; + try { + $status = preg_match( + $retryNonemptyAtStart ? $nonemptyPattern : $pattern, + $subject, + $match, + PREG_OFFSET_CAPTURE | PREG_UNMATCHED_AS_NULL, + $offset, + ); + } catch (RegexToolsFailure $error) { + throw new RegexToolsFailure( + 'match', + 'match-error', + $error->getMessage(), + $error->patternOffset, + ); + } catch (Throwable $error) { + throw new RegexToolsFailure( + 'match', + 'match-error', + $error->getMessage(), + ); + } + if ($status === false) { + throw new RegexToolsFailure( + 'match', + 'match-error', + preg_last_error_msg(), + ); + } + if ($status === 0) { + if ($retryNonemptyAtStart) { + $retryNonemptyAtStart = false; + $offset = $unicode + ? regex_tools_next_utf8_offset($subject, $offset) + : $offset + 1; + continue; + } + break; + } + + $rows = max(1, $groupCount); + if ( + count($records) >= $maximumMatches + || $captureRows + $rows > $maximumCaptureRows + ) { + $resultsTruncated = true; + break; + } + $record = regex_tools_match_record($match, $groupCount, $subject); + $records[] = $record; + $captureRows += $rows; + if (!$global) { + break; + } + + [$start, $end] = $record['span']; + if ($end > $start) { + $offset = $end; + $retryNonemptyAtStart = false; + } elseif ($end >= $subjectBytes) { + break; + } else { + /* + * preg_match_all retries an empty match at the same position with + * PCRE2_NOTEMPTY_ATSTART before advancing. PHP does not expose that + * option on preg_match, so an anchored, non-empty derived pattern + * reproduces the retry while retaining the original captures. + */ + $offset = $end; + $retryNonemptyAtStart = true; + } + } + return [ + 'matches' => $records, + 'resultsTruncated' => $resultsTruncated, + ]; +} + +/** + * @return array{0: string, 1: int, 2: bool} + */ +function regex_tools_append_bounded( + string &$output, + string $fragment, + int $maximumBytes, + bool &$truncated, +): bool { + if ($fragment === '') { + return true; + } + if ($truncated) { + return false; + } + $remaining = $maximumBytes - strlen($output); + if (strlen($fragment) <= $remaining) { + $output .= $fragment; + return true; + } + $prefix = substr($fragment, 0, max(0, $remaining)); + while ($prefix !== '' && preg_match('//u', $prefix) !== 1) { + $prefix = substr($prefix, 0, -1); + } + $output .= $prefix; + $truncated = true; + return false; +} + +/** + * Mirrors preg_get_backref() from php-src 8.5.8. PHP replacement references + * consume one or two decimal digits and may use the ${n} spelling. + * + * @return null|array{0: int, 1: int} + */ +function regex_tools_parse_replacement_backref( + string $replacement, + int $index, +): ?array { + $length = strlen($replacement); + if ($index + 1 >= $length) { + return null; + } + $walk = $index; + $inBrace = false; + if ( + $replacement[$walk] === '$' + && ($replacement[$walk + 1] ?? '') === '{' + ) { + $inBrace = true; + $walk++; + } + $walk++; + $first = $replacement[$walk] ?? ''; + if ( + $first === '' + || ord($first) < ord('0') + || ord($first) > ord('9') + ) { + return null; + } + $backref = ord($first) - ord('0'); + $walk++; + $second = $replacement[$walk] ?? ''; + if ( + $second !== '' + && ord($second) >= ord('0') + && ord($second) <= ord('9') + ) { + $backref = ($backref * 10) + ord($second) - ord('0'); + $walk++; + } + if ($inBrace) { + if (($replacement[$walk] ?? '') !== '}') { + return null; + } + $walk++; + } + return [$backref, $walk]; +} + +/** + * The parser is a direct, fixed translation of PHP 8.5.8's replacement loop + * and preg_get_backref(). Parsing once avoids repeatedly walking a large + * template for its literal spans. + * + * @return list + */ +function regex_tools_replacement_tokens(string $replacement): array +{ + $tokens = []; + $literal = ''; + $walkLast = ''; + $index = 0; + $length = strlen($replacement); + while ($index < $length) { + $character = $replacement[$index]; + if ($character === '\\' || $character === '$') { + if ($walkLast === '\\') { + $literal[strlen($literal) - 1] = $character; + $index++; + $walkLast = ''; + continue; + } + $parsed = regex_tools_parse_replacement_backref( + $replacement, + $index, + ); + if ($parsed !== null) { + if ($literal !== '') { + $tokens[] = ['literal', $literal]; + $literal = ''; + } + [$backref, $index] = $parsed; + $tokens[] = ['backref', $backref]; + continue; + } + } + $literal .= $character; + $index++; + $walkLast = $character; + } + if ($literal !== '') { + $tokens[] = ['literal', $literal]; + } + return $tokens; +} + +/** + * Applies replacement only to the authoritative records returned to the app. + * This is the cross-engine partial-result contract: once a match/capture cap + * is reached, the unprocessed tail remains unchanged. Every append is clipped + * before allocation can exceed the requested UTF-8 byte limit. + * + * @param list + * }> $records + * @param list $tokens + * @return array{0: string, 1: int, 2: bool} + */ +function regex_tools_replace_bounded( + string $subject, + array $records, + array $tokens, + int $maximumBytes, +): array { + $output = ''; + $truncated = false; + $cursor = 0; + foreach ($records as $record) { + [$start, $end] = $record['span']; + if (!regex_tools_append_bounded( + $output, + substr($subject, $cursor, $start - $cursor), + $maximumBytes, + $truncated, + )) { + break; + } + foreach ($tokens as [$kind, $value]) { + if ($kind === 'literal') { + $fragment = $value; + } else { + $number = $value; + $range = $number === 0 + ? $record['span'] + : ($record['captures'][$number - 1] ?? null); + $fragment = $range === null + ? '' + : substr($subject, $range[0], $range[1] - $range[0]); + } + if (!regex_tools_append_bounded( + $output, + $fragment, + $maximumBytes, + $truncated, + )) { + break 2; + } + } + $cursor = $end; + } + if (!$truncated) { + regex_tools_append_bounded( + $output, + substr($subject, $cursor), + $maximumBytes, + $truncated, + ); + } + return [$output, strlen($output), $truncated]; +} + +/** + * @return array + */ +function regex_tools_identity(): array +{ + $test = []; + $matched = preg_match( + '~(?é+)~u', + '😀éé', + $test, + PREG_OFFSET_CAPTURE | PREG_UNMATCHED_AS_NULL, + ); + $replaced = preg_replace('~(?é+)~u', '[$1]', '😀éé'); + $parityPattern = '~(a)(b)?~u'; + $paritySubject = 'zab a'; + $parityRecords = regex_tools_collect( + $parityPattern, + '~\\G(?:(a)(b)?)(?!\\G)~u', + $paritySubject, + true, + true, + 2, + 100, + 100, + ); + $parityReplacement = '$2:$1/${1}/\\1/\\\\1/\\$1/$99/${1x}'; + [$bridgeReplacement, $_bridgeBytes, $bridgeTruncated] = + regex_tools_replace_bounded( + $paritySubject, + $parityRecords['matches'], + regex_tools_replacement_tokens($parityReplacement), + 4_096, + ); + $nativeReplacement = preg_replace( + $parityPattern, + $parityReplacement, + $paritySubject, + ); + $pcreVersion = explode(' ', PCRE_VERSION, 2)[0]; + $selfTest = $matched === 1 + && ($test[0][1] ?? null) === 4 + && strlen($test[0][0] ?? '') === 4 + && ($test['word'][1] ?? null) === 4 + && $replaced === '😀[éé]' + && !$bridgeTruncated + && $bridgeReplacement === $nativeReplacement; + return [ + 'abi' => REGEX_TOOLS_ABI, + 'ok' => true, + 'identity' => [ + 'bridge' => 'regex-tools-php-json', + 'bridgeVersion' => REGEX_TOOLS_ABI, + 'phpVersion' => PHP_VERSION, + 'phpSapi' => PHP_SAPI, + 'pcreVersion' => $pcreVersion, + 'pcreVersionFull' => PCRE_VERSION, + 'integerBytes' => PHP_INT_SIZE, + 'offsetUnit' => 'utf8-byte', + 'selfTest' => $selfTest, + ], + ]; +} + +/** + * @return array + */ +function regex_tools_main(): array +{ + $request = regex_tools_request(); + if (($request['operation'] ?? null) === 'identity') { + return regex_tools_identity(); + } + regex_tools_validate_request($request); + + $rawPattern = $request['pattern']; + $flags = $request['flags']; + $subject = $request['subject']; + $metadata = regex_tools_capture_metadata($rawPattern, $flags); + $pattern = regex_tools_pattern($rawPattern, $flags); + $nonemptyPattern = regex_tools_pattern( + '\\G(?:' . $rawPattern . ')(?!\\G)', + $flags, + ); + $collected = regex_tools_collect( + $pattern, + $nonemptyPattern, + $subject, + str_contains($flags, 'g'), + str_contains($flags, 'u'), + $metadata['groupCount'], + $request['maximumMatches'], + $request['maximumCaptureRows'], + ); + $result = [ + 'abi' => REGEX_TOOLS_ABI, + 'ok' => true, + 'groupCount' => $metadata['groupCount'], + 'groupNames' => $metadata['groupNames'], + 'matches' => $collected['matches'], + 'resultsTruncated' => $collected['resultsTruncated'], + ]; + if ($request['operation'] === 'execute') { + return $result; + } + + [$bounded, $outputBytes, $outputTruncated] = + regex_tools_replace_bounded( + $subject, + $collected['matches'], + regex_tools_replacement_tokens($request['replacement']), + $request['maximumOutputBytes'], + ); + /* + * Base64 keeps the JSON envelope within a predictable 4/3 expansion. + * Emitting arbitrary output directly as JSON could expand control bytes + * sixfold before the supervising worker has a chance to enforce its cap. + */ + $result['outputBase64'] = base64_encode($bounded); + $result['outputBytes'] = $outputBytes; + $result['outputTruncated'] = $outputTruncated; + return $result; +} + +try { + $response = regex_tools_main(); +} catch (Throwable $error) { + $response = regex_tools_failure($error); +} + +try { + echo json_encode( + $response, + JSON_THROW_ON_ERROR + | JSON_UNESCAPED_SLASHES + | JSON_UNESCAPED_UNICODE, + ); +} catch (Throwable $error) { + echo '{"abi":1,"ok":false,"phase":"bridge","code":"encoding-error",' + . '"message":"The PHP bridge response could not be encoded."}'; +} diff --git a/engines/php/native-components.json b/engines/php/native-components.json new file mode 100644 index 0000000..92572a1 --- /dev/null +++ b/engines/php/native-components.json @@ -0,0 +1,414 @@ +{ + "schemaVersion": 1, + "scope": { + "asset": "@php-wasm/web-8-5 3.1.46 Asyncify php_8_5.wasm", + "assetSha256": "ed97ea5422dbf23e0687c98203cc8c6d7f2772a3d71b03d4991d2fdd93a048f0", + "assetBytes": 21019221, + "phpVersion": "8.5.8", + "phpBuildDate": "Jul 8 2026 07:06:40", + "platform": "wasm32-emscripten", + "purpose": "Complete legal and source inventory for the exact shipped PHP WebAssembly main module" + }, + "buildProvenance": { + "wordpressPlayground": { + "release": "v3.1.46", + "commit": "581c7c172428159eb4e6c5309054a568cd39a97a", + "repository": "https://github.com/WordPress/wordpress-playground", + "packageGitHead": "581c7c172428159eb4e6c5309054a568cd39a97a" + }, + "php": { + "version": "8.5.8", + "tag": "php-8.5.8", + "tagObject": "8a3b5a5124006c11a8fbfce838ec7dd53615cc77", + "commit": "26b97507444c4fbda072f57dda1820f7b7d5e467", + "repository": "https://github.com/php/php-src" + }, + "emscripten": { + "version": "4.0.19", + "commit": "08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "repository": "https://github.com/emscripten-core/emscripten" + }, + "recipe": { + "path": "packages/php-wasm/compile/php/Dockerfile", + "variant": "web Asyncify with the platform-default feature set", + "sourceUrl": "https://github.com/WordPress/wordpress-playground/blob/581c7c172428159eb4e6c5309054a568cd39a97a/packages/php-wasm/compile/php/Dockerfile" + } + }, + "linkedComponents": [ + { + "id": "wordpress-playground-php-wasm", + "version": "3.1.46", + "source": "WordPress Playground commit 581c7c172428159eb4e6c5309054a568cd39a97a", + "license": "GPL-2.0-or-later", + "legalFiles": ["LICENSE.php-wasm-GPL-2.0-or-later.txt"], + "evidence": "npm package gitHead and integrity plus exact loader/WebAssembly hashes" + }, + { + "id": "php", + "version": "8.5.8", + "source": "php-src commit 26b97507444c4fbda072f57dda1820f7b7d5e467, patched by the pinned WordPress Playground recipe", + "license": "PHP-4.0 (BSD-3-Clause) plus separately identified bundled-source terms", + "legalFiles": [ + "LICENSE.PHP-4.0.txt", + "LICENSE.PHP-Zend-2.0.txt", + "NOTICE.PHP-REDIST-BINS.txt", + "LICENSE.PHP-CLI-http-parser-MIT.txt", + "NOTICE.PHP-public-domain-hash-code.txt" + ], + "bundledSourceNotices": [ + { + "component": "Zend Engine", + "source": "php-src Zend/LICENSE at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "Zend Engine License version 2.00", + "legalFile": "LICENSE.PHP-Zend-2.0.txt" + }, + { + "component": "php-src binary redistribution notices", + "source": "php-src README.REDIST.BINS at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "legalFile": "NOTICE.PHP-REDIST-BINS.txt" + }, + { + "component": "CLI HTTP parser", + "source": "php-src sapi/cli/php_http_parser.c at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "sourceSha256": "5c601ebbeaceda9ae3018be99e56cedc1568211a22ecdc19a9ac7bcb9f8a303e", + "license": "MIT", + "legalFile": "LICENSE.PHP-CLI-http-parser-MIT.txt" + }, + { + "component": "bundled hash implementations", + "source": "php-src ext/hash at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "algorithms": ["FNV", "Keccak/SHA-3", "MurmurHash3"], + "license": "Public-Domain, CC0-1.0 and MIT-like permission", + "legalFile": "NOTICE.PHP-public-domain-hash-code.txt" + } + ], + "evidence": "PHP_VERSION and PHP_BUILD_DATE runtime constants; the loaded Zend engine, CLI SAPI source marker and hash_algos() runtime audit" + }, + { + "id": "pcre2", + "version": "10.44", + "source": "php-src ext/pcre/pcre2lib at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "PCRE2 BSD licence", + "legalFiles": ["LICENSE.PCRE2-10.44.txt"], + "evidence": "PCRE_VERSION=10.44 2024-06-07" + }, + { + "id": "php-libbcmath", + "version": "PHP 8.5.8 vendored snapshot", + "source": "php-src ext/bcmath/libbcmath at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "LGPL-2.0-or-later", + "legalFiles": ["LICENSE.PHP-bcmath-LGPL-2.1.txt"], + "evidence": "loaded bcmath extension and exact php-src source identity" + }, + { + "id": "timelib", + "version": "2022.15", + "source": "php-src ext/date/lib at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "MIT", + "legalFiles": ["LICENSE.PHP-timelib-MIT.txt"], + "evidence": "timelib version in runtime module information" + }, + { + "id": "iana-tzdata", + "version": "2026.1", + "source": "php-src ext/date/lib/timezonedb.h at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "Public-Domain", + "legalFiles": ["NOTICE.IANA-TZDATA-2026.1.txt"], + "evidence": "runtime Timezone Database Version=2026.1" + }, + { + "id": "php-libmagic", + "version": "PHP 8.5.8 vendored snapshot", + "source": "php-src ext/fileinfo/libmagic at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "BSD-2-Clause", + "legalFiles": ["LICENSE.PHP-libmagic-BSD.txt"], + "evidence": "loaded fileinfo extension and exact php-src source identity" + }, + { + "id": "lexbor", + "version": "2.7.0", + "source": "php-src ext/lexbor at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "Apache-2.0", + "legalFiles": [ + "LICENSE.PHP-Lexbor-Apache-2.0.txt", + "NOTICE.PHP-Lexbor.txt" + ], + "evidence": "loaded lexbor extension and runtime Lexbor version=2.7.0" + }, + { + "id": "libmbfl", + "version": "1.3.2", + "source": "php-src ext/mbstring/libmbfl at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "LGPL-2.1", + "legalFiles": ["LICENSE.PHP-libmbfl-LGPL-2.1.txt"], + "evidence": "loaded mbstring extension and runtime libmbfl version=1.3.2" + }, + { + "id": "php-uriparser", + "version": "1.0.2", + "source": "php-src ext/uri/uriparser at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "BSD-3-Clause", + "legalFiles": ["LICENSE.PHP-uriparser-BSD-3-Clause.txt"], + "evidence": "loaded uri extension and runtime bundled version=1.0.2" + }, + { + "id": "php-libavifinfo", + "version": "PHP 8.5.8 vendored snapshot", + "source": "php-src ext/standard/libavifinfo at commit 26b97507444c4fbda072f57dda1820f7b7d5e467", + "license": "BSD-2-Clause with Alliance for Open Media Patent License 1.0", + "legalFiles": [ + "LICENSE.PHP-libavifinfo-BSD-2-Clause.txt", + "PATENTS.PHP-libavifinfo.txt" + ], + "evidence": "loaded standard extension and exact php-src source identity" + }, + { + "id": "zlib", + "version": "1.2.13", + "source": "https://www.zlib.net/fossils/zlib-1.2.13.tar.gz", + "sourceArchiveSha256": "b3a24de97a8fdbc835b9833169501030b8977031bcb54b3b3ac13740f846ab30", + "sourceCommit": "04f42ceca40f73e2978b50e93806c2a18c1281fc", + "license": "Zlib", + "legalFiles": ["LICENSE.zlib-1.2.13.txt"], + "evidence": "ZLIB_VERSION=1.2.13 and cURL linked zlib version" + }, + { + "id": "libzip", + "version": "1.9.2", + "source": "https://libzip.org/download/libzip-1.9.2.tar.gz", + "sourceArchiveSha256": "fd6a7f745de3d69cf5603edc9cb33d2890f0198e415255d0987a0cf10d824c6f", + "sourceCommit": "5532f9baa0c44cc5435ad135686a4ea009075b9a", + "license": "BSD-3-Clause", + "legalFiles": ["LICENSE.libzip-1.9.2.txt"], + "evidence": "ZipArchive::LIBZIP_VERSION=1.9.2" + }, + { + "id": "libxml2", + "version": "2.9.10", + "source": "https://gitlab.gnome.org/GNOME/libxml2/-/tree/41a34e1f4ffae2ce401600dbb5fe43f8fe402641", + "sourceCommit": "41a34e1f4ffae2ce401600dbb5fe43f8fe402641", + "license": "MIT", + "legalFiles": ["LICENSE.libxml2-2.9.10.txt"], + "evidence": "LIBXML_DOTTED_VERSION=2.9.10 and loaded version=20910-GITv2.9.10" + }, + { + "id": "sqlite", + "version": "3.51.0", + "source": "https://sqlite.org/2025/sqlite-autoconf-3510000.tar.gz", + "sourceArchiveSha256": "42e26dfdd96aa2e6b1b1be5c88b0887f9959093f650d693cb02eb9c36d146ca5", + "sourceId": "fb2c931ae597f8d00a37574ff67aeed3eced", + "license": "Public-Domain", + "legalFiles": ["NOTICE.SQLite-3.51.0.txt"], + "evidence": "SQLite3::version()=3.51.0" + }, + { + "id": "libgd", + "version": "2.3.3", + "source": "https://github.com/libgd/libgd/releases/download/gd-2.3.3/libgd-2.3.3.tar.gz", + "sourceArchiveSha256": "dd3f1f0bb016edcc0b2d082e8229c822ad1d02223511997c80461481759b1ed2", + "sourceCommit": "b5319a41286107b53daa0e08e402aa1819764bdc", + "license": "BSD-like bundled terms", + "legalFiles": ["LICENSE.libgd-2.3.3.txt"], + "evidence": "GD_VERSION=2.3.3" + }, + { + "id": "libjpeg-turbo", + "version": "3.0.3", + "source": "https://github.com/libjpeg-turbo/libjpeg-turbo/releases/download/3.0.3/libjpeg-turbo-3.0.3.tar.gz", + "sourceArchiveSha256": "343e789069fc7afbcdfe44dbba7dbbf45afa98a15150e079a38e60e44578865d", + "sourceCommit": "7fa4b5b762c9a99b46b0b7838f5fd55071b92ea5", + "license": "IJG AND BSD-3-Clause AND Zlib", + "legalFiles": ["LICENSE.libjpeg-turbo-3.0.3.txt"], + "evidence": "binary version marker libjpeg-turbo 3.0.3" + }, + { + "id": "libpng", + "version": "1.6.39", + "source": "https://prdownloads.sourceforge.net/libpng/libpng-1.6.39.tar.gz?download", + "sourceArchiveSha256": "af4fb7f260f839919e5958e5ab01a275d4fe436d45442a36ee62f73e5beb75ba", + "sourceCommit": "07b8803110da160b158ebfef872627da6c85cbdf", + "license": "Libpng", + "legalFiles": ["LICENSE.libpng-1.6.39.txt"], + "evidence": "binary version marker 1.6.39 and GD PNG support" + }, + { + "id": "libwebp-and-libsharpyuv", + "version": "commit 845d5476a866141ba35ac133f856fa62f0b7445f", + "source": "https://chromium.googlesource.com/webm/libwebp/+archive/845d5476a866141ba35ac133f856fa62f0b7445f.tar.gz", + "sourceArchiveSha256": "c68cbb9501e11d2686ec027b550867214c2e9232678a28ddafaa0abcb96ab4c4", + "sourceCommit": "845d5476a866141ba35ac133f856fa62f0b7445f", + "license": "BSD-3-Clause with WebM patent grant", + "legalFiles": ["LICENSE.libwebp.txt", "PATENTS.libwebp.txt"], + "evidence": "exact WordPress build-recipe commit and linked libwebp/libsharpyuv archives" + }, + { + "id": "libavif", + "version": "1.3.0", + "source": "https://github.com/AOMediaCodec/libavif/archive/refs/tags/v1.3.0.tar.gz", + "sourceArchiveSha256": "0a545e953cc049bf5bcf4ee467306a2f113a75110edf59e61248873101cd26c1", + "sourceCommit": "1aadfad932c98c069a1204261b1856f81f3bc199", + "license": "BSD-2-Clause plus bundled component terms", + "legalFiles": ["LICENSE.libavif-1.3.0.txt"], + "evidence": "WordPress build recipe uses AVIF_CODEC_AOM=LOCAL and GD reports AVIF support" + }, + { + "id": "libaom", + "version": "3.12.1", + "source": "https://aomedia.googlesource.com/aom/+archive/v3.12.1.tar.gz", + "sourceArchiveSha256": "8ecd25e39c4c94240d3aba272f8bde80f7a1c0448843c50d17a3eba54bd68586", + "sourceCommit": "10aece4157eb79315da205f39e19bf6ab3ee30d0", + "license": "BSD-2-Clause with Alliance for Open Media Patent License 1.0", + "legalFiles": ["LICENSE.libaom-3.12.1.txt", "PATENTS.libaom-3.12.1.txt"], + "evidence": "libavif v1.3.0 LocalAom.cmake pins v3.12.1; binary encoder and decoder version markers confirm 3.12.1" + }, + { + "id": "libyuv", + "version": "snapshot vendored by libaom 3.12.1", + "source": "third_party/libyuv in the exact libaom v3.12.1 archive", + "license": "BSD-3-Clause", + "legalFiles": ["LICENSE.libyuv.txt"], + "evidence": "libavif LOCAL AOM build enables AOM's bundled libyuv path" + }, + { + "id": "openssl", + "version": "1.1.1t", + "source": "https://www.openssl.org/source/openssl-1.1.1t.tar.gz", + "sourceArchiveSha256": "8dee9b24bdb1dcbf0c3d1e9b02fb8f6bf22165e807f45adeb7c9677536859d3b", + "sourceCommit": "830bf8e1e4749ad65c51b6a1d0d769ae689404ba", + "license": "OpenSSL and Original SSLeay licences", + "legalFiles": ["LICENSE.OpenSSL-1.1.1t.txt"], + "evidence": "OPENSSL_VERSION_TEXT and cURL SSL version both report OpenSSL 1.1.1t" + }, + { + "id": "curl", + "version": "7.69.1", + "source": "https://curl.se/download/curl-7.69.1.tar.gz", + "sourceArchiveSha256": "01ae0c123dee45b01bbaef94c0bc00ed2aec89cb2ee0fd598e0d302a6b5e0a98", + "sourceCommit": "b81e0b07784dc4c1e8d0a86194b9d28776d071c0", + "license": "curl", + "legalFiles": ["LICENSE.curl-7.69.1.txt"], + "evidence": "curl_version()=7.69.1" + }, + { + "id": "libiconv", + "version": "1.17", + "source": "https://ftp.gnu.org/pub/gnu/libiconv/libiconv-1.17.tar.gz", + "sourceArchiveSha256": "8f74213b56238c85a50a5329f77e06198771e70dd9a739779f4c02f65d971313", + "license": "LGPL-2.1-or-later", + "legalFiles": ["LICENSE.libiconv-1.17-LGPL-2.1.txt"], + "evidence": "ICONV_VERSION=1.17" + }, + { + "id": "oniguruma", + "version": "6.9.10", + "source": "WordPress Playground prebuilt archive at commit b38db761632d860bd519021d33a2230117841ee4", + "linkedArchiveGitBlob": "1e4a8d4f15b680d2f93433cb1adbb7dcd499b0a5", + "linkedArchiveSha256": "d040c88febc3d7f3548860b096640966647b34c118887041f25f51f3259eb36f", + "buildCompiler": "Emscripten 4.0.5 (the archive was later linked into the Emscripten 4.0.19 main module)", + "auditedReleaseCommit": "4ef89209a239c1aea328cf13c05a2807e5c146d1", + "auditedReleaseArchiveSha256": "ad92309d0d13eebc27f6592e875f3efbfa3dda2bf6da5952e00f0a2120c921a8", + "upstreamSourceRange": { + "firstCommitWithExactInstalledHeader": "005482a534c821017882bc5ab1940b842b426081", + "lastCommitBeforeHeaderChanged": "3eb317dc4413692e4eaa92a68839c74aa74fbc77", + "excludingCommit": "ba9abef9cdbeed860c18d02a66b682f549b35a82", + "installedHeaderGitBlob": "22e9b317b95bb55ac8e9d9da93fc4f64d3930f4a" + }, + "buildCommitStatus": "The upstream recipe cloned its default branch without a revision. The exact build-time HEAD is not recoverable; the committed archive, installed header, runtime version and bounded upstream source interval are pinned instead of falsely claiming the v6.9.10 tag.", + "license": "BSD-2-Clause", + "legalFiles": ["LICENSE.Oniguruma-6.9.10.txt"], + "evidence": "MB_ONIGURUMA_VERSION=6.9.10; exact committed archive and header blobs; the exact shipped WebAssembly hash remains the final binary identity" + }, + { + "id": "emscripten-runtime", + "version": "4.0.19", + "source": "Emscripten commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "MIT OR NCSA", + "legalFiles": ["LICENSE.Emscripten-4.0.19.txt"], + "evidence": "pinned WordPress base-image recipe and generated main-module loader/runtime" + }, + { + "id": "musl-libc", + "version": "Emscripten 4.0.19 snapshot", + "source": "Emscripten system/lib/libc/musl at commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "MIT and component notices", + "legalFiles": ["LICENSE.musl.txt"], + "evidence": "Emscripten libc linked into the main module" + }, + { + "id": "llvm-compiler-rt", + "version": "Emscripten 4.0.19 snapshot", + "source": "Emscripten system/lib/compiler-rt at commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "Apache-2.0 WITH LLVM-exception (current code) and NCSA OR MIT (legacy code)", + "legalFiles": ["LICENSE.llvm-compiler-rt.txt"], + "evidence": "compiler-rt builtins such as __extenddftf2 are defined in the main module" + }, + { + "id": "llvm-libcxx", + "version": "Emscripten 4.0.19 snapshot", + "source": "Emscripten system/lib/libcxx at commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "Apache-2.0 WITH LLVM-exception", + "legalFiles": ["LICENSE.libcxx.txt"], + "evidence": "C++ standard-library symbols are defined in the main module" + }, + { + "id": "llvm-libcxxabi", + "version": "Emscripten 4.0.19 snapshot", + "source": "Emscripten system/lib/libcxxabi at commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "Apache-2.0 WITH LLVM-exception", + "legalFiles": ["LICENSE.libcxxabi.txt"], + "evidence": "__cxa and C++ RTTI symbols are defined in the main module" + }, + { + "id": "dlmalloc", + "version": "2.8.6", + "source": "Emscripten system/lib/dlmalloc.c at commit 08e2de1031913e4ba7963b1c56f35f036a7d4d56", + "license": "Public-Domain", + "legalFiles": ["NOTICE.dlmalloc-2.8.6.txt"], + "evidence": "Emscripten default allocator source for this build" + } + ], + "excludedDetections": [ + { + "id": "gmp", + "status": "not linked", + "runtimeEvidence": "extension_loaded('gmp')=false and function_exists('gmp_init')=false", + "rawStringExplanation": "gmp_* names are compiled into Zend/Optimizer/zend_func_infos.h for optimization metadata even when ext/gmp is absent" + }, + { + "id": "libsodium", + "status": "not linked", + "runtimeEvidence": "extension_loaded('sodium')=false and function_exists('sodium_crypto_box')=false", + "rawStringExplanation": "sodium_* names are compiled into Zend/Optimizer/zend_func_infos.h for optimization metadata even when ext/sodium is absent" + }, + { + "id": "tidy", + "status": "not linked", + "runtimeEvidence": "extension_loaded('tidy')=false, function_exists('tidy_parse_string')=false and class_exists('tidy')=false", + "rawStringExplanation": "generic tidy strings and PHP credit/name tables are not evidence of libtidy" + }, + { + "id": "intl-and-icu", + "status": "not shipped", + "runtimeEvidence": "extension_loaded('intl')=false and class_exists('IntlDateFormatter')=false", + "rawStringExplanation": "intlcal_* names come from Zend optimizer metadata; the npm package's separate intl.so side module is outside the pack's closed file set" + }, + { + "id": "freetype", + "status": "not linked", + "runtimeEvidence": "the exact libgd recipe sets ENABLE_FREETYPE=OFF and supplies stubs", + "rawStringExplanation": "phpinfo reports a synthetic gdlib-config feature string, but the final link contains no FreeType archive" + }, + { + "id": "imagemagick-and-imagick", + "status": "not linked", + "runtimeEvidence": "extension_loaded('imagick')=false and class_exists('Imagick')=false", + "rawStringExplanation": "the web build sets WITH_IMAGICK=no" + }, + { + "id": "standalone-libaom-3.13.1-recipe", + "status": "not linked", + "runtimeEvidence": "the final link consumes libavif's LOCAL AOM 3.12.1 build and the binary reports encoder/decoder 3.12.1", + "rawStringExplanation": "the neighbouring 3.13.1 library recipe is not a dependency of this libavif build" + } + ] +} diff --git a/engines/python/bridge.py b/engines/python/bridge.py index a21196a..8f4f418 100644 --- a/engines/python/bridge.py +++ b/engines/python/bridge.py @@ -5,6 +5,7 @@ Pyodide runtime starts. User-controlled values are passed as function arguments; they are never evaluated as Python source. """ +import base64 import json import re import sys @@ -256,9 +257,16 @@ def _regex_tools_run( "resultsTruncated": results_truncated, } if operation == "replace": + output = "".join(output_chunks).encode("utf-8") + if len(output) != output_bytes: + return _error( + "bridge", + "output-byte-count-mismatch", + "The bounded Python output byte count is inconsistent.", + ) result.update( { - "output": "".join(output_chunks), + "outputBase64": base64.b64encode(output).decode("ascii"), "outputBytes": output_bytes, "outputTruncated": output_truncated, } diff --git a/engines/ruby/README.md b/engines/ruby/README.md new file mode 100644 index 0000000..8cdc4b6 --- /dev/null +++ b/engines/ruby/README.md @@ -0,0 +1,37 @@ +# Ruby regular-expression engine + +Regex Tools executes Ruby expressions in the actual CRuby 4.0.0 engine built +for `wasm32-wasi` by ruby.wasm. The reviewed runtime is the minimal +`ruby.wasm` from `@ruby/4.0-wasm-wasi@2.9.3-2.9.4`; the JavaScript host API is +`@ruby/wasm-wasi@2.9.3-2.9.4`. + +The fixed `bridge.rb` module is evaluated once during worker start. Pattern, +flags, subject, limits and replacement travel through a bounded, +length-prefixed file in the worker-local WASI memory filesystem. Bounded inert +JSON returns metadata only; replacement output is written as UTF-8 to a +separate bounded worker-local file. No user-controlled value is evaluated or +interpolated as Ruby or JavaScript source, and the bridge does not use the +ruby.wasm `JS.eval` conversion path. + +CRuby performs compilation and matching and reports character offsets, which +the adapter exposes as Unicode code-point native offsets and normalizes to +browser UTF-16 ranges. Native `String#gsub`/`String#sub` block iteration drives +replacement matching without materializing expanded output. A fixed streaming +implementation of CRuby 4.0.0's `rb_reg_regsub` grammar handles `\1` through +`\9`, `\k`, `\0`, `\&`, ``\` ``, `\'`, `\+`, and `\\`; a load-time +bounded fixture verifies parity with CRuby. The expander stops on a valid UTF-8 +boundary at the configured byte limit. Unpaired browser UTF-16 surrogates are +rejected before request encoding. A workbench timeout, cancellation, +supersession or crash terminates the dedicated worker and its complete +WebAssembly heap. + +The deterministic pack contains only: + +- `ruby.wasm`; +- `engine-metadata.json`; +- `SHA256SUMS`; +- ruby.wasm's exact `LICENSE.txt`; +- ruby.wasm's complete `NOTICE.txt`, including CRuby and bundled third-party + notices; and +- the exact browser WASI shim and `tslib` license texts required by the + JavaScript host bundle. diff --git a/engines/ruby/bridge.rb b/engines/ruby/bridge.rb new file mode 100644 index 0000000..bb3ee01 --- /dev/null +++ b/engines/ruby/bridge.rb @@ -0,0 +1,605 @@ +# frozen_string_literal: true + +# Fixed bridge evaluated once inside the bundled CRuby WebAssembly runtime. +# +# JavaScript writes one bounded, length-prefixed request to the worker-local +# WASI memory filesystem. User-controlled pattern, subject and replacement +# strings are never interpolated into Ruby or JavaScript source. Replacement +# matching is driven by CRuby String#gsub/String#sub block iteration, while a +# fixed streaming implementation of CRuby 4.0.0's rb_reg_regsub grammar writes +# only the requested UTF-8 prefix to a separate worker-local output file. +module RegexToolsRubyBridge + ABI_VERSION = 2 + MAXIMUM_CAPTURE_GROUPS = 1_000 + MAXIMUM_ERROR_CHARACTERS = 1_024 + MAXIMUM_REQUEST_BYTES = 18 * 1024 * 1024 + MAXIMUM_RESPONSE_BYTES = 16 * 1024 * 1024 + MAXIMUM_MATCHES = 10_000 + MAXIMUM_CAPTURE_ROWS = 100_000 + MAXIMUM_OUTPUT_BYTES = 64 * 1024 * 1024 + REQUEST_FIELD_COUNT = 8 + REQUEST_FILE = "/regex-tools-request.bin" + OUTPUT_FILE = "/regex-tools-output.bin" + REQUEST_MAGIC = "RGXRUBY1".b + REPLACEMENT_STOP = :regex_tools_replacement_stop + HEX_DIGITS = "0123456789abcdef" + + class ReplacementFailure < StandardError + attr_reader :original + + def initialize(original) + @original = original + super(original.message) + set_backtrace(original.backtrace) + end + end + + class BoundedUtf8Output + attr_reader :bytes + + def initialize(maximum_bytes) + @maximum_bytes = maximum_bytes + @value = String.new(capacity: [maximum_bytes, 64 * 1024].min) + @value.force_encoding(Encoding::UTF_8) + @bytes = 0 + @truncated = false + end + + def append(value, byte_start = 0, byte_length = nil) + byte_length ||= value.bytesize - byte_start + return true if byte_length <= 0 + return false if @truncated + + remaining = @maximum_bytes - @bytes + if byte_length <= remaining + @value << value.byteslice(byte_start, byte_length) + @bytes += byte_length + return true + end + + prefix = value.byteslice(byte_start, remaining) + prefix = prefix.byteslice(0, prefix.bytesize - 1) until prefix.valid_encoding? + @value << prefix + @bytes += prefix.bytesize + @truncated = true + false + end + + def truncated? + @truncated + end + + def value + @value + end + end + + class << self + def run + reset_output + encode_json(run_record(*read_request)) + rescue StandardError => error + begin + reset_output + rescue StandardError + # The original bridge error is more useful than a secondary cleanup + # failure. The adapter will still reject a stale output byte count. + end + encode_json(error_record("bridge", "bridge-error", error)) + end + + private + + def reset_output + File.binwrite(OUTPUT_FILE, "".b) + end + + def read_request + data = File.binread(REQUEST_FILE) + unless data.bytesize <= MAXIMUM_REQUEST_BYTES && + data.byteslice(0, REQUEST_MAGIC.bytesize) == REQUEST_MAGIC + raise ArgumentError, "Invalid Ruby bridge request." + end + + offset = REQUEST_MAGIC.bytesize + fields = REQUEST_FIELD_COUNT.times.map do + raise ArgumentError, "Truncated Ruby bridge request." if offset + 4 > data.bytesize + + length = data.getbyte(offset) << 24 | + data.getbyte(offset + 1) << 16 | + data.getbyte(offset + 2) << 8 | + data.getbyte(offset + 3) + offset += 4 + raise ArgumentError, "Truncated Ruby bridge field." if offset + length > data.bytesize + + field = data.byteslice(offset, length) + offset += length + field.force_encoding(Encoding::UTF_8) + raise ArgumentError, "Invalid UTF-8 Ruby bridge field." unless field.valid_encoding? + + field + end + raise ArgumentError, "Trailing Ruby bridge request data." unless offset == data.bytesize + + fields + end + + def bounded_integer(value, label, maximum) + text = value.to_s + unless /\A[1-9][0-9]*\z/.match?(text) + raise ArgumentError, "#{label} must be a positive decimal integer." + end + number = text.to_i + unless number <= maximum + raise ArgumentError, "#{label} exceeds the Ruby bridge limit." + end + number + end + + def run_record( + operation_value, + pattern_value, + flags_value, + subject_value, + maximum_matches_value, + maximum_capture_rows_value, + replacement_value, + maximum_output_bytes_value + ) + operation = operation_value.to_s + return identity if operation == "identity" + + unless operation == "execute" || operation == "replace" + return error_record( + "bridge", + "invalid-operation", + "Unsupported Ruby bridge operation." + ) + end + + pattern = pattern_value.to_s + flags = flags_value.to_s + subject = subject_value.to_s + replacement = replacement_value.to_s + maximum_matches = bounded_integer( + maximum_matches_value, + "maximumMatches", + MAXIMUM_MATCHES + ) + maximum_capture_rows = bounded_integer( + maximum_capture_rows_value, + "maximumCaptureRows", + MAXIMUM_CAPTURE_ROWS + ) + maximum_output_bytes = bounded_integer( + maximum_output_bytes_value, + "maximumOutputBytes", + MAXIMUM_OUTPUT_BYTES + ) + unless /\A[gimx]*\z/.match?(flags) && flags.each_char.uniq.length == flags.length + return error_record( + "bridge", + "invalid-flags", + "The Ruby bridge received unsupported or duplicate flags." + ) + end + + regexp = compile(pattern, flags) + return regexp if regexp.is_a?(Hash) + + group_count = capture_group_count(regexp) + if group_count > MAXIMUM_CAPTURE_GROUPS + return error_record( + "compile", + "capture-group-limit", + "The pattern declares #{group_count} capture groups; " \ + "the bridge limit is #{MAXIMUM_CAPTURE_GROUPS}." + ) + end + + begin + collected = collect_matches( + regexp, + subject, + flags.include?("g"), + group_count, + maximum_matches, + maximum_capture_rows, + operation == "replace" ? replacement : nil, + maximum_output_bytes + ) + rescue ReplacementFailure => error + return error_record( + "replacement", + "replacement-error", + error.original + ) + rescue StandardError => error + return error_record("match", "match-error", error) + end + + result = { + "abi" => ABI_VERSION, + "ok" => true, + "groupCount" => group_count, + "groupNames" => capture_group_names(regexp), + "matches" => collected["matches"], + "resultsTruncated" => collected["resultsTruncated"] + } + return result if operation == "execute" + + File.binwrite(OUTPUT_FILE, collected["output"]) + result.merge( + "outputBytes" => collected["outputBytes"], + "outputTruncated" => collected["outputTruncated"] + ) + rescue StandardError => error + error_record("bridge", "bridge-error", error) + end + + # RbValue#toJS delegates Hash/Array conversion to the ruby.wasm `js` gem, + # whose generic conversion path constructs objects through JS.eval. The + # Toolbox CSP deliberately disallows that capability. Return one inert, + # metadata-only JSON string, assembled incrementally without per-value + # arrays or the potentially 6x JSON escaping amplification of output text. + def encode_json(value) + output = String.new(capacity: 4 * 1024) + output.force_encoding(Encoding::UTF_8) + append_json(output, value) + if output.bytesize > MAXIMUM_RESPONSE_BYTES + raise RangeError, "Ruby bridge metadata exceeds its response limit." + end + output + end + + def append_json(output, value) + case value + when Hash + output << "{" + first = true + value.each do |key, item| + output << "," unless first + first = false + append_json_string(output, key.to_s) + output << ":" + append_json(output, item) + end + output << "}" + when Array + output << "[" + value.each_with_index do |item, index| + output << "," unless index.zero? + append_json(output, item) + end + output << "]" + when String + append_json_string(output, value) + when Integer + output << value.to_s + when true + output << "true" + when false + output << "false" + when nil + output << "null" + else + append_json_string(output, value.to_s) + end + if output.bytesize > MAXIMUM_RESPONSE_BYTES + raise RangeError, "Ruby bridge metadata exceeds its response limit." + end + end + + def append_json_string(output, value) + text = value.valid_encoding? \ + ? value \ + : value.encode( + Encoding::UTF_8, + invalid: :replace, + undef: :replace, + replace: "\uFFFD" + ) + output << "\"" + text.each_codepoint do |codepoint| + case codepoint + when 0x08 then output << "\\b" + when 0x09 then output << "\\t" + when 0x0A then output << "\\n" + when 0x0C then output << "\\f" + when 0x0D then output << "\\r" + when 0x22 then output << "\\\"" + when 0x5C then output << "\\\\" + when 0x00..0x1F + output << "\\u00" + output << HEX_DIGITS.getbyte(codepoint >> 4) + output << HEX_DIGITS.getbyte(codepoint & 0x0F) + else + output << codepoint + end + end + output << "\"" + end + + def identity + verify_replacement_parity + { + "abi" => ABI_VERSION, + "ok" => true, + "identity" => { + "implementation" => RUBY_ENGINE, + "rubyVersion" => RUBY_VERSION, + "platform" => RUBY_PLATFORM, + "defaultExternalEncoding" => Encoding.default_external.name + } + } + end + + def compile(pattern, flags) + options = 0 + options |= Regexp::IGNORECASE if flags.include?("i") + options |= Regexp::MULTILINE if flags.include?("m") + options |= Regexp::EXTENDED if flags.include?("x") + Regexp.new(pattern, options) + rescue RegexpError => error + error_record("compile", "compile-error", error) + rescue StandardError => error + error_record("compile", "compile-error", error) + end + + def capture_group_count(regexp) + # Alternating with an empty non-capturing branch makes a match available + # without changing the original capture numbering. + Regexp.union(regexp, /(?:)/).match("").length - 1 + end + + def capture_group_names(regexp) + regexp.named_captures.flat_map do |name, numbers| + numbers.map { |number| [number, name] } + end.sort_by { |number, name| [number, name] } + end + + def match_record(match, group_count) + captures = (1..group_count).map do |group_number| + start_offset = match.begin(group_number) + start_offset.nil? \ + ? nil \ + : [start_offset, match.end(group_number)] + end + { + "span" => [match.begin(0), match.end(0)], + "captures" => captures + } + end + + def collect_matches( + regexp, + subject, + global, + group_count, + maximum_matches, + maximum_capture_rows, + replacement = nil, + maximum_output_bytes = 1 + ) + records = [] + capture_rows = 0 + results_truncated = false + output = replacement.nil? \ + ? nil \ + : BoundedUtf8Output.new(maximum_output_bytes) + last_replacement_end = 0 + + callback = proc do + match = Regexp.last_match + rows_for_match = [1, group_count].max + if records.length >= maximum_matches || + capture_rows + rows_for_match > maximum_capture_rows + results_truncated = true + throw REPLACEMENT_STOP + end + + records << match_record(match, group_count) + capture_rows += rows_for_match + unless output.nil? || output.truncated? + match_start = match.bytebegin(0) + output.append( + subject, + last_replacement_end, + match_start - last_replacement_end + ) + unless output.truncated? + begin + append_replacement( + output, + replacement, + subject, + match, + regexp.names.empty? + ) + rescue StandardError => error + raise ReplacementFailure, error + end + end + end + last_replacement_end = match.byteend(0) + "" + end + + catch(REPLACEMENT_STOP) do + global ? subject.gsub(regexp, &callback) : subject.sub(regexp, &callback) + end + + unless output.nil? || output.truncated? + output.append( + subject, + last_replacement_end, + subject.bytesize - last_replacement_end + ) + end + + result = { + "matches" => records, + "resultsTruncated" => results_truncated + } + unless output.nil? + result["output"] = output.value + result["outputBytes"] = output.bytes + result["outputTruncated"] = output.truncated? + end + result + end + + # Mirrors CRuby 4.0.0 rb_reg_regsub: \1..\9, \k, \0, \&, \`, + # \', \+, \\ and literal preservation for every other escaped character. + # Match selection and byte offsets remain native MatchData results. + def append_replacement( + output, + replacement, + subject, + match, + numeric_backrefs_active + ) + bytes = replacement.b + cursor = 0 + while cursor < bytes.bytesize && !output.truncated? + slash = bytes.index("\\", cursor) + if slash.nil? + output.append(replacement, cursor, bytes.bytesize - cursor) + break + end + output.append(replacement, cursor, slash - cursor) if slash > cursor + break if output.truncated? + + if slash + 1 >= bytes.bytesize + output.append(replacement, slash, 1) + break + end + + marker = bytes.getbyte(slash + 1) + cursor = slash + 2 + case marker + when 0x31..0x39 + append_capture( + output, + subject, + match, + marker - 0x30 + ) if numeric_backrefs_active + when 0x6B # k + if cursor < bytes.bytesize && bytes.getbyte(cursor) == 0x3C # < + name_start = cursor + 1 + name_end = bytes.index(">", name_start) + if name_end.nil? + raise RuntimeError, "invalid group name reference format" + end + name = replacement.byteslice(name_start, name_end - name_start) + append_capture(output, subject, match, name) + cursor = name_end + 1 + else + output.append(replacement, slash, 2) + end + when 0x30, 0x26 # 0, & + append_capture(output, subject, match, 0) + when 0x60 # ` + output.append(subject, 0, match.bytebegin(0)) + when 0x27 # ' + match_end = match.byteend(0) + output.append(subject, match_end, subject.bytesize - match_end) + when 0x2B # + + group_number = match.length - 1 + group_number -= 1 while group_number > 0 && match.bytebegin(group_number).nil? + append_capture(output, subject, match, group_number) if group_number > 0 + when 0x5C # \ + output.append(replacement, slash + 1, 1) + else + if marker >= 0x80 + cursor += 1 while cursor < bytes.bytesize && + (bytes.getbyte(cursor) & 0xC0) == 0x80 + end + output.append(replacement, slash, cursor - slash) + end + end + end + + def append_capture(output, subject, match, group) + if group.is_a?(Integer) && group >= match.length + return + end + byte_start, byte_end = match.byteoffset(group) + return if byte_start.nil? + + output.append(subject, byte_start, byte_end - byte_start) + end + + def verify_replacement_parity + return if @replacement_parity_verified + + slash = 92.chr + fixtures = [ + [ + /(a)(b)?/, + "ab a", + [ + "<", + "#{slash}0", + "|#{slash}&", + "|#{slash}1", + "|#{slash}2", + "|#{slash}9", + "|#{slash}+", + "|#{slash}#{slash}", + "|#{slash}q", + "|#{slash}`", + "|#{slash}'", + ">" + ].join, + true + ], + [ + /(?a)(?b)?/, + "ab a", + "<#{slash}k|#{slash}k|#{slash}1>", + true + ], + [/(é)/, "xéy", "#{slash}é/#{slash}1", false] + ] + fixtures.each do |regexp, subject, replacement, global| + native = global \ + ? subject.gsub(regexp, replacement) \ + : subject.sub(regexp, replacement) + bounded = collect_matches( + regexp, + subject, + global, + capture_group_count(regexp), + MAXIMUM_MATCHES, + MAXIMUM_CAPTURE_ROWS, + replacement, + 1024 * 1024 + ) + unless !bounded["resultsTruncated"] && + !bounded["outputTruncated"] && + bounded["output"] == native + raise "Bounded Ruby replacement semantics failed the CRuby parity test." + end + end + @replacement_parity_verified = true + end + + def error_record(phase, code, error) + message = error.is_a?(Exception) ? error.message : error.to_s + if message.length > MAXIMUM_ERROR_CHARACTERS + message = "#{message[0, MAXIMUM_ERROR_CHARACTERS - 1]}…" + end + { + "abi" => ABI_VERSION, + "ok" => false, + "phase" => phase, + "code" => code, + "message" => message + } + end + end +end + +RegexToolsRubyBridge diff --git a/engines/rust/Cargo.lock b/engines/rust/Cargo.lock new file mode 100644 index 0000000..9ad80c5 --- /dev/null +++ b/engines/rust/Cargo.lock @@ -0,0 +1,216 @@ +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +version = 4 + +[[package]] +name = "aho-corasick" +version = "1.1.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ddd31a130427c27518df266943a5308ed92d4b226cc639f5a8f1002816174301" +dependencies = [ + "memchr", +] + +[[package]] +name = "bumpalo" +version = "3.20.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "72f5acc6cb2ba439de613abc23857ec3d78374d8ed5ac84e9d11336e87da8649" + +[[package]] +name = "cfg-if" +version = "1.0.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9330f8b2ff13f34540b44e946ef35111825727b38d33286ef986142615121801" + +[[package]] +name = "itoa" +version = "1.0.18" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8f42a60cbdf9a97f5d2305f08a87dc4e09308d1276d28c869c684d7777685682" + +[[package]] +name = "memchr" +version = "2.8.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "cf8baf1c55e62ffcace7a9f06f4bd9cd3f0c4beb022d3b367256b91b87513d98" + +[[package]] +name = "once_cell" +version = "1.21.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9f7c3e4beb33f85d45ae3e3a1792185706c8e16d043238c593331cc7cd313b50" + +[[package]] +name = "proc-macro2" +version = "1.0.107" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "985e7ec9bb745e6ce6535b544d84d6cd6f7ad8bd711c398938ae983b91a766d9" +dependencies = [ + "unicode-ident", +] + +[[package]] +name = "quote" +version = "1.0.47" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "1fbf4db142a473a8d80c26bbf18454ed458bf8d26c8219c331daecfdbd079001" +dependencies = [ + "proc-macro2", +] + +[[package]] +name = "regex" +version = "1.13.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f020237b6c8eed93db2e2cb53c00c60a8e1bc73da7d073199a1180401450218d" +dependencies = [ + "aho-corasick", + "memchr", + "regex-automata", + "regex-syntax", +] + +[[package]] +name = "regex-automata" +version = "0.4.16" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8fcfdb36bda0c880c5931cdc7a2bcdc8ba4556847b9d912bca70bc94708711ad" +dependencies = [ + "aho-corasick", + "memchr", + "regex-syntax", +] + +[[package]] +name = "regex-syntax" +version = "0.8.11" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d6f6ff9a378485b298a5286656da665ba74413d36db0979633275d2e708145d4" + +[[package]] +name = "regex-tools-rust-engine" +version = "0.1.0" +dependencies = [ + "regex", + "serde", + "serde_json", + "wasm-bindgen", +] + +[[package]] +name = "rustversion" +version = "1.0.23" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "cf54715a573b99ac80df0bc206da022bcd442c974952c7b9720069370852e21f" + +[[package]] +name = "serde" +version = "1.0.228" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9a8e94ea7f378bd32cbbd37198a4a91436180c5bb472411e48b5ec2e2124ae9e" +dependencies = [ + "serde_core", + "serde_derive", +] + +[[package]] +name = "serde_core" +version = "1.0.228" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "41d385c7d4ca58e59fc732af25c3983b67ac852c1a25000afe1175de458b67ad" +dependencies = [ + "serde_derive", +] + +[[package]] +name = "serde_derive" +version = "1.0.228" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d540f220d3187173da220f885ab66608367b6574e925011a9353e4badda91d79" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] + +[[package]] +name = "serde_json" +version = "1.0.150" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e8014e44b4736ed0538adeecded0fce2a272f22dc9578a7eb6b2d9993c74cfb9" +dependencies = [ + "itoa", + "memchr", + "serde", + "serde_core", + "zmij", +] + +[[package]] +name = "syn" +version = "2.0.119" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "872831b642d1a07999a962a351ed35b955ea2cfc8f3862091e2a240a84f17297" +dependencies = [ + "proc-macro2", + "quote", + "unicode-ident", +] + +[[package]] +name = "unicode-ident" +version = "1.0.24" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e6e4313cd5fcd3dad5cafa179702e2b244f760991f45397d14d4ebf38247da75" + +[[package]] +name = "wasm-bindgen" +version = "0.2.126" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4b067c0c11094aef6b7a801c1e34a26affafdf3d051dba08456b868789aaf9a4" +dependencies = [ + "cfg-if", + "once_cell", + "rustversion", + "wasm-bindgen-macro", + "wasm-bindgen-shared", +] + +[[package]] +name = "wasm-bindgen-macro" +version = "0.2.126" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "167ce5e579f6bcf889c4f7175a8a5a585de84e8ff93976ce393efa5f2837aab1" +dependencies = [ + "quote", + "wasm-bindgen-macro-support", +] + +[[package]] +name = "wasm-bindgen-macro-support" +version = "0.2.126" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f3997c7839262f4ef12cf90b818d6340c18e80f263f1a94bf157d0ec4420380e" +dependencies = [ + "bumpalo", + "proc-macro2", + "quote", + "syn", + "wasm-bindgen-shared", +] + +[[package]] +name = "wasm-bindgen-shared" +version = "0.2.126" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dc1b4cb0cc549fcf58d7dfc081778139b3d283a081644e833e84682ad71cea24" +dependencies = [ + "unicode-ident", +] + +[[package]] +name = "zmij" +version = "1.0.23" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "29666d0abbfad1e3dc4dcf6144730dd3a3ab225bbbdac83319345b1b44ccfc1b" diff --git a/engines/rust/Cargo.toml b/engines/rust/Cargo.toml new file mode 100644 index 0000000..56afbb3 --- /dev/null +++ b/engines/rust/Cargo.toml @@ -0,0 +1,23 @@ +[package] +name = "regex-tools-rust-engine" +version = "0.1.0" +edition = "2024" +rust-version = "1.97.1" +license = "GPL-3.0-or-later" +publish = false + +[lib] +crate-type = ["cdylib"] + +[dependencies] +regex = "=1.13.1" +serde = { version = "=1.0.228", features = ["derive"] } +serde_json = "=1.0.150" +wasm-bindgen = "=0.2.126" + +[profile.release] +codegen-units = 1 +lto = true +opt-level = "z" +panic = "abort" +strip = "symbols" diff --git a/engines/rust/README.md b/engines/rust/README.md new file mode 100644 index 0000000..5f5fc46 --- /dev/null +++ b/engines/rust/README.md @@ -0,0 +1,25 @@ +# Rust regex WebAssembly engine + +This directory builds the actual Rust `regex` crate 1.13.1 for +`wasm32-unknown-unknown` with Rust 1.97.1 and wasm-bindgen 0.2.126. + +The fixed bridge accepts JSON values only. The adapter measures the exact +encoded request size, and the native cap includes JSON's worst-case sixfold +escaping for every accepted string field. It exposes native UTF-8 byte offsets, +capture names, iteration, and `Captures::expand` replacement syntax. It does +not evaluate user values as Rust or JavaScript source. + +Replacement uses a bounded streaming implementation of +`Captures::expand` grammar. Load-time differential fixtures compare it with +the native API, and capture references stop expanding as soon as the UTF-8 +output cap is reached. +The bounded bytes cross the JSON bridge as base64, so control-heavy output has +a fixed 4:3 transport expansion instead of JSON's content-dependent escaping. + +Flags `i`, `m`, `s`, `U`, `x`, and `R` map directly to `RegexBuilder`. +Unicode is the crate's native default; the accepted `u` flag explicitly +affirms that default. `g` selects the crate's native iterator. + +The crate deliberately excludes look-around and backreferences. Compile-size, +DFA-cache, pattern, subject, match, capture-row, and output limits are enforced +inside the module. Replacement output is clipped only at a UTF-8 boundary. diff --git a/engines/rust/rust-toolchain.toml b/engines/rust/rust-toolchain.toml new file mode 100644 index 0000000..16d10a7 --- /dev/null +++ b/engines/rust/rust-toolchain.toml @@ -0,0 +1,4 @@ +[toolchain] +channel = "1.97.1" +profile = "minimal" +targets = ["wasm32-unknown-unknown"] diff --git a/engines/rust/src/lib.rs b/engines/rust/src/lib.rs new file mode 100644 index 0000000..4b37238 --- /dev/null +++ b/engines/rust/src/lib.rs @@ -0,0 +1,574 @@ +//! Fixed, bounded WebAssembly bridge for Rust's `regex` crate 1.13.1. +//! +//! User-controlled pattern, subject and replacement values enter through +//! deserialized JSON. They are never interpreted as Rust or JavaScript source. + +#![forbid(unsafe_code)] + +use regex::{Captures, Regex, RegexBuilder}; +use serde::{Deserialize, Serialize}; +use serde_json::{Map, Value}; +use std::collections::{BTreeMap, BTreeSet}; +use wasm_bindgen::prelude::*; + +const BRIDGE_ABI_VERSION: u32 = 1; +const REGEX_CRATE_VERSION: &str = "1.13.1"; +const RUSTC_VERSION: &str = env!("REGEX_TOOLS_RUSTC_VERSION"); +const EXPECTED_RUSTC_VERSION: &str = "rustc 1.97.1 (8bab26f4f 2026-07-14)"; +const MAXIMUM_PATTERN_BYTES: usize = 256 * 1024; +const MAXIMUM_SUBJECT_BYTES: usize = 16 * 1024 * 1024; +const MAXIMUM_REPLACEMENT_BYTES: usize = 256 * 1024; +const MAXIMUM_MATCHES: usize = 10_000; +const MAXIMUM_CAPTURE_ROWS: usize = 100_000; +const MAXIMUM_CAPTURE_GROUPS: usize = 1_000; +const MAXIMUM_OUTPUT_BYTES: usize = 64 * 1024 * 1024; +const MAXIMUM_REQUEST_JSON_BYTES: usize = + 6 * (MAXIMUM_SUBJECT_BYTES + MAXIMUM_PATTERN_BYTES + MAXIMUM_REPLACEMENT_BYTES) + + 64 * 1024; +const MAXIMUM_ERROR_MESSAGE_BYTES: usize = 1_024; +const COMPILED_SIZE_LIMIT_BYTES: usize = 10 * 1024 * 1024; +const DFA_SIZE_LIMIT_BYTES: usize = 2 * 1024 * 1024; + +#[derive(Deserialize)] +#[serde(rename_all = "camelCase", deny_unknown_fields)] +struct BridgeRequest { + abi: u32, + operation: String, + pattern: String, + flags: String, + options: BTreeMap, + subject: String, + scan_all: bool, + maximum_matches: usize, + maximum_capture_rows: usize, + replacement: Option, + maximum_output_bytes: Option, +} + +#[derive(Serialize)] +#[serde(rename_all = "camelCase")] +struct BridgeFailure { + abi: u32, + ok: bool, + phase: &'static str, + code: &'static str, + message: String, +} + +#[derive(Serialize)] +struct NativeMatch { + span: [usize; 2], + captures: Vec>, +} + +#[derive(Serialize)] +#[serde(rename_all = "camelCase")] +struct BridgeSuccess { + abi: u32, + ok: bool, + group_count: usize, + group_names: Vec<(usize, String)>, + matches: Vec, + results_truncated: bool, + #[serde(skip_serializing_if = "Option::is_none")] + output_base64: Option, + #[serde(skip_serializing_if = "Option::is_none")] + output_bytes: Option, + #[serde(skip_serializing_if = "Option::is_none")] + output_truncated: Option, +} + +fn bounded_message(value: impl std::fmt::Display) -> String { + let value = value.to_string(); + if value.len() <= MAXIMUM_ERROR_MESSAGE_BYTES { + return value; + } + let mut end = MAXIMUM_ERROR_MESSAGE_BYTES - "…".len(); + while !value.is_char_boundary(end) { + end -= 1; + } + format!("{}…", &value[..end]) +} + +fn serialize(value: &T) -> String { + match serde_json::to_string(value) { + Ok(encoded) => encoded, + Err(_) => { + "{\"abi\":1,\"ok\":false,\"phase\":\"bridge\",\"code\":\"serialization-error\",\"message\":\"The Rust bridge could not serialize its bounded result.\"}".to_owned() + } + } +} + +fn failure(phase: &'static str, code: &'static str, message: impl std::fmt::Display) -> String { + serialize(&BridgeFailure { + abi: BRIDGE_ABI_VERSION, + ok: false, + phase, + code, + message: bounded_message(message), + }) +} + +fn validate_request(request: &BridgeRequest) -> Result<(), String> { + if request.abi != BRIDGE_ABI_VERSION { + return Err(failure( + "bridge", + "abi-mismatch", + "The bridge ABI version is unsupported.", + )); + } + if request.operation != "execute" && request.operation != "replace" { + return Err(failure( + "bridge", + "invalid-operation", + "The bridge operation is unsupported.", + )); + } + if !request.options.is_empty() { + return Err(failure( + "bridge", + "unsupported-option", + "Rust regex does not accept engine options.", + )); + } + if request.pattern.len() > MAXIMUM_PATTERN_BYTES { + return Err(failure( + "bridge", + "pattern-limit", + "The pattern exceeds the bridge limit.", + )); + } + if request.subject.len() > MAXIMUM_SUBJECT_BYTES { + return Err(failure( + "bridge", + "subject-limit", + "The subject exceeds the bridge limit.", + )); + } + if request.maximum_matches == 0 + || request.maximum_matches > MAXIMUM_MATCHES + || request.maximum_capture_rows == 0 + || request.maximum_capture_rows > MAXIMUM_CAPTURE_ROWS + { + return Err(failure( + "bridge", + "result-limit", + "The requested result bounds are outside the bridge contract.", + )); + } + let mut seen = BTreeSet::new(); + for flag in request.flags.chars() { + if !"gimsUuxR".contains(flag) || !seen.insert(flag) { + return Err(failure( + "bridge", + "unsupported-flag", + "The request contains an unsupported or duplicate Rust flag.", + )); + } + } + if request.operation == "execute" { + if request.replacement.is_some() || request.maximum_output_bytes.is_some() { + return Err(failure( + "bridge", + "invalid-request", + "Execution requests cannot contain replacement fields.", + )); + } + return Ok(()); + } + let Some(replacement) = &request.replacement else { + return Err(failure( + "bridge", + "invalid-request", + "Replacement requests require a template.", + )); + }; + let Some(output_limit) = request.maximum_output_bytes else { + return Err(failure( + "bridge", + "invalid-request", + "Replacement requests require an output bound.", + )); + }; + if replacement.len() > MAXIMUM_REPLACEMENT_BYTES { + return Err(failure( + "bridge", + "replacement-limit", + "The replacement exceeds the bridge limit.", + )); + } + if output_limit == 0 || output_limit > MAXIMUM_OUTPUT_BYTES { + return Err(failure( + "bridge", + "output-limit", + "The output bound is outside the bridge contract.", + )); + } + Ok(()) +} + +fn compile(request: &BridgeRequest) -> Result { + let has = |flag| request.flags.contains(flag); + let mut builder = RegexBuilder::new(&request.pattern); + builder + .case_insensitive(has('i')) + .multi_line(has('m')) + .dot_matches_new_line(has('s')) + .swap_greed(has('U')) + // Unicode is Rust regex's native default. The accepted `u` flag is an + // explicit affirmation, not a request to disable Unicode when absent. + .unicode(true) + .ignore_whitespace(has('x')) + .crlf(has('R')) + .size_limit(COMPILED_SIZE_LIMIT_BYTES) + .dfa_size_limit(DFA_SIZE_LIMIT_BYTES); + builder + .build() + .map_err(|error| failure("compile", "compile-error", error)) +} + +fn materialize(captures: &Captures<'_>, group_count: usize) -> NativeMatch { + let whole = captures + .get(0) + .expect("regex captures always contain the complete match"); + let groups = (1..=group_count) + .map(|group| { + captures + .get(group) + .map(|capture| [capture.start(), capture.end()]) + }) + .collect(); + NativeMatch { + span: [whole.start(), whole.end()], + captures: groups, + } +} + +fn collect_matches( + compiled: &Regex, + request: &BridgeRequest, + group_count: usize, +) -> (Vec, bool) { + let rows_per_match = group_count.max(1); + let allowed = request + .maximum_matches + .min(request.maximum_capture_rows / rows_per_match); + let global = request.flags.contains('g'); + let mut records = Vec::with_capacity(allowed.min(256)); + let mut truncated = false; + if global { + for captures in compiled.captures_iter(&request.subject) { + if records.len() == allowed { + truncated = true; + break; + } + records.push(materialize(&captures, group_count)); + } + } else if let Some(captures) = compiled.captures(&request.subject) { + if allowed == 0 { + truncated = true; + } else { + records.push(materialize(&captures, group_count)); + } + } + (records, truncated) +} + +struct BoundedOutput { + value: String, + maximum: usize, + truncated: bool, +} + +impl BoundedOutput { + fn new(maximum: usize) -> Self { + Self { + value: String::with_capacity(maximum.min(64 * 1024)), + maximum, + truncated: false, + } + } + + fn append(&mut self, value: &str) { + if self.truncated || value.is_empty() { + return; + } + let remaining = self.maximum - self.value.len(); + if value.len() <= remaining { + self.value.push_str(value); + return; + } + let mut end = remaining; + while !value.is_char_boundary(end) { + end -= 1; + } + self.value.push_str(&value[..end]); + self.truncated = true; + } +} + +enum ReplacementReference<'a> { + Number(usize), + Named(&'a str), +} + +fn capture_reference(replacement: &str) -> Option<(ReplacementReference<'_>, usize)> { + let bytes = replacement.as_bytes(); + if bytes.len() <= 1 || bytes[0] != b'$' { + return None; + } + let (name, end) = if bytes[1] == b'{' { + let close = bytes[2..].iter().position(|&byte| byte == b'}')? + 2; + (&replacement[2..close], close + 1) + } else { + let mut end = 1; + while bytes + .get(end) + .is_some_and(|byte| byte.is_ascii_alphanumeric() || *byte == b'_') + { + end += 1; + } + if end == 1 { + return None; + } + (&replacement[1..end], end) + }; + let reference = match name.parse::() { + Ok(number) => ReplacementReference::Number(number), + Err(_) => ReplacementReference::Named(name), + }; + Some((reference, end)) +} + +fn expand_replacement_bounded( + output: &mut BoundedOutput, + captures: &Captures<'_>, + mut replacement: &str, +) { + while !replacement.is_empty() && !output.truncated { + let Some(dollar) = replacement.as_bytes().iter().position(|&byte| byte == b'$') else { + output.append(replacement); + return; + }; + output.append(&replacement[..dollar]); + if output.truncated { + return; + } + replacement = &replacement[dollar..]; + if replacement.as_bytes().get(1) == Some(&b'$') { + output.append("$"); + replacement = &replacement[2..]; + continue; + } + let Some((reference, end)) = capture_reference(replacement) else { + output.append("$"); + replacement = &replacement[1..]; + continue; + }; + replacement = &replacement[end..]; + let capture = match reference { + ReplacementReference::Number(number) => captures.get(number), + ReplacementReference::Named(name) => captures.name(name), + }; + if let Some(capture) = capture { + output.append(capture.as_str()); + } + } +} + +fn encode_base64(input: &[u8]) -> String { + const ALPHABET: &[u8; 64] = b"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + let mut encoded = String::with_capacity(input.len().div_ceil(3) * 4); + for chunk in input.chunks(3) { + let first = chunk[0]; + let second = chunk.get(1).copied().unwrap_or(0); + let third = chunk.get(2).copied().unwrap_or(0); + encoded.push(ALPHABET[usize::from(first >> 2)] as char); + encoded.push(ALPHABET[usize::from(((first & 0x03) << 4) | (second >> 4))] as char); + encoded.push(if chunk.len() > 1 { + ALPHABET[usize::from(((second & 0x0f) << 2) | (third >> 6))] as char + } else { + '=' + }); + encoded.push(if chunk.len() > 2 { + ALPHABET[usize::from(third & 0x3f)] as char + } else { + '=' + }); + } + encoded +} + +fn replace_bounded( + compiled: &Regex, + request: &BridgeRequest, + accepted_matches: usize, +) -> (String, usize, bool) { + let replacement = request + .replacement + .as_deref() + .expect("validated replacement request"); + let output_limit = request + .maximum_output_bytes + .expect("validated replacement request"); + let mut output = BoundedOutput::new(output_limit); + let mut cursor = 0; + let global = request.flags.contains('g'); + let maximum = if global { + accepted_matches + } else { + accepted_matches.min(1) + }; + for captures in compiled.captures_iter(&request.subject).take(maximum) { + let whole = captures + .get(0) + .expect("regex captures always contain the complete match"); + output.append(&request.subject[cursor..whole.start()]); + expand_replacement_bounded(&mut output, &captures, replacement); + cursor = whole.end(); + } + output.append(&request.subject[cursor..]); + let bytes = output.value.len(); + ( + encode_base64(output.value.as_bytes()), + bytes, + output.truncated, + ) +} + +fn execute(encoded: &str) -> String { + if encoded.len() > MAXIMUM_REQUEST_JSON_BYTES { + return failure( + "bridge", + "request-limit", + "The encoded request exceeds the bridge limit.", + ); + } + let request: BridgeRequest = match serde_json::from_str(encoded) { + Ok(request) => request, + Err(error) => return failure("bridge", "invalid-request", error), + }; + if let Err(error) = validate_request(&request) { + return error; + } + // Reading the field also keeps the transport contract explicit: matching + // is selected by the normalized native `g` flag, while scanAll records the + // application request that caused an internal `g` to be added. + let _scan_all = request.scan_all; + let compiled = match compile(&request) { + Ok(compiled) => compiled, + Err(error) => return error, + }; + let group_count = compiled.captures_len() - 1; + if group_count > MAXIMUM_CAPTURE_GROUPS { + return failure( + "compile", + "capture-group-limit", + format!( + "The pattern declares {group_count} capture groups; the bridge limit is {MAXIMUM_CAPTURE_GROUPS}." + ), + ); + } + let group_names = compiled + .capture_names() + .enumerate() + .filter_map(|(number, name)| name.map(|name| (number, name.to_owned()))) + .filter(|(number, _)| *number > 0) + .collect(); + let (matches, results_truncated) = collect_matches(&compiled, &request, group_count); + let mut result = BridgeSuccess { + abi: BRIDGE_ABI_VERSION, + ok: true, + group_count, + group_names, + matches, + results_truncated, + output_base64: None, + output_bytes: None, + output_truncated: None, + }; + if request.operation == "replace" { + let (output_base64, output_bytes, output_truncated) = + replace_bounded(&compiled, &request, result.matches.len()); + result.output_base64 = Some(output_base64); + result.output_bytes = Some(output_bytes); + result.output_truncated = Some(output_truncated); + } + serialize(&result) +} + +fn self_test() -> bool { + if RUSTC_VERSION != EXPECTED_RUSTC_VERSION || encode_base64("😀".as_bytes()) != "8J+YgA==" { + return false; + } + let Ok(compiled) = Regex::new(r"(?P😀+)") else { + return false; + }; + let Some(captures) = compiled.captures("x😀😀") else { + return false; + }; + let Some(whole) = captures.get(0) else { + return false; + }; + let Some(word) = captures.name("word") else { + return false; + }; + if whole.start() != 1 || whole.end() != 9 || word.start() != 1 || word.end() != 9 { + return false; + } + for template in [ + "${word}-$word-$$", + "$1x|${1}x", + "${missing}|$|${word", + "$01|${01}|$123456789012345678901234567890", + "${}|${word}", + ] { + let mut native = String::new(); + captures.expand(template, &mut native); + let mut bounded = BoundedOutput::new(4 * 1024); + expand_replacement_bounded(&mut bounded, &captures, template); + if bounded.truncated || bounded.value != native { + return false; + } + } + let mut adversarial = BoundedOutput::new(5); + expand_replacement_bounded(&mut adversarial, &captures, &"${word}".repeat(32 * 1024)); + adversarial.truncated && adversarial.value == "😀" +} + +#[wasm_bindgen] +pub fn identity() -> String { + let mut identity = Map::new(); + identity.insert( + "bridge".to_owned(), + Value::String("regex-tools-rust-json".to_owned()), + ); + identity.insert("bridgeVersion".to_owned(), Value::from(BRIDGE_ABI_VERSION)); + identity.insert( + "engine".to_owned(), + Value::String("Rust regex crate".to_owned()), + ); + identity.insert( + "engineVersion".to_owned(), + Value::String(REGEX_CRATE_VERSION.to_owned()), + ); + identity.insert( + "offsetUnit".to_owned(), + Value::String("utf8-byte".to_owned()), + ); + identity.insert( + "rustcVersion".to_owned(), + Value::String(RUSTC_VERSION.to_owned()), + ); + identity.insert("selfTest".to_owned(), Value::Bool(self_test())); + let mut envelope = Map::new(); + envelope.insert("abi".to_owned(), Value::from(BRIDGE_ABI_VERSION)); + envelope.insert("ok".to_owned(), Value::Bool(true)); + envelope.insert("identity".to_owned(), Value::Object(identity)); + serialize(&Value::Object(envelope)) +} + +#[wasm_bindgen] +pub fn run(encoded: &str) -> String { + execute(encoded) +} diff --git a/package-lock.json b/package-lock.json index 3562dd6..5eb7922 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,12 +1,12 @@ { "name": "regex-tools", - "version": "0.3.0", + "version": "0.4.0", "lockfileVersion": 3, "requires": true, "packages": { "": { "name": "regex-tools", - "version": "0.3.0", + "version": "0.4.0", "license": "GPL-3.0-or-later", "dependencies": { "@add-ideas/toolbox-contract": "0.2.2", @@ -24,8 +24,13 @@ }, "devDependencies": { "@add-ideas/toolbox-testkit": "0.2.2", + "@bjorn3/browser_wasi_shim": "0.4.2", "@eslint/js": "10.0.1", + "@php-wasm/universal": "3.1.46", + "@php-wasm/web-8-5": "3.1.46", "@playwright/test": "1.61.1", + "@ruby/4.0-wasm-wasi": "2.9.3-2.9.4", + "@ruby/wasm-wasi": "2.9.3-2.9.4", "@testing-library/jest-dom": "6.9.1", "@testing-library/react": "16.3.2", "@testing-library/user-event": "14.6.1", @@ -389,6 +394,13 @@ "node": ">=6.9.0" } }, + "node_modules/@bjorn3/browser_wasi_shim": { + "version": "0.4.2", + "resolved": "https://registry.npmjs.org/@bjorn3/browser_wasi_shim/-/browser_wasi_shim-0.4.2.tgz", + "integrity": "sha512-/iHkCVUG3VbcbmEHn5iIUpIrh7a7WPiwZ3sHy4HZKZzBdSadwdddYDZAII2zBvQYV0Lfi8naZngPCN7WPHI/hA==", + "dev": true, + "license": "MIT OR Apache-2.0" + }, "node_modules/@bramus/specificity": { "version": "2.4.2", "resolved": "https://registry.npmjs.org/@bramus/specificity/-/specificity-2.4.2.tgz", @@ -954,6 +966,84 @@ "url": "https://github.com/sponsors/Boshen" } }, + "node_modules/@php-wasm/logger": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/logger/-/logger-3.1.46.tgz", + "integrity": "sha512-PfnDq5ammh5FXxkGX1TGEck9gmW3i76IvBCqtX4D45xnSBIuCeu8uf2oWuty2j/c8wTEO8vyRDdvCj5oow7bXw==", + "dev": true, + "license": "GPL-2.0-or-later", + "engines": { + "node": ">=20.10.0", + "npm": ">=10.2.3" + } + }, + "node_modules/@php-wasm/progress": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/progress/-/progress-3.1.46.tgz", + "integrity": "sha512-WmmgEm6yz322M3pzgAUjxckyhpVxr2WWlHyVYDyaMZWU6UIDUHfiRZRPzADohNyYvV3g0/zMNaDGmxz+TTXwQQ==", + "dev": true, + "license": "GPL-2.0-or-later", + "dependencies": { + "@php-wasm/logger": "3.1.46" + }, + "engines": { + "node": ">=20.10.0", + "npm": ">=10.2.3" + } + }, + "node_modules/@php-wasm/stream-compression": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/stream-compression/-/stream-compression-3.1.46.tgz", + "integrity": "sha512-+oUw4CPX52FgYXEh5C+MgJAg7Cy5OeaVuh7HnQR6oxb69nU63/r8tHTLV/WrWRyjBYh321uJzLV7Gg29qmiUtg==", + "dev": true, + "license": "GPL-2.0-or-later", + "dependencies": { + "@php-wasm/util": "3.1.46" + } + }, + "node_modules/@php-wasm/universal": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/universal/-/universal-3.1.46.tgz", + "integrity": "sha512-sx0KyN5kcsCMzwy+XJAyoOukSA5TEZYd0LK3l9kRP3I0CSd5h6JItkf5eZ42WltB+wD+aTRdqSwc/Mvkc7qBjQ==", + "dev": true, + "license": "GPL-2.0-or-later", + "dependencies": { + "@php-wasm/logger": "3.1.46", + "@php-wasm/progress": "3.1.46", + "@php-wasm/stream-compression": "3.1.46", + "@php-wasm/util": "3.1.46", + "ini": "4.1.2" + }, + "engines": { + "node": ">=20.10.0", + "npm": ">=10.2.3" + } + }, + "node_modules/@php-wasm/util": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/util/-/util-3.1.46.tgz", + "integrity": "sha512-Yh9HNbx+rB2R1tScUvvAsbJVIB7msjWceWYogyR2YvAOqlDL0ymZyaQ65+K3QcHh/8HostTRwwgQh5oK4DLDrA==", + "dev": true, + "engines": { + "node": ">=20.10.0", + "npm": ">=10.2.3" + } + }, + "node_modules/@php-wasm/web-8-5": { + "version": "3.1.46", + "resolved": "https://registry.npmjs.org/@php-wasm/web-8-5/-/web-8-5-3.1.46.tgz", + "integrity": "sha512-j9wwlY6aNXuKBr4JPJzqE+vkM3Onk+byJsxLqaJs4U0gYDUBLr8CuKuVr+p13apSTUosConePYTAs0214aNxYA==", + "dev": true, + "license": "GPL-2.0-or-later", + "dependencies": { + "@php-wasm/universal": "3.1.46", + "wasm-feature-detect": "1.8.0" + }, + "engines": { + "node": ">=20.10.0", + "npm": ">=10.2.3" + } + }, "node_modules/@playwright/test": { "version": "1.61.1", "resolved": "https://registry.npmjs.org/@playwright/test/-/test-1.61.1.tgz", @@ -1252,6 +1342,27 @@ "dev": true, "license": "MIT" }, + "node_modules/@ruby/4.0-wasm-wasi": { + "version": "2.9.3-2.9.4", + "resolved": "https://registry.npmjs.org/@ruby/4.0-wasm-wasi/-/4.0-wasm-wasi-2.9.3-2.9.4.tgz", + "integrity": "sha512-USLEWmCjM/DIota/9c7Mwzzl3v8mvmg4x24m+zMq8+vLx5+AdOS6dyXvsL/B8+XjQn5UgYhh3c8ekaUdWFkUMA==", + "dev": true, + "license": "MIT", + "dependencies": { + "@ruby/wasm-wasi": "2.9.3-2.9.4" + } + }, + "node_modules/@ruby/wasm-wasi": { + "version": "2.9.3-2.9.4", + "resolved": "https://registry.npmjs.org/@ruby/wasm-wasi/-/wasm-wasi-2.9.3-2.9.4.tgz", + "integrity": "sha512-WxW9wON/TIf+8Ktng8qDJeV/6iH8kw+YwxOsOyXdAdLJgfYDPAXOqpIVd/96y2C9V8VJ2yqZm/IRv6nLeV6EKg==", + "dev": true, + "license": "MIT", + "dependencies": { + "@bjorn3/browser_wasi_shim": "^0.4.2", + "tslib": "^2.8.1" + } + }, "node_modules/@standard-schema/spec": { "version": "1.1.0", "resolved": "https://registry.npmjs.org/@standard-schema/spec/-/spec-1.1.0.tgz", @@ -2614,6 +2725,16 @@ "node": ">=8" } }, + "node_modules/ini": { + "version": "4.1.2", + "resolved": "https://registry.npmjs.org/ini/-/ini-4.1.2.tgz", + "integrity": "sha512-AMB1mvwR1pyBFY/nSevUX6y8nJWS63/SzUKD3JyQn97s4xgIdgQPT75IRouIiBAN4yLQBUShNYVW0+UG25daCw==", + "dev": true, + "license": "ISC", + "engines": { + "node": "^14.17.0 || ^16.13.0 || >=18.0.0" + } + }, "node_modules/is-extglob": { "version": "2.1.1", "resolved": "https://registry.npmjs.org/is-extglob/-/is-extglob-2.1.1.tgz", @@ -3731,8 +3852,7 @@ "resolved": "https://registry.npmjs.org/tslib/-/tslib-2.8.1.tgz", "integrity": "sha512-oJFu94HQb+KVduSUQL7wnpmqnfmLsOA/nAh6b6EH0wCEoK0/mPeXU6c3wKDV83MkOuHPRHtSXKKU99IBazS/2w==", "dev": true, - "license": "0BSD", - "optional": true + "license": "0BSD" }, "node_modules/type-check": { "version": "0.4.0", @@ -4045,6 +4165,13 @@ "node": ">=18" } }, + "node_modules/wasm-feature-detect": { + "version": "1.8.0", + "resolved": "https://registry.npmjs.org/wasm-feature-detect/-/wasm-feature-detect-1.8.0.tgz", + "integrity": "sha512-zksaLKM2fVlnB5jQQDqKXXwYHLQUVH9es+5TOOHwGOVJOCeRBCiPjwSg+3tN2AdTCzjgli4jijCH290kXb/zWQ==", + "dev": true, + "license": "Apache-2.0" + }, "node_modules/webidl-conversions": { "version": "8.0.1", "resolved": "https://registry.npmjs.org/webidl-conversions/-/webidl-conversions-8.0.1.tgz", diff --git a/package.json b/package.json index 4ffaf75..c938fe5 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "regex-tools", - "version": "0.3.0", + "version": "0.4.0", "description": "Develop, explain, test and apply regular expressions locally in the browser.", "license": "GPL-3.0-or-later", "author": "Albrecht Degering", @@ -35,12 +35,33 @@ "engines:pcre2:build": "node scripts/build-engines.mjs --pcre2", "engines:pcre2:install": "node scripts/install-pcre2-engine.mjs", "engines:pcre2:verify": "node scripts/verify-engine-assets.mjs --pcre2-pack .engine-build/pcre2", + "engines:cpp:build": "node scripts/cpp-engine-pack.mjs", + "engines:cpp:install": "node scripts/install-cpp-engine.mjs", + "engines:cpp:verify": "node scripts/verify-engine-assets.mjs --cpp-pack public/engines/cpp", + "engines:dotnet:build": "node scripts/dotnet-engine-pack.mjs", + "engines:dotnet:install": "node scripts/install-dotnet-engine.mjs", + "engines:dotnet:verify": "node scripts/verify-engine-assets.mjs --dotnet-pack public/engines/dotnet", + "engines:go:build": "node scripts/build-go-engine.mjs", + "engines:go:install": "node scripts/install-go-engine.mjs", + "engines:go:verify": "node scripts/verify-engine-assets.mjs --go-pack public/engines/go", "engines:python:build": "node scripts/python-engine-pack.mjs", "engines:python:install": "node scripts/install-python-engine.mjs", "engines:python:verify": "node scripts/verify-engine-assets.mjs --python-pack public/engines/python", "engines:java:build": "node scripts/java-engine-pack.mjs", "engines:java:install": "node scripts/install-java-engine.mjs", "engines:java:verify": "node scripts/verify-engine-assets.mjs --java-pack public/engines/java", + "engines:perl:build": "node scripts/perl-engine-pack.mjs", + "engines:perl:install": "node scripts/install-perl-engine.mjs", + "engines:perl:verify": "node scripts/verify-engine-assets.mjs --perl-pack public/engines/perl", + "engines:php:build": "node scripts/php-engine-pack.mjs", + "engines:php:install": "node scripts/install-php-engine.mjs", + "engines:php:verify": "node scripts/verify-engine-assets.mjs --php-pack public/engines/php", + "engines:ruby:build": "node scripts/ruby-engine-pack.mjs", + "engines:ruby:install": "node scripts/install-ruby-engine.mjs", + "engines:ruby:verify": "node scripts/verify-engine-assets.mjs --ruby-pack public/engines/ruby", + "engines:rust:build": "node scripts/build-rust-engine.mjs", + "engines:rust:install": "node scripts/install-rust-engine.mjs", + "engines:rust:verify": "node scripts/verify-engine-assets.mjs --rust-pack public/engines/rust", "engines:verify": "node scripts/verify-engine-assets.mjs", "manifest:generate": "node scripts/generate-toolbox-manifest.mjs", "manifest:check": "node scripts/generate-toolbox-manifest.mjs --check", @@ -66,8 +87,13 @@ }, "devDependencies": { "@add-ideas/toolbox-testkit": "0.2.2", + "@bjorn3/browser_wasi_shim": "0.4.2", "@eslint/js": "10.0.1", + "@php-wasm/universal": "3.1.46", + "@php-wasm/web-8-5": "3.1.46", "@playwright/test": "1.61.1", + "@ruby/4.0-wasm-wasi": "2.9.3-2.9.4", + "@ruby/wasm-wasi": "2.9.3-2.9.4", "@testing-library/jest-dom": "6.9.1", "@testing-library/react": "16.3.2", "@testing-library/user-event": "14.6.1", diff --git a/playwright.config.ts b/playwright.config.ts index 8d5c452..0bdbc58 100644 --- a/playwright.config.ts +++ b/playwright.config.ts @@ -3,6 +3,7 @@ import { defineConfig, devices } from "@playwright/test"; export default defineConfig({ testDir: "./tests/browser", fullyParallel: false, + workers: 4, timeout: 120_000, expect: { timeout: 10_000 }, reporter: [["list"]], diff --git a/public/engines/README.md b/public/engines/README.md index 6069dc1..21dec10 100644 --- a/public/engines/README.md +++ b/public/engines/README.md @@ -1,13 +1,42 @@ # Engine assets Regex Tools executes ECMAScript through the browser's native `RegExp` engine. -It also ships three declared, self-hosted runtime packs: +It also ships ten declared, self-hosted runtime packs: -- `pcre2/`: official PCRE2 10.47, 8-bit WebAssembly; -- `python/`: Pyodide 314.0.3 with CPython 3.14.2 `re`; and +- `pcre2/`: official standalone PCRE2 10.47, 8-bit WebAssembly; +- `php/`: PHP 8.5.8 `preg_*` through `@php-wasm/web-8-5` 3.1.46; this runtime + reports PCRE2 10.44; +- `perl/`: Perl 5.28.1 through the legacy WebPerl 0.09-beta prebuilt runtime; +- `python/`: Pyodide 314.0.3 with CPython 3.14.2 `re`, a complete linked + base-runtime inventory (including vendored loader ports), + preferred-form/patch manifest and independently pinned legal closure; +- `ruby/`: minimal ruby.wasm 2.9.3-2.9.4 with CRuby 4.0.0 `Regexp`; - `java/`: TeaVM 0.15.0's `java.util.regex` class library compiled to an - ES2015 module. This module is not OpenJDK. + ES2015 module; this module is not OpenJDK; +- `cpp/`: Emscripten 6.0.4 libc++ `std::wregex`, with an exact traced native + component/source/legal manifest; +- `go/`: Go 1.26.5 standard-library `regexp` for `js/wasm`; +- `rust/`: Rust `regex` crate 1.13.1 for `wasm32-unknown-unknown`; and +- `dotnet/`: .NET 10.0.10 `System.Text.RegularExpressions` for browser + WebAssembly. + +The selectable Scala/JVM compatibility profile intentionally shares +`java/`. It does not contain or claim a Scala runtime. The packs come from pinned, documented open-source inputs. Runtime files travel with deterministic metadata, closed-set checksums and the applicable upstream licence/notice material, all of which are verified by the release gate. +The Python pack's `SOURCE-MANIFEST.json` records exact source archives or Git +trees, both vendored stack-parser source ports, all Pyodide +CPython/Emscripten patches and the evidence for every component already linked +into its loader or base WebAssembly module. The C++ source manifest similarly +binds its exact module to the traced Emscripten runtime, musl, emmalloc, +compiler-rt, libc++ and libc++abi inputs and the explicit non-selection of +libunwind. The +hundreds of optional entries in `pyodide-lock.json` are a package catalogue; +their wheels are not part of this pack. + +The Perl pack remains an explicit exception in age, not in identity: its +upstream beta assets are retained byte-for-byte and labelled legacy everywhere. +Its loader contains a dormant optional JavaScript-interoperability `eval` site; +the fixed bridge does not import or call it. diff --git a/public/engines/cpp/LICENSE-Emscripten.txt b/public/engines/cpp/LICENSE-Emscripten.txt new file mode 100644 index 0000000..70cabe3 --- /dev/null +++ b/public/engines/cpp/LICENSE-Emscripten.txt @@ -0,0 +1,102 @@ +Emscripten is available under 2 licenses, the MIT license and the +University of Illinois/NCSA Open Source License. + +Both are permissive open source licenses, with little if any +practical difference between them. + +The reason for offering both is that (1) the MIT license is +well-known, while (2) the University of Illinois/NCSA Open Source +License allows Emscripten's code to be integrated upstream into +LLVM, which uses that license, should the opportunity arise. + +The full text of both licenses follows. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following disclaimers + in the documentation and/or other materials provided with the + distribution. + + Neither the names of Mozilla, + nor the names of its contributors may be used to endorse + or promote products derived from this Software without specific prior + written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + +============================================================================== + +This program uses portions of Node.js source code located in src/library_path.js, +in accordance with the terms of the MIT license. Node's license follows: + + """ + Copyright Joyent, Inc. and other Node contributors. All rights reserved. + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. + """ + +The musl libc project is bundled in this repo, and it has the MIT license, see +system/lib/libc/musl/COPYRIGHT + +The third_party/ subdirectory contains code with other licenses. None of it is +used by default, but certain options use it (e.g., the optional closure compiler +flag will run closure compiler from third_party/). + diff --git a/public/engines/cpp/LICENSE-compiler-rt.txt b/public/engines/cpp/LICENSE-compiler-rt.txt new file mode 100644 index 0000000..5a79a1b --- /dev/null +++ b/public/engines/cpp/LICENSE-compiler-rt.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The compiler_rt library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2015 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/public/engines/cpp/LICENSE-libcxx.txt b/public/engines/cpp/LICENSE-libcxx.txt new file mode 100644 index 0000000..e159d28 --- /dev/null +++ b/public/engines/cpp/LICENSE-libcxx.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The libc++ library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2014 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/public/engines/cpp/LICENSE-libcxxabi.txt b/public/engines/cpp/LICENSE-libcxxabi.txt new file mode 100644 index 0000000..b75c044 --- /dev/null +++ b/public/engines/cpp/LICENSE-libcxxabi.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The libc++abi library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2014 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/public/engines/cpp/LICENSE-libunwind.txt b/public/engines/cpp/LICENSE-libunwind.txt new file mode 100644 index 0000000..1e31206 --- /dev/null +++ b/public/engines/cpp/LICENSE-libunwind.txt @@ -0,0 +1,311 @@ +============================================================================== +The LLVM Project is under the Apache License v2.0 with LLVM Exceptions: +============================================================================== + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + + +---- LLVM Exceptions to the Apache 2.0 License ---- + +As an exception, if, as a result of your compiling your source code, portions +of this Software are embedded into an Object form of such source code, you +may redistribute such embedded portions in such Object form without complying +with the conditions of Sections 4(a), 4(b) and 4(d) of the License. + +In addition, if you combine or link compiled forms of this Software with +software that is licensed under the GPLv2 ("Combined Software") and if a +court of competent jurisdiction determines that the patent provision (Section +3), the indemnity provision (Section 9) or other Section of the License +conflicts with the conditions of the GPLv2, you may retroactively and +prospectively choose to deem waived or otherwise exclude such Section(s) of +the License, but only in their entirety and only with respect to the Combined +Software. + +============================================================================== +Software from third parties included in the LLVM Project: +============================================================================== +The LLVM Project contains third party software which is under different license +terms. All such code will be identified clearly using at least one of two +mechanisms: +1) It will be in a separate directory tree with its own `LICENSE.txt` or + `LICENSE` file at the top containing the specific license and restrictions + which apply to that software, or +2) It will contain specific license and restriction terms at the top of every + file. + +============================================================================== +Legacy LLVM License (https://llvm.org/docs/DeveloperPolicy.html#legacy): +============================================================================== + +The libunwind library is dual licensed under both the University of Illinois +"BSD-Like" license and the MIT license. As a user of this code you may choose +to use it under either license. As a contributor, you agree to allow your code +to be used under both. + +Full text of the relevant licenses is included below. + +============================================================================== + +University of Illinois/NCSA +Open Source License + +Copyright (c) 2009-2019 by the contributors listed in CREDITS.TXT + +All rights reserved. + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +============================================================================== + +Copyright (c) 2009-2014 by the contributors listed in CREDITS.TXT + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/public/engines/cpp/LICENSE-musl.txt b/public/engines/cpp/LICENSE-musl.txt new file mode 100644 index 0000000..2f15edc --- /dev/null +++ b/public/engines/cpp/LICENSE-musl.txt @@ -0,0 +1,193 @@ +musl as a whole is licensed under the following standard MIT license: + +---------------------------------------------------------------------- +Copyright © 2005-2020 Rich Felker, et al. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +---------------------------------------------------------------------- + +Authors/contributors include: + +A. Wilcox +Ada Worcester +Alex Dowad +Alex Suykov +Alexander Monakov +Andre McCurdy +Andrew Kelley +Anthony G. Basile +Aric Belsito +Arvid Picciani +Bartosz Brachaczek +Benjamin Peterson +Bobby Bingham +Boris Brezillon +Brent Cook +Chris Spiegel +Clément Vasseur +Daniel Micay +Daniel Sabogal +Daurnimator +David Carlier +David Edelsohn +Denys Vlasenko +Dmitry Ivanov +Dmitry V. Levin +Drew DeVault +Emil Renner Berthing +Fangrui Song +Felix Fietkau +Felix Janda +Gianluca Anzolin +Hauke Mehrtens +He X +Hiltjo Posthuma +Isaac Dunham +Jaydeep Patil +Jens Gustedt +Jeremy Huntwork +Jo-Philipp Wich +Joakim Sindholt +John Spencer +Julien Ramseier +Justin Cormack +Kaarle Ritvanen +Khem Raj +Kylie McClain +Leah Neukirchen +Luca Barbato +Luka Perkov +Lynn Ochs +M Farkas-Dyck (Strake) +Mahesh Bodapati +Markus Wichmann +Masanori Ogino +Michael Clark +Michael Forney +Mikhail Kremnyov +Natanael Copa +Nicholas J. Kain +orc +Pascal Cuoq +Patrick Oppenlander +Petr Hosek +Petr Skocik +Pierre Carrier +Reini Urban +Rich Felker +Richard Pennington +Ryan Fairfax +Samuel Holland +Segev Finer +Shiz +sin +Solar Designer +Stefan Kristiansson +Stefan O'Rear +Szabolcs Nagy +Timo Teräs +Trutz Behn +Will Dietz +William Haddon +William Pitcock + +Portions of this software are derived from third-party works licensed +under terms compatible with the above MIT license: + +The TRE regular expression implementation (src/regex/reg* and +src/regex/tre*) is Copyright © 2001-2008 Ville Laurikari and licensed +under a 2-clause BSD license (license text in the source files). The +included version has been heavily modified by Rich Felker in 2012, in +the interests of size, simplicity, and namespace cleanliness. + +Much of the math library code (src/math/* and src/complex/*) is +Copyright © 1993,2004 Sun Microsystems or +Copyright © 2003-2011 David Schultz or +Copyright © 2003-2009 Steven G. Kargl or +Copyright © 2003-2009 Bruce D. Evans or +Copyright © 2008 Stephen L. Moshier or +Copyright © 2017-2018 Arm Limited +and labelled as such in comments in the individual source files. All +have been licensed under extremely permissive terms. + +The ARM memcpy code (src/string/arm/memcpy.S) is Copyright © 2008 +The Android Open Source Project and is licensed under a two-clause BSD +license. It was taken from Bionic libc, used on Android. + +The AArch64 memcpy and memset code (src/string/aarch64/*) are +Copyright © 1999-2019, Arm Limited. + +The implementation of DES for crypt (src/crypt/crypt_des.c) is +Copyright © 1994 David Burren. It is licensed under a BSD license. + +The implementation of blowfish crypt (src/crypt/crypt_blowfish.c) was +originally written by Solar Designer and placed into the public +domain. The code also comes with a fallback permissive license for use +in jurisdictions that may not recognize the public domain. + +The smoothsort implementation (src/stdlib/qsort.c) is Copyright © 2011 +Lynn Ochs and is licensed under an MIT-style license. + +The x86_64 port was written by Nicholas J. Kain and is licensed under +the standard MIT terms. + +The mips and microblaze ports were originally written by Richard +Pennington for use in the ellcc project. The original code was adapted +by Rich Felker for build system and code conventions during upstream +integration. It is licensed under the standard MIT terms. + +The mips64 port was contributed by Imagination Technologies and is +licensed under the standard MIT terms. + +The powerpc port was also originally written by Richard Pennington, +and later supplemented and integrated by John Spencer. It is licensed +under the standard MIT terms. + +All other files which have no copyright comments are original works +produced specifically for use as part of this library, written either +by Rich Felker, the main author of the library, or by one or more +contibutors listed above. Details on authorship of individual files +can be found in the git version control history of the project. The +omission of copyright and license comments in each file is in the +interest of source tree size. + +In addition, permission is hereby granted for all public header files +(include/* and arch/*/bits/*) and crt files intended to be linked into +applications (crt/*, ldso/dlstart.c, and arch/*/crt_arch.h) to omit +the copyright notice and permission notice otherwise required by the +license, and to use these files without any requirement of +attribution. These files include substantial contributions from: + +Bobby Bingham +John Spencer +Nicholas J. Kain +Rich Felker +Richard Pennington +Stefan Kristiansson +Szabolcs Nagy + +all of whom have explicitly granted such permission. + +This file previously contained text expressing a belief that most of +the files covered by the above exception were sufficiently trivial not +to be subject to copyright, resulting in confusion over whether it +negated the permissions granted in the license. In the spirit of +permissive licensing, and of not having licensing issues being an +obstacle to adoption, that text has been removed. diff --git a/public/engines/cpp/SHA256SUMS b/public/engines/cpp/SHA256SUMS new file mode 100644 index 0000000..aba7dcb --- /dev/null +++ b/public/engines/cpp/SHA256SUMS @@ -0,0 +1,10 @@ +620a78084fc7ca97c0b5dea9abf891f3ffcadfdbf305276f099c9c4e12fc1d86 LICENSE-Emscripten.txt +1a8f1058753f1ba890de984e48f0242a3a5c29a6a8f2ed9fd813f36985387e8d LICENSE-compiler-rt.txt +539dd7aed86e8a4f12cbdd0e6c50c189c7d74847e4fecc64ce2c6ee3a01da38b LICENSE-libcxx.txt +e2b35be49f7284a45b7baca8fc7b3ab7440e7902392b2528a457816b5bb2a15c LICENSE-libcxxabi.txt +b5efebcaca80879234098e52d1725e6d9eb8fb96a19fce625d39184b705f7b6d LICENSE-libunwind.txt +b870108ec5e7790e9f9919064f1b9421d62d5f9b0e6c230c6adf7ea2da62e97b LICENSE-musl.txt +8e45a797178ae85a0dcf9fd96c6b5a841cb50fd7f729ffc5342f7f838bf2bcd9 SOURCE-MANIFEST.json +0d7662707b103af64f5b13302c8159178d3363c332030494cce7b2f9a4a8c0a7 cpp-regex.mjs +231c0a37472f2ef7880377b044adadd31a852a0adf2e3cf023055b5dca74c460 cpp-regex.wasm +d2ef97f36d36c90cad6f975c7a4040174888645129cd9d81d3f6c441b6796b57 engine-metadata.json diff --git a/public/engines/cpp/SOURCE-MANIFEST.json b/public/engines/cpp/SOURCE-MANIFEST.json new file mode 100644 index 0000000..5aceacd --- /dev/null +++ b/public/engines/cpp/SOURCE-MANIFEST.json @@ -0,0 +1,219 @@ +{ + "schemaVersion": 1, + "engine": "cpp", + "scope": { + "asset": "cpp-regex.wasm", + "assetSha256": "231c0a37472f2ef7880377b044adadd31a852a0adf2e3cf023055b5dca74c460", + "assetBytes": 251481, + "purpose": "Complete linked-component, preferred-source and legal inventory for the exact C++ WebAssembly module" + }, + "sourceSnapshot": { + "project": "Emscripten", + "version": "6.0.4", + "tag": "6.0.4", + "commitSha1": "fe5be6afdff43ad58860d821fcc8572a23f92d19", + "repository": "https://github.com/emscripten-core/emscripten", + "preferredSourceUrl": "https://github.com/emscripten-core/emscripten/tree/fe5be6afdff43ad58860d821fcc8572a23f92d19", + "archiveUrl": "https://github.com/emscripten-core/emscripten/archive/fe5be6afdff43ad58860d821fcc8572a23f92d19.tar.gz", + "emsdk": { + "tag": "6.0.4", + "commitSha1": "224ec5f9f2f72f09f9ce0e26d66bae7dbd8b692f", + "releaseCommitSha1": "b23272fac5d05617cd36dc451356dca0f79bf22d", + "repository": "https://github.com/emscripten-core/emsdk" + }, + "llvmToolchain": { + "version": "24.0.0git", + "commitSha1": "c050c487e9edb97ef44f53cb29fe1d8bcddb8f76", + "repository": "https://github.com/llvm/llvm-project" + } + }, + "buildSelection": { + "exceptionMode": "Emscripten JavaScript exceptions (-fexceptions)", + "allocator": "emmalloc (-sMALLOC=emmalloc)", + "exactLinkedArchives": [ + "libc++.a", + "libc++abi.a", + "libc.a", + "libclang_rt.builtins.a", + "libembind-rtti.a", + "libemmalloc.a", + "libnoexit.a", + "libstubs.a" + ], + "inventoryMethod": "the pack builder adds wasm-ld --trace, accepts this exact archive set and fails on any addition, removal or libunwind selection" + }, + "sourceEvidence": [ + { + "sourcePath": "emscripten-revision.txt", + "sourceSha256": "33d347ba6aa1de448bc1727d46912c1abcbddac9a32dcf4794d7098dea16e1ad" + }, + { + "sourcePath": "emscripten-version.txt", + "sourceSha256": "1ae2390b7da62b8488a9f596a39ed978b22356de0f267db9ae9dd43d0d3faa6e" + }, + { + "sourcePath": "system/lib/compiler-rt/README.md", + "sourceSha256": "50648d4da5c5c88468da064bd9ba29d68d47597607852330423da0a1cf987946" + }, + { + "sourcePath": "system/lib/libc/README.md", + "sourceSha256": "69aeb7c1991af58c547f8da100c57ff38f53c4015f4df579731c5abab84654b9" + }, + { + "sourcePath": "system/lib/libcxx/README.md", + "sourceSha256": "da90136512d04c06e2bd27ef18d71be34bfc64c06bc29b12ddcf66bb76ae193b" + }, + { + "sourcePath": "system/lib/libcxxabi/README.md", + "sourceSha256": "dcfec7b2c2987ce00e513cac89933f4d30329070570c4efdb4d1d00297182736" + }, + { + "sourcePath": "system/lib/libunwind/README.md", + "sourceSha256": "26b3b06b2640cee75b2cf4e01b0956a0fd6cc5ca2054998e18d66ff060762410" + }, + { + "sourcePath": "system/lib/emmalloc.c", + "sourceSha256": "00eb577cbef51a3359c309f45a7c99a814b8c6151ab75c9a3c78a56f0169146b" + } + ], + "linkedComponents": [ + { + "id": "emscripten-runtime", + "version": "6.0.4", + "linked": true, + "linkedArchives": [ + "libembind-rtti.a", + "libnoexit.a", + "libstubs.a" + ], + "sourcePath": "src, system/lib and tools", + "sourceEvidencePath": "emscripten-revision.txt", + "license": "MIT OR NCSA", + "legalFiles": [ + "LICENSE-Emscripten.txt" + ], + "evidence": "Emscripten-generated JavaScript/runtime imports plus exact linker-trace archive members" + }, + { + "id": "musl", + "version": "1.2.6 with Emscripten changes", + "linked": true, + "linkedArchives": [ + "libc.a" + ], + "sourcePath": "system/lib/libc", + "sourceEvidencePath": "system/lib/libc/README.md", + "license": "MIT and file-level compatible terms", + "legalFiles": [ + "LICENSE-musl.txt" + ], + "evidence": "exact linker trace selects members of libc.a" + }, + { + "id": "emmalloc", + "version": "Emscripten 6.0.4 snapshot", + "linked": true, + "linkedArchives": [ + "libemmalloc.a" + ], + "sourcePath": "system/lib/emmalloc.c", + "sourceEvidencePath": "system/lib/emmalloc.c", + "license": "MIT OR NCSA", + "legalFiles": [ + "LICENSE-Emscripten.txt" + ], + "evidence": "the build fixes -sMALLOC=emmalloc and the exact linker trace selects emmalloc.o and sbrk.o" + }, + { + "id": "compiler-rt", + "version": "22.1.8 with Emscripten changes", + "linked": true, + "linkedArchives": [ + "libclang_rt.builtins.a" + ], + "sourcePath": "system/lib/compiler-rt", + "sourceEvidencePath": "system/lib/compiler-rt/README.md", + "license": "Apache-2.0 WITH LLVM-exception and legacy component terms", + "legalFiles": [ + "LICENSE-compiler-rt.txt" + ], + "evidence": "exact linker trace selects compiler-rt builtins, including Emscripten exception support" + }, + { + "id": "libc++", + "version": "21.1.8 with Emscripten changes", + "linked": true, + "linkedArchives": [ + "libc++.a" + ], + "sourcePath": "system/lib/libcxx", + "sourceEvidencePath": "system/lib/libcxx/README.md", + "license": "Apache-2.0 WITH LLVM-exception and legacy component terms", + "legalFiles": [ + "LICENSE-libcxx.txt" + ], + "evidence": "exact linker trace selects libc++ regex, locale, string, exception and support objects" + }, + { + "id": "libc++abi", + "version": "21.1.8 with Emscripten changes", + "linked": true, + "linkedArchives": [ + "libc++abi.a" + ], + "sourcePath": "system/lib/libcxxabi", + "sourceEvidencePath": "system/lib/libcxxabi/README.md", + "license": "Apache-2.0 WITH LLVM-exception and legacy component terms", + "legalFiles": [ + "LICENSE-libcxxabi.txt" + ], + "evidence": "exact linker trace selects the Emscripten C++ exception ABI and type-information objects" + }, + { + "id": "libunwind", + "version": "22.1.8 with Emscripten changes", + "linked": false, + "linkedArchives": [], + "consideredArchive": "libunwind.a", + "sourcePath": "system/lib/libunwind", + "sourceEvidencePath": "system/lib/libunwind/README.md", + "license": "Apache-2.0 WITH LLVM-exception and legacy component terms", + "legalFiles": [ + "LICENSE-libunwind.txt" + ], + "evidence": "audited exclusion: the exact JavaScript-exception linker trace selects no libunwind.a member; its legal text is retained to make that boundary reviewable" + } + ], + "legalFiles": [ + { + "path": "LICENSE-Emscripten.txt", + "sha256": "620a78084fc7ca97c0b5dea9abf891f3ffcadfdbf305276f099c9c4e12fc1d86", + "bytes": 5093 + }, + { + "path": "LICENSE-compiler-rt.txt", + "sha256": "1a8f1058753f1ba890de984e48f0242a3a5c29a6a8f2ed9fd813f36985387e8d", + "bytes": 16708 + }, + { + "path": "LICENSE-libcxx.txt", + "sha256": "539dd7aed86e8a4f12cbdd0e6c50c189c7d74847e4fecc64ce2c6ee3a01da38b", + "bytes": 16703 + }, + { + "path": "LICENSE-libcxxabi.txt", + "sha256": "e2b35be49f7284a45b7baca8fc7b3ab7440e7902392b2528a457816b5bb2a15c", + "bytes": 16706 + }, + { + "path": "LICENSE-libunwind.txt", + "sha256": "b5efebcaca80879234098e52d1725e6d9eb8fb96a19fce625d39184b705f7b6d", + "bytes": 16706 + }, + { + "path": "LICENSE-musl.txt", + "sha256": "b870108ec5e7790e9f9919064f1b9421d62d5f9b0e6c230c6adf7ea2da62e97b", + "bytes": 6196 + } + ] +} diff --git a/public/engines/cpp/cpp-regex.mjs b/public/engines/cpp/cpp-regex.mjs new file mode 100644 index 0000000..fa2eb58 --- /dev/null +++ b/public/engines/cpp/cpp-regex.mjs @@ -0,0 +1,2 @@ +async function createCppRegexModule(moduleArg={}){var Module=moduleArg;var ENVIRONMENT_IS_WEB=!!globalThis.window;var ENVIRONMENT_IS_WORKER=!!globalThis.WorkerGlobalScope;var ENVIRONMENT_IS_NODE=globalThis.process?.versions?.node&&globalThis.process?.type!="renderer";if(ENVIRONMENT_IS_NODE){const{createRequire}=await import("node:module");var require=createRequire(import.meta.url)}var programArgs=[];var thisProgram="./this.program";var quit_=(status,toThrow)=>{throw toThrow};var _scriptName=import.meta.url;var scriptDirectory="";function locateFile(path){if(Module["locateFile"]){return Module["locateFile"](path,scriptDirectory)}return scriptDirectory+path}var readAsync,readBinary;if(ENVIRONMENT_IS_NODE){var fs=require("node:fs");if(_scriptName.startsWith("file:")){scriptDirectory=require("node:path").dirname(require("node:url").fileURLToPath(_scriptName))+"/"}readBinary=filename=>{filename=isFileURI(filename)?new URL(filename):filename;var ret=fs.readFileSync(filename);return ret};readAsync=async(filename,binary=true)=>{filename=isFileURI(filename)?new URL(filename):filename;var ret=fs.readFileSync(filename,binary?undefined:"utf8");return ret};if(process.argv.length>1){thisProgram=process.argv[1].replace(/\\/g,"/")}programArgs=process.argv.slice(2);quit_=(status,toThrow)=>{process.exitCode=status;throw toThrow}}else if(ENVIRONMENT_IS_WEB||ENVIRONMENT_IS_WORKER){try{scriptDirectory=new URL(".",_scriptName).href}catch{}{if(ENVIRONMENT_IS_WORKER){readBinary=url=>{var xhr=new XMLHttpRequest;xhr.open("GET",url,false);xhr.responseType="arraybuffer";xhr.send(null);return new Uint8Array(xhr.response)}}readAsync=async url=>{var response=await fetch(url,{credentials:"same-origin"});if(response.ok){return response.arrayBuffer()}throw new Error(response.status+" : "+response.url)}}}else{}var out=console.log.bind(console);var err=console.error.bind(console);var wasmBinary;var ABORT=false;var isFileURI=filename=>filename.startsWith("file://");class EmscriptenEH{}class EmscriptenSjLj extends EmscriptenEH{}class CppException extends EmscriptenEH{constructor(excPtr){super();this.excPtr=excPtr}}var runtimeInitialized=false;function getMemoryBuffer(){return wasmMemory.buffer}function updateMemoryViews(){if(HEAP8?.buffer?.resizable)return;var b=getMemoryBuffer();HEAP8=new Int8Array(b);HEAP16=new Int16Array(b);HEAPU8=new Uint8Array(b);HEAPU16=new Uint16Array(b);HEAP32=new Int32Array(b);HEAPU32=new Uint32Array(b);HEAPF32=new Float32Array(b);HEAPF64=new Float64Array(b);HEAP64=new BigInt64Array(b);HEAPU64=new BigUint64Array(b)}function preRun(){}function initRuntime(){runtimeInitialized=true;wasmExports["ea"]()}function postRun(){}function abort(what){what=`Aborted(${what})`;err(what);ABORT=true;what+=". Build with -sASSERTIONS for more info.";var e=new WebAssembly.RuntimeError(what);throw e}var wasmBinaryFile;function findWasmBinary(){if(Module["locateFile"]){return locateFile("cpp-regex.wasm")}return new URL("cpp-regex.wasm",import.meta.url).href}function getBinarySync(file){if(file==wasmBinaryFile&&wasmBinary){return new Uint8Array(wasmBinary)}if(readBinary){return readBinary(file)}throw"both async and sync fetching of the wasm failed"}async function getWasmBinary(binaryFile){if(!wasmBinary){try{var response=await readAsync(binaryFile);return new Uint8Array(response)}catch{}}return getBinarySync(binaryFile)}async function instantiateArrayBuffer(binaryFile,imports){try{var binary=await getWasmBinary(binaryFile);var instance=await WebAssembly.instantiate(binary,imports);return instance}catch(reason){err(`failed to asynchronously prepare wasm: ${reason}`);abort(reason)}}async function instantiateAsync(binary,binaryFile,imports){if(!binary&&!ENVIRONMENT_IS_NODE){try{var response=fetch(binaryFile,{credentials:"same-origin"});var instantiationResult=await WebAssembly.instantiateStreaming(response,imports);return instantiationResult}catch(reason){err(`wasm streaming compile failed: ${reason}`);err("falling back to ArrayBuffer instantiation")}}return instantiateArrayBuffer(binaryFile,imports)}function getWasmImports(){var imports={a:wasmImports};return imports}async function createWasm(){function receiveInstance(instance){wasmExports=instance.exports;assignWasmExports(wasmExports);updateMemoryViews();return wasmExports}function receiveInstantiationResult(result){return receiveInstance(result["instance"])}var info=getWasmImports();wasmBinaryFile??=findWasmBinary();var result=await instantiateAsync(wasmBinary,wasmBinaryFile,info);var exports=receiveInstantiationResult(result);return exports}class ExitStatus{name="ExitStatus";constructor(status){this.message=`Program terminated with exit(${status})`;this.status=status}}var HEAP8;var stackRestore=val=>__emscripten_stack_restore(val);var stackSave=()=>_emscripten_stack_get_current();var exceptionCaught=[];var uncaughtExceptionCount=0;var ___cxa_begin_catch=ptr=>{var info=new ExceptionInfo(ptr);if(!info.get_caught()){info.set_caught(true);uncaughtExceptionCount--}info.set_rethrown(false);exceptionCaught.push(info);return ___cxa_get_exception_ptr(ptr)};var exceptionLast=null;var ___cxa_end_catch=()=>{_setThrew(0,0);var info=exceptionCaught.pop();___cxa_decrement_exception_refcount(info.excPtr);exceptionLast=null};var HEAPU32;class ExceptionInfo{constructor(excPtr){this.excPtr=excPtr;this.ptr=excPtr-24}set_type(type){HEAPU32[this.ptr+4>>2]=type}get_type(){return HEAPU32[this.ptr+4>>2]}set_destructor(destructor){HEAPU32[this.ptr+8>>2]=destructor}get_destructor(){return HEAPU32[this.ptr+8>>2]}set_caught(caught){caught=caught?1:0;HEAP8[this.ptr+12]=caught}get_caught(){return HEAP8[this.ptr+12]!=0}set_rethrown(rethrown){rethrown=rethrown?1:0;HEAP8[this.ptr+13]=rethrown}get_rethrown(){return HEAP8[this.ptr+13]!=0}init(type,destructor){this.set_adjusted_ptr(0);this.set_type(type);this.set_destructor(destructor)}set_adjusted_ptr(adjustedPtr){HEAPU32[this.ptr+16>>2]=adjustedPtr}get_adjusted_ptr(){return HEAPU32[this.ptr+16>>2]}}var setTempRet0=val=>__emscripten_tempret_set(val);var findMatchingCatch=args=>{var thrown=exceptionLast?.excPtr;if(!thrown){setTempRet0(0);return 0}var info=new ExceptionInfo(thrown);info.set_adjusted_ptr(thrown);var thrownType=info.get_type();if(!thrownType){setTempRet0(0);return thrown}for(var caughtType of args){if(caughtType===0||caughtType===thrownType){break}var adjusted_ptr_addr=info.ptr+16;if(___cxa_can_catch(caughtType,thrownType,adjusted_ptr_addr)){setTempRet0(caughtType);return thrown}}setTempRet0(thrownType);return thrown};var ___cxa_find_matching_catch_2=()=>findMatchingCatch([]);var ___cxa_find_matching_catch_3=arg0=>findMatchingCatch([arg0]);var ___cxa_find_matching_catch_4=(arg0,arg1)=>findMatchingCatch([arg0,arg1]);var ___cxa_find_matching_catch_5=(arg0,arg1,arg2)=>findMatchingCatch([arg0,arg1,arg2]);var ___cxa_throw=(ptr,type,destructor)=>{var info=new ExceptionInfo(ptr);info.init(type,destructor);___cxa_increment_exception_refcount(ptr);exceptionLast=new CppException(ptr);uncaughtExceptionCount++;throw exceptionLast};var ___resumeException=ptr=>{if(!exceptionLast){exceptionLast=new CppException(ptr)}throw exceptionLast};var __abort_js=()=>abort("");var HEAPU8;var AsciiToString=ptr=>{var str="";while(1){var ch=HEAPU8[ptr++];if(!ch)return str;str+=String.fromCharCode(ch)}};var awaitingDependencies={};var registeredTypes={};var typeDependencies={};class BindingError extends Error{constructor(message){super(message);this.name="BindingError"}}var throwBindingError=message=>{throw new BindingError(message)};function sharedRegisterType(rawType,registeredInstance,options={}){var name=registeredInstance.name;if(!rawType){throwBindingError(`type "${name}" must have a positive integer typeid pointer`)}if(registeredTypes.hasOwnProperty(rawType)){if(options.ignoreDuplicateRegistrations){return}else{throwBindingError(`Cannot register type '${name}' twice`)}}registeredTypes[rawType]=registeredInstance;delete typeDependencies[rawType];if(awaitingDependencies.hasOwnProperty(rawType)){var callbacks=awaitingDependencies[rawType];delete awaitingDependencies[rawType];callbacks.forEach(cb=>cb())}}function registerType(rawType,registeredInstance,options={}){return sharedRegisterType(rawType,registeredInstance,options)}var HEAP16;var HEAPU16;var HEAP32;var HEAP64;var HEAPU64;var integerReadValueFromPointer=(name,width,signed)=>{switch(width){case 1:return signed?pointer=>HEAP8[pointer]:pointer=>HEAPU8[pointer];case 2:return signed?pointer=>HEAP16[pointer>>1]:pointer=>HEAPU16[pointer>>1];case 4:return signed?pointer=>HEAP32[pointer>>2]:pointer=>HEAPU32[pointer>>2];case 8:return signed?pointer=>HEAP64[pointer>>3]:pointer=>HEAPU64[pointer>>3];default:throw new TypeError(`invalid integer width (${width}): ${name}`)}};var __embind_register_bigint=(primitiveType,name,size,minRange,maxRange)=>{name=AsciiToString(name);const isUnsignedType=minRange===0n;let fromWireType=value=>value;if(isUnsignedType){const bitSize=size*8;fromWireType=value=>BigInt.asUintN(bitSize,value);maxRange=fromWireType(maxRange)}registerType(primitiveType,{name,fromWireType,toWireType:(destructors,value)=>{if(typeof value=="number"){value=BigInt(value)}return value},readValueFromPointer:integerReadValueFromPointer(name,size,!isUnsignedType),destructorFunction:null})};var __embind_register_bool=(rawType,name,trueValue,falseValue)=>{name=AsciiToString(name);registerType(rawType,{name,fromWireType:function(wt){return!!wt},toWireType:function(destructors,o){return o?trueValue:falseValue},readValueFromPointer:function(pointer){return this.fromWireType(HEAPU8[pointer])},destructorFunction:null})};var emval_freelist=[];var emval_handles=[0,1,,1,null,1,true,1,false,1];var emval_exception_decrefs=[];var __emval_decref=handle=>{if(handle>9&&0===--emval_handles[handle+1]){var value=emval_handles[handle];emval_handles[handle]=undefined;var destructor=emval_exception_decrefs[handle];if(destructor){emval_exception_decrefs[handle]=undefined;destructor(value)}emval_freelist.push(handle)}};var Emval={toValue:handle=>{if(!handle){throwBindingError(`Cannot use deleted val. handle = ${handle}`)}return emval_handles[handle]},toHandle:value=>{switch(value){case undefined:return 2;case null:return 4;case true:return 6;case false:return 8;default:{const handle=emval_freelist.pop()||emval_handles.length;emval_handles[handle]=value;emval_handles[handle+1]=1;return handle}}}};function readPointer(pointer){return this.fromWireType(HEAPU32[pointer>>2])}var EmValType={name:"emscripten::val",fromWireType:handle=>{var rv=Emval.toValue(handle);__emval_decref(handle);return rv},toWireType:(destructors,value)=>Emval.toHandle(value),readValueFromPointer:readPointer,destructorFunction:null};var __embind_register_emval=rawType=>registerType(rawType,EmValType);var HEAPF32;var HEAPF64;var floatReadValueFromPointer=(name,width)=>{switch(width){case 4:return function(pointer){return this.fromWireType(HEAPF32[pointer>>2])};case 8:return function(pointer){return this.fromWireType(HEAPF64[pointer>>3])};default:throw new TypeError(`invalid float width (${width}): ${name}`)}};var __embind_register_float=(rawType,name,size)=>{name=AsciiToString(name);registerType(rawType,{name,fromWireType:value=>value,toWireType:(destructors,value)=>value,readValueFromPointer:floatReadValueFromPointer(name,size),destructorFunction:null})};var createNamedFunction=(name,func)=>Object.defineProperty(func,"name",{value:name});var runDestructors=destructors=>{while(destructors.length){var ptr=destructors.pop();var del=destructors.pop();del(ptr)}};function usesDestructorStack(argTypes){for(var i=1;i{if(undefined===proto[methodName].overloadTable){var prevFunc=proto[methodName];proto[methodName]=function(...args){if(!proto[methodName].overloadTable.hasOwnProperty(args.length)){throwBindingError(`Function '${humanName}' called with an invalid number of arguments (${args.length}) - expects one of (${proto[methodName].overloadTable})!`)}return proto[methodName].overloadTable[args.length].apply(this,args)};proto[methodName].overloadTable=[];proto[methodName].overloadTable[prevFunc.argCount]=prevFunc}};var exposePublicSymbol=(name,value,numArguments)=>{if(Module.hasOwnProperty(name)){if(undefined===numArguments||undefined!==Module[name].overloadTable&&undefined!==Module[name].overloadTable[numArguments]){throwBindingError(`Cannot register public name '${name}' twice`)}ensureOverloadTable(Module,name,name);if(Module[name].overloadTable.hasOwnProperty(numArguments)){throwBindingError(`Cannot register multiple overloads of a function with the same number of arguments (${numArguments})!`)}Module[name].overloadTable[numArguments]=value}else{Module[name]=value;Module[name].argCount=numArguments}};var heap32VectorToArray=(count,firstElement)=>{var array=[];for(var i=0;i>2])}return array};class InternalError extends Error{constructor(message){super(message);this.name="InternalError"}}var throwInternalError=message=>{throw new InternalError(message)};var replacePublicSymbol=(name,value,numArguments)=>{if(!Module.hasOwnProperty(name)){throwInternalError("Replacing nonexistent public symbol")}if(undefined!==Module[name].overloadTable&&undefined!==numArguments){Module[name].overloadTable[numArguments]=value}else{Module[name]=value;Module[name].argCount=numArguments}};var wasmTableMirror=[];var getWasmTableEntry=funcPtr=>{var func=wasmTableMirror[funcPtr];if(!func){wasmTableMirror[funcPtr]=func=wasmTable.get(funcPtr)}return func};var embind__requireFunction=(signature,rawFunction,isAsync=false)=>{signature=AsciiToString(signature);function makeDynCaller(){var rtn=getWasmTableEntry(rawFunction);return rtn}var fp=makeDynCaller();if(typeof fp!="function"){throwBindingError(`unknown function pointer with signature ${signature}: ${rawFunction}`)}return fp};class UnboundTypeError extends Error{}var getTypeName=type=>{var ptr=___getTypeName(type);var rv=AsciiToString(ptr);_free(ptr);return rv};var throwUnboundTypeError=(message,types)=>{var unboundTypes=[];var seen={};function visit(type){if(seen[type]){return}if(registeredTypes[type]){return}if(typeDependencies[type]){typeDependencies[type].forEach(visit);return}unboundTypes.push(type);seen[type]=true}types.forEach(visit);throw new UnboundTypeError(`${message}: `+unboundTypes.map(getTypeName).join([", "]))};var whenDependentTypesAreResolved=(myTypes,dependentTypes,getTypeConverters)=>{myTypes.forEach(type=>typeDependencies[type]=dependentTypes);function onComplete(typeConverters){var myTypeConverters=getTypeConverters(typeConverters);if(myTypeConverters.length!==myTypes.length){throwInternalError("Mismatched type converter count")}for(var i=0;i{typeConverters[i]=registeredTypes[dt];++registered;if(registered===unregisteredTypes.length){onComplete(typeConverters)}})}}if(0===unregisteredTypes.length){onComplete(typeConverters)}};var getFunctionName=signature=>{signature=signature.trim();const argsIndex=signature.indexOf("(");if(argsIndex===-1)return signature;return signature.slice(0,argsIndex)};var __embind_register_function=(name,argCount,rawArgTypesAddr,signature,rawInvoker,fn,isAsync,isNonnullReturn)=>{var argTypes=heap32VectorToArray(argCount,rawArgTypesAddr);name=AsciiToString(name);name=getFunctionName(name);rawInvoker=embind__requireFunction(signature,rawInvoker,isAsync);exposePublicSymbol(name,function(){throwUnboundTypeError(`Cannot call ${name} due to unbound types`,argTypes)},argCount-1);whenDependentTypesAreResolved([],argTypes,argTypes=>{var invokerArgsArray=[argTypes[0],null].concat(argTypes.slice(1));replacePublicSymbol(name,craftInvokerFunction(name,invokerArgsArray,null,rawInvoker,fn,isAsync),argCount-1);return[]})};var __embind_register_integer=(primitiveType,name,size,minRange,maxRange)=>{name=AsciiToString(name);const isUnsignedType=minRange===0;let fromWireType=value=>value;if(isUnsignedType){var bitshift=32-8*size;fromWireType=value=>value<>>bitshift;maxRange=fromWireType(maxRange)}registerType(primitiveType,{name,fromWireType,toWireType:(destructors,value)=>value,readValueFromPointer:integerReadValueFromPointer(name,size,minRange!==0),destructorFunction:null})};var __embind_register_memory_view=(rawType,dataTypeIndex,name)=>{var typeMapping=[Int8Array,Uint8Array,Int16Array,Uint16Array,Int32Array,Uint32Array,Float32Array,Float64Array,BigInt64Array,BigUint64Array];var TA=typeMapping[dataTypeIndex];function decodeMemoryView(handle){var size=HEAPU32[handle>>2];var data=HEAPU32[handle+4>>2];return new TA(HEAP8.buffer,data,size)}name=AsciiToString(name);registerType(rawType,{name,fromWireType:decodeMemoryView,readValueFromPointer:decodeMemoryView},{ignoreDuplicateRegistrations:true})};var stringToUTF8Array=(str,heap,outIdx,maxBytesToWrite)=>{if(!(maxBytesToWrite>0))return 0;var startIdx=outIdx;var endIdx=outIdx+maxBytesToWrite-1;for(var i=0;i=endIdx)break;heap[outIdx++]=u}else if(u<=2047){if(outIdx+1>=endIdx)break;heap[outIdx++]=192|u>>6;heap[outIdx++]=128|u&63}else if(u<=65535){if(outIdx+2>=endIdx)break;heap[outIdx++]=224|u>>12;heap[outIdx++]=128|u>>6&63;heap[outIdx++]=128|u&63}else{if(outIdx+3>=endIdx)break;heap[outIdx++]=240|u>>18;heap[outIdx++]=128|u>>12&63;heap[outIdx++]=128|u>>6&63;heap[outIdx++]=128|u&63;i++}}heap[outIdx]=0;return outIdx-startIdx};var stringToUTF8=(str,outPtr,maxBytesToWrite)=>stringToUTF8Array(str,HEAPU8,outPtr,maxBytesToWrite);var lengthBytesUTF8=str=>{var len=0;for(var i=0;i=55296&&c<=57343){len+=4;++i}else{len+=3}}return len};var UTF8Decoder=globalThis.TextDecoder&&new TextDecoder;var findStringEnd=(heapOrArray,idx,maxBytesToRead,ignoreNul)=>{var maxIdx=idx+maxBytesToRead;if(ignoreNul)return maxIdx;while(heapOrArray[idx]&&!(idx>=maxIdx))++idx;return idx};var UTF8ArrayToString=(heapOrArray,idx=0,maxBytesToRead,ignoreNul)=>{var endPtr=findStringEnd(heapOrArray,idx,maxBytesToRead,ignoreNul);if(endPtr-idx>16&&heapOrArray.buffer&&UTF8Decoder){return UTF8Decoder.decode(heapOrArray.subarray(idx,endPtr))}var str="";while(idx>10,56320|ch&1023)}}return str};var UTF8ToString=(ptr,maxBytesToRead,ignoreNul)=>ptr?UTF8ArrayToString(HEAPU8,ptr,maxBytesToRead,ignoreNul):"";var __embind_register_std_string=(rawType,name)=>{name=AsciiToString(name);var stdStringIsUTF8=true;registerType(rawType,{name,fromWireType(value){var length=HEAPU32[value>>2];var payload=value+4;var str;if(stdStringIsUTF8){str=UTF8ToString(payload,length,true)}else{str="";for(var i=0;i>2]=length;if(valueIsOfTypeString){if(stdStringIsUTF8){stringToUTF8(value,ptr,length+1)}else{for(var i=0;i255){_free(base);throwBindingError("String has UTF-16 code units that do not fit in 8 bits")}HEAPU8[ptr+i]=charCode}}}else{HEAPU8.set(value,ptr)}if(destructors!==null){destructors.push(_free,base)}return base},readValueFromPointer:readPointer,destructorFunction(ptr){_free(ptr)}})};var UTF16Decoder=globalThis.TextDecoder?new TextDecoder("utf-16le"):undefined;var UTF16ToString=(ptr,maxBytesToRead,ignoreNul)=>{var idx=ptr>>1;var endIdx=findStringEnd(HEAPU16,idx,maxBytesToRead/2,ignoreNul);if(endIdx-idx>16&&UTF16Decoder)return UTF16Decoder.decode(HEAPU16.subarray(idx,endIdx));var str="";for(var i=idx;i{if(maxBytesToWrite<2)return 0;maxBytesToWrite-=2;var startPtr=outPtr;var numCharsToWrite=maxBytesToWrite>1]=codeUnit;outPtr+=2}HEAP16[outPtr>>1]=0;return outPtr-startPtr};var lengthBytesUTF16=str=>str.length*2;var UTF32ToString=(ptr,maxBytesToRead,ignoreNul)=>{var str="";var startIdx=ptr>>2;for(var i=0;!(i>=maxBytesToRead/4);i++){var utf32=HEAPU32[startIdx+i];if(!utf32&&!ignoreNul)break;str+=String.fromCodePoint(utf32)}return str};var stringToUTF32=(str,outPtr,maxBytesToWrite=2147483647)=>{if(maxBytesToWrite<4)return 0;var startPtr=outPtr;var endPtr=startPtr+maxBytesToWrite-4;for(var i=0;i65535){i++}HEAP32[outPtr>>2]=codePoint;outPtr+=4;if(outPtr+4>endPtr)break}HEAP32[outPtr>>2]=0;return outPtr-startPtr};var lengthBytesUTF32=str=>{var len=0;for(var i=0;i65535){i++}len+=4}return len};var __embind_register_std_wstring=(rawType,charSize,name)=>{name=AsciiToString(name);var decodeString,encodeString,lengthBytesUTF;if(charSize===2){decodeString=UTF16ToString;encodeString=stringToUTF16;lengthBytesUTF=lengthBytesUTF16}else{decodeString=UTF32ToString;encodeString=stringToUTF32;lengthBytesUTF=lengthBytesUTF32}registerType(rawType,{name,fromWireType:value=>{var length=HEAPU32[value>>2];var str=decodeString(value+4,length*charSize,true);_free(value);return str},toWireType:(destructors,value)=>{if(!(typeof value=="string")){throwBindingError(`Cannot pass non-string to C++ string type ${name}`)}var length=lengthBytesUTF(value);var ptr=_malloc(4+length+charSize);HEAPU32[ptr>>2]=length/charSize;encodeString(value,ptr+4,length+charSize);if(destructors!==null){destructors.push(_free,ptr)}return ptr},readValueFromPointer:readPointer,destructorFunction(ptr){_free(ptr)}})};var __embind_register_void=(rawType,name)=>{name=AsciiToString(name);registerType(rawType,{isVoid:true,name,fromWireType:()=>undefined,toWireType:(destructors,o)=>undefined})};var emval_methodCallers=[];var emval_addMethodCaller=caller=>{var id=emval_methodCallers.length;emval_methodCallers.push(caller);return id};var requireRegisteredType=(rawType,humanName)=>{var impl=registeredTypes[rawType];if(undefined===impl){throwBindingError(`${humanName} has unknown type ${getTypeName(rawType)}`)}return impl};var emval_lookupTypes=(argCount,argTypes)=>{var a=new Array(argCount);for(var i=0;i>2],`parameter ${i}`)}return a};var emval_returnValue=(toReturnWire,destructorsRef,handle)=>{var destructors=[];var result=toReturnWire(destructors,handle);if(destructors.length){HEAPU32[destructorsRef>>2]=Emval.toHandle(destructors)}return result};var emval_symbols={};var getStringOrSymbol=address=>{var symbol=emval_symbols[address];if(symbol===undefined){return AsciiToString(address)}return symbol};var __emval_create_invoker=(argCount,argTypesPtr,kind)=>{var GenericWireTypeSize=8;var[retType,...argTypes]=emval_lookupTypes(argCount,argTypesPtr);var toReturnWire=retType.toWireType.bind(retType);var argFromPtr=argTypes.map(type=>type.readValueFromPointer.bind(type));argCount--;var argN=new Array(argCount);var invokerFunction=(handle,methodName,destructorsRef,args)=>{var offset=0;for(var i=0;it.name)}) => ${retType.name}>`;return emval_addMethodCaller(createNamedFunction(functionName,invokerFunction))};var __emval_get_property=(handle,key)=>{handle=Emval.toValue(handle);key=Emval.toValue(key);return Emval.toHandle(handle[key])};var __emval_incref=handle=>{if(handle>9){emval_handles[handle+1]+=1}};var __emval_invoke=(caller,handle,methodName,destructorsRef,args)=>emval_methodCallers[caller](handle,methodName,destructorsRef,args);var __emval_new_array=()=>Emval.toHandle([]);var __emval_new_cstring=v=>Emval.toHandle(getStringOrSymbol(v));var __emval_new_object=()=>Emval.toHandle({});var __emval_run_destructors=handle=>{var destructors=Emval.toValue(handle);runDestructors(destructors);__emval_decref(handle)};var __emval_set_property=(handle,key,value)=>{handle=Emval.toValue(handle);key=Emval.toValue(key);value=Emval.toValue(value);handle[key]=value};var __tzset_js=(timezone,daylight,std_name,dst_name)=>{var currentYear=(new Date).getFullYear();var winter=new Date(currentYear,0,1);var summer=new Date(currentYear,6,1);var winterOffset=winter.getTimezoneOffset();var summerOffset=summer.getTimezoneOffset();var stdTimezoneOffset=Math.max(winterOffset,summerOffset);HEAPU32[timezone>>2]=stdTimezoneOffset*60;HEAP32[daylight>>2]=Number(winterOffset!=summerOffset);var extractZone=timezoneOffset=>{var sign=timezoneOffset>=0?"-":"+";var absOffset=Math.abs(timezoneOffset);var hours=String(Math.floor(absOffset/60)).padStart(2,"0");var minutes=String(absOffset%60).padStart(2,"0");return`UTC${sign}${hours}${minutes}`};var winterName=extractZone(winterOffset);var summerName=extractZone(summerOffset);if(summerOffset268435456;var alignMemory=(size,alignment)=>Math.ceil(size/alignment)*alignment;var growMemory=size=>{var oldHeapSize=wasmMemory.buffer.byteLength;var pages=(size-oldHeapSize+65535)/65536|0;try{wasmMemory.grow(pages);updateMemoryViews();return 1}catch(e){}};var _emscripten_resize_heap=requestedSize=>{var oldSize=HEAPU8.length;requestedSize>>>=0;var maxHeapSize=getHeapMax();if(requestedSize>maxHeapSize){return false}for(var cutDown=1;cutDown<=4;cutDown*=2){var overGrownHeapSize=oldSize*(1+.2/cutDown);overGrownHeapSize=Math.min(overGrownHeapSize,requestedSize+100663296);var newSize=Math.min(maxHeapSize,alignMemory(Math.max(requestedSize,overGrownHeapSize),65536));var replacement=growMemory(newSize);if(replacement){return true}}return false};var ENV={};var getExecutableName=()=>thisProgram;var getEnvStrings=()=>{if(!getEnvStrings.strings){var lang=(globalThis.navigator?.language??"C").replace("-","_")+".UTF-8";var env={USER:"web_user",LOGNAME:"web_user",PATH:"/",PWD:"/",HOME:"/home/web_user",LANG:lang,_:getExecutableName()};for(var x in ENV){if(ENV[x]===undefined)delete env[x];else env[x]=ENV[x]}var strings=[];for(var x in env){strings.push(`${x}=${env[x]}`)}getEnvStrings.strings=strings}return getEnvStrings.strings};var _environ_get=(__environ,environ_buf)=>{var bufSize=0;var envp=0;for(var string of getEnvStrings()){var ptr=environ_buf+bufSize;HEAPU32[__environ+envp>>2]=ptr;bufSize+=stringToUTF8(string,ptr,Infinity)+1;envp+=4}return 0};var _environ_sizes_get=(penviron_count,penviron_buf_size)=>{var strings=getEnvStrings();HEAPU32[penviron_count>>2]=strings.length;var bufSize=0;for(var string of strings){bufSize+=lengthBytesUTF8(string)+1}HEAPU32[penviron_buf_size>>2]=bufSize;return 0};var _llvm_eh_typeid_for=type=>type;{if(Module["print"])out=Module["print"];if(Module["printErr"])err=Module["printErr"];if(Module["wasmBinary"])wasmBinary=Module["wasmBinary"]}var _malloc,___getTypeName,_free,_setThrew,__emscripten_tempret_set,__emscripten_stack_restore,_emscripten_stack_get_current,___cxa_increment_exception_refcount,___cxa_decrement_exception_refcount,___cxa_can_catch,___cxa_get_exception_ptr,memory,__indirect_function_table,wasmMemory,wasmTable;function assignWasmExports(wasmExports){_malloc=wasmExports["ga"];___getTypeName=wasmExports["ha"];_free=wasmExports["ia"];_setThrew=wasmExports["ja"];__emscripten_tempret_set=wasmExports["ka"];__emscripten_stack_restore=wasmExports["la"];_emscripten_stack_get_current=wasmExports["ma"];___cxa_increment_exception_refcount=wasmExports["na"];___cxa_decrement_exception_refcount=wasmExports["oa"];___cxa_can_catch=wasmExports["pa"];___cxa_get_exception_ptr=wasmExports["qa"];memory=wasmMemory=wasmExports["da"];__indirect_function_table=wasmTable=wasmExports["fa"]}var wasmImports={F:___cxa_begin_catch,O:___cxa_end_catch,a:___cxa_find_matching_catch_2,n:___cxa_find_matching_catch_3,f:___cxa_find_matching_catch_4,u:___cxa_find_matching_catch_5,o:___cxa_throw,d:___resumeException,U:__abort_js,N:__embind_register_bigint,X:__embind_register_bool,V:__embind_register_emval,M:__embind_register_float,G:__embind_register_function,v:__embind_register_integer,p:__embind_register_memory_view,W:__embind_register_std_string,H:__embind_register_std_wstring,Y:__embind_register_void,A:__emval_create_invoker,aa:__emval_decref,ba:__emval_get_property,E:__emval_incref,z:__emval_invoke,$:__emval_new_array,y:__emval_new_cstring,I:__emval_new_object,_:__emval_run_destructors,Z:__emval_set_property,Q:__tzset_js,T:_emscripten_resize_heap,R:_environ_get,S:_environ_sizes_get,J:invoke_diii,t:invoke_diiiii,K:invoke_fiii,l:invoke_i,b:invoke_ii,c:invoke_iii,k:invoke_iiii,j:invoke_iiiii,r:invoke_iiiiii,q:invoke_iiiiiii,L:invoke_iiiiiiii,C:invoke_iiiiiiiiiiii,D:invoke_jiiii,i:invoke_v,g:invoke_vi,e:invoke_vii,h:invoke_viii,m:invoke_viiii,w:invoke_viiiii,s:invoke_viiiiiii,ca:invoke_viiiiiiii,x:invoke_viiiiiiiiii,B:invoke_viiiiiiiiiiiiiii,P:_llvm_eh_typeid_for};function invoke_viii(index,a1,a2,a3){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_vii(index,a1,a2){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiii(index,a1,a2,a3){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_ii(index,a1){var sp=stackSave();try{return getWasmTableEntry(index)(a1)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiiiii(index,a1,a2,a3,a4,a5){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4,a5)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiiii(index,a1,a2,a3,a4,a5){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4,a5)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_v(index){var sp=stackSave();try{getWasmTableEntry(index)()}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiiiiiii(index,a1,a2,a3,a4,a5,a6,a7,a8){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7,a8)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iii(index,a1,a2){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_vi(index,a1){var sp=stackSave();try{getWasmTableEntry(index)(a1)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiii(index,a1,a2,a3,a4){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiiii(index,a1,a2,a3,a4){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_i(index){var sp=stackSave();try{return getWasmTableEntry(index)()}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_diiiii(index,a1,a2,a3,a4,a5){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4,a5)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiiiiii(index,a1,a2,a3,a4,a5,a6){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiiiiiii(index,a1,a2,a3,a4,a5,a6,a7){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_jiiii(index,a1,a2,a3,a4){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0);return 0n}}function invoke_fiii(index,a1,a2,a3){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_diii(index,a1,a2,a3){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiiiiii(index,a1,a2,a3,a4,a5,a6,a7){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_iiiiiiiiiiii(index,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11){var sp=stackSave();try{return getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiiiiiiiii(index,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}function invoke_viiiiiiiiiiiiiii(index,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15){var sp=stackSave();try{getWasmTableEntry(index)(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15)}catch(e){stackRestore(sp);if(!(e instanceof EmscriptenEH))throw e;_setThrew(1,0)}}async function run(){preRun();if(ABORT)return;initRuntime();postRun()}var wasmExports;wasmExports=await createWasm();await run(); +;return Module}export default createCppRegexModule; diff --git a/public/engines/cpp/cpp-regex.wasm b/public/engines/cpp/cpp-regex.wasm new file mode 100644 index 0000000..c4c794d Binary files /dev/null and b/public/engines/cpp/cpp-regex.wasm differ diff --git a/public/engines/cpp/engine-metadata.json b/public/engines/cpp/engine-metadata.json new file mode 100644 index 0000000..3c0914a --- /dev/null +++ b/public/engines/cpp/engine-metadata.json @@ -0,0 +1,145 @@ +{ + "schemaVersion": 1, + "engine": "cpp", + "engineName": "C++ std::wregex (Emscripten libc++)", + "engineVersion": "Emscripten 6.0.4 libc++ std::wregex", + "semanticIdentity": "Emscripten 6.0.4 libc++ std::wregex; C++ modified ECMAScript grammar by default", + "status": "production-native-runtime", + "bridge": { + "abiVersion": 1, + "nativeOffsetUnit": "Unicode code points (32-bit wchar_t)", + "requestEncoding": "structured Embind values; no user source evaluation", + "dynamicExecutionDisabled": true, + "replacement": { + "semantics": "libc++ match_results::format default grammar", + "implementation": "bounded streaming expansion without materializing an unbounded native format result", + "paritySelfTest": "load-time fixtures compare the bounded expander with libc++ match_results::format" + }, + "supportedApplicationFlags": [ + "g", + "i", + "n", + "o", + "c" + ], + "grammars": [ + "ECMAScript", + "basic", + "extended", + "awk", + "grep", + "egrep" + ], + "limits": { + "maximumPatternUtf16": 65536, + "maximumSubjectBytes": 16777216, + "maximumReplacementUtf16": 65536, + "maximumMatches": 10000, + "maximumCaptureRows": 100000, + "maximumCaptureGroups": 1000, + "maximumOutputBytes": 67108864 + }, + "sourceFiles": [ + { + "path": "engines/cpp/README.md", + "sha256": "f8e47cd674ed78f2c36551e8f7d433de1ee06bb2845babab4926586dce011825", + "bytes": 1608 + }, + { + "path": "engines/cpp/cpp_regex_bridge.cpp", + "sha256": "8404d4b2efc7944f222b67ed03737f8e93923b9653db93b370b0e0a9ee589c64", + "bytes": 13763 + }, + { + "path": "scripts/cpp-engine-pack.mjs", + "sha256": "cd12f2bcba336a938338d7b2d5ab2b7bcf54b46dd678d1ee5523d71582484d41", + "bytes": 23040 + } + ] + }, + "source": { + "project": "Emscripten system runtime and LLVM libc++", + "repository": "https://github.com/emscripten-core/emscripten", + "tag": "6.0.4", + "commitSha1": "fe5be6afdff43ad58860d821fcc8572a23f92d19", + "preferredSourceUrl": "https://github.com/emscripten-core/emscripten/tree/fe5be6afdff43ad58860d821fcc8572a23f92d19", + "sourceManifest": "SOURCE-MANIFEST.json", + "license": "MIT OR NCSA AND MIT AND Apache-2.0 WITH LLVM-exception and legacy component terms" + }, + "toolchain": { + "version": "6.0.4", + "commitSha1": "fe5be6afdff43ad58860d821fcc8572a23f92d19", + "emsdkCommitSha1": "224ec5f9f2f72f09f9ce0e26d66bae7dbd8b692f", + "releaseCommitSha1": "b23272fac5d05617cd36dc451356dca0f79bf22d", + "llvmVersion": "24.0.0git", + "llvmCommitSha1": "c050c487e9edb97ef44f53cb29fe1d8bcddb8f76", + "target": "wasm32-unknown-emscripten", + "linkedArchives": [ + "libc++.a", + "libc++abi.a", + "libc.a", + "libclang_rt.builtins.a", + "libembind-rtti.a", + "libemmalloc.a", + "libnoexit.a", + "libstubs.a" + ], + "command": "em++ -std=c++20 -O3 -fexceptions --bind -sMODULARIZE=1 -sEXPORT_ES6=1 -sMALLOC=emmalloc -sDYNAMIC_EXECUTION=0 -Wl,--trace" + }, + "licensing": { + "sourceManifest": "SOURCE-MANIFEST.json", + "linkedComponentCount": 6, + "auditedExclusions": [ + "libunwind" + ], + "independentlyPinnedLegalFiles": 6 + }, + "sourceDateEpoch": 1785110400, + "files": [ + { + "path": "LICENSE-Emscripten.txt", + "sha256": "620a78084fc7ca97c0b5dea9abf891f3ffcadfdbf305276f099c9c4e12fc1d86", + "bytes": 5093 + }, + { + "path": "LICENSE-compiler-rt.txt", + "sha256": "1a8f1058753f1ba890de984e48f0242a3a5c29a6a8f2ed9fd813f36985387e8d", + "bytes": 16708 + }, + { + "path": "LICENSE-libcxx.txt", + "sha256": "539dd7aed86e8a4f12cbdd0e6c50c189c7d74847e4fecc64ce2c6ee3a01da38b", + "bytes": 16703 + }, + { + "path": "LICENSE-libcxxabi.txt", + "sha256": "e2b35be49f7284a45b7baca8fc7b3ab7440e7902392b2528a457816b5bb2a15c", + "bytes": 16706 + }, + { + "path": "LICENSE-libunwind.txt", + "sha256": "b5efebcaca80879234098e52d1725e6d9eb8fb96a19fce625d39184b705f7b6d", + "bytes": 16706 + }, + { + "path": "LICENSE-musl.txt", + "sha256": "b870108ec5e7790e9f9919064f1b9421d62d5f9b0e6c230c6adf7ea2da62e97b", + "bytes": 6196 + }, + { + "path": "SOURCE-MANIFEST.json", + "sha256": "8e45a797178ae85a0dcf9fd96c6b5a841cb50fd7f729ffc5342f7f838bf2bcd9", + "bytes": 7550 + }, + { + "path": "cpp-regex.mjs", + "sha256": "0d7662707b103af64f5b13302c8159178d3363c332030494cce7b2f9a4a8c0a7", + "bytes": 36448 + }, + { + "path": "cpp-regex.wasm", + "sha256": "231c0a37472f2ef7880377b044adadd31a852a0adf2e3cf023055b5dca74c460", + "bytes": 251481 + } + ] +} diff --git a/public/engines/dotnet/LICENSE-dotnet.txt b/public/engines/dotnet/LICENSE-dotnet.txt new file mode 100644 index 0000000..984713a --- /dev/null +++ b/public/engines/dotnet/LICENSE-dotnet.txt @@ -0,0 +1,23 @@ +The MIT License (MIT) + +Copyright (c) .NET Foundation and Contributors + +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/public/engines/dotnet/SHA256SUMS b/public/engines/dotnet/SHA256SUMS new file mode 100644 index 0000000..f9f1590 --- /dev/null +++ b/public/engines/dotnet/SHA256SUMS @@ -0,0 +1,19 @@ +cfc21f5e8bd655ae997eec916138b707b1d290b83272c02a95c9f821b8c87310 LICENSE-dotnet.txt +2dc8f8c5a39401e928b5784ab564eb8b3ceb99ead3df8f260e0cab7e0bbecc7a THIRD-PARTY-NOTICES.txt +8178d080bf8b139da2417184ad607664f0abb8bf5f7bc3acfdd19dac1c01be57 _framework/RegexTools.DotNet.nq07srqsrv.wasm +fc65ef6182d0633e5da7fb634f3c6bbc9cda00c04fb9318023a0d75c91fd0be6 _framework/System.Collections.035l5xddsu.wasm +e95181d82588827027195b7be3ba2a4df8b1580b0a1a98cf3e4275378f673984 _framework/System.IO.Pipelines.9846faqurl.wasm +08f8ff79ef495e642c1f000b7d9e2d8d651675f67cf3c3b974acc85bfba38ecc _framework/System.Linq.0mnik33gd9.wasm +8b52fd95bdaafddde9c041faaf908153ff3763712ebb8c274897df1e97bd8840 _framework/System.Memory.1p33wui4du.wasm +c813dfea69a9161b6e721c663b960193597fe148f48acbae57315cae7988681d _framework/System.Private.CoreLib.kprynbd0oq.wasm +18e7c4e1816cab053848fa468beedc191c5d57b7f8050e82e2d74541c9c05467 _framework/System.Runtime.8ovzk6bt8k.wasm +f03ceddaccb17a82e8e27e2ae71f7bcea8155c527f50569f94b52199ea11d451 _framework/System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm +4ba3b0e95e97a3897fc5dd4823dfb91de0497166f389cbfd1e1bdc9df548a8b3 _framework/System.Security.Cryptography.nx98zbj2m5.wasm +864de168a4ce82a9aa8deea10bf30f76d0de302a382b20f2fea69f324ff0eadb _framework/System.Text.Encodings.Web.efde74c33p.wasm +12c10b1368766432adc311b48a7970f67bc2cffc76f92336224a1f846673e146 _framework/System.Text.Json.yzatygskj6.wasm +caca9e11dc0df1917a8b14f213bf6c2c404faeddb43ab10551f1807d07c7fc43 _framework/System.Text.RegularExpressions.imqsl0y08u.wasm +647cf2841162fa23115ff9b0c55a4e370ab432912da48dd844a3d16e38c09a1a _framework/dotnet.js +224bc09dfc8b875fff993976d256f751b4f72ccd758e4a9144eab8c9d9f98ed1 _framework/dotnet.native.224bc09dfc8b.js +1603c30cea37bbfc154d37528b99ffd5fcf7ca833d07112bc239d7cee598bff7 _framework/dotnet.native.6k8j5v15h5.wasm +48e507110dc58430226c1491daef74356669a018cfb964661f40400135258495 _framework/dotnet.runtime.web2r9gqbh.js +8359eacd9d1aead6e3c3abef36e73b217233138600dbe1aff8880be48c32309f engine-metadata.json diff --git a/public/engines/dotnet/THIRD-PARTY-NOTICES.txt b/public/engines/dotnet/THIRD-PARTY-NOTICES.txt new file mode 100644 index 0000000..d4ec433 --- /dev/null +++ b/public/engines/dotnet/THIRD-PARTY-NOTICES.txt @@ -0,0 +1,1451 @@ +.NET Runtime uses third-party libraries or other resources that may be +distributed under licenses different than the .NET Runtime software. + +In the event that we accidentally failed to list a required notice, please +bring it to our attention. Post an issue or email us: + + dotnet@microsoft.com + +The attached notices are provided for information only. + +License notice for ASP.NET +------------------------------- + +Copyright (c) .NET Foundation. All rights reserved. +Licensed under the Apache License, Version 2.0. + +Available at +https://github.com/dotnet/aspnetcore/blob/main/LICENSE.txt + +License notice for Slicing-by-8 +------------------------------- + +http://sourceforge.net/projects/slicing-by-8/ + +Copyright (c) 2004-2006 Intel Corporation - All Rights Reserved + + +This software program is licensed subject to the BSD License, available at +http://www.opensource.org/licenses/bsd-license.html. + +License notice for Unicode data +------------------------------- + +https://www.unicode.org/license.html + +Copyright © 1991-2020 Unicode, Inc. All rights reserved. +Distributed under the Terms of Use in https://www.unicode.org/copyright.html. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of the Unicode data files and any associated documentation +(the "Data Files") or Unicode software and any associated documentation +(the "Software") to deal in the Data Files or Software +without restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, and/or sell copies of +the Data Files or Software, and to permit persons to whom the Data Files +or Software are furnished to do so, provided that either +(a) this copyright and permission notice appear with all copies +of the Data Files or Software, or +(b) this copyright and permission notice appear in associated +Documentation. + +THE DATA FILES AND SOFTWARE ARE PROVIDED "AS IS", WITHOUT WARRANTY OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT OF THIRD PARTY RIGHTS. +IN NO EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS +NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR CONSEQUENTIAL +DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, +DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THE DATA FILES OR SOFTWARE. + +Except as contained in this notice, the name of a copyright holder +shall not be used in advertising or otherwise to promote the sale, +use or other dealings in these Data Files or Software without prior +written authorization of the copyright holder. + +License notice for Mono +------------------------------- + +http://www.mono-project.com/docs/about-mono/ + +Copyright (c) .NET Foundation Contributors + +MIT License + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the Software), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for International Organization for Standardization +----------------------------------------------------------------- + +Portions (C) International Organization for Standardization 1986: + Permission to copy in any form is granted for use with + conforming SGML systems and applications as defined in + ISO 8879, provided this notice is included in all copies. + +License notice for Intel +------------------------ + +"Copyright (c) 2004-2006 Intel Corporation - All Rights Reserved + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for Xamarin and Novell +------------------------------------- + +Copyright (c) 2015 Xamarin, Inc (http://www.xamarin.com) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +Copyright (c) 2011 Novell, Inc (http://www.novell.com) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +Third party notice for W3C +-------------------------- + +"W3C SOFTWARE AND DOCUMENT NOTICE AND LICENSE +Status: This license takes effect 13 May, 2015. +This work is being provided by the copyright holders under the following license. +License +By obtaining and/or copying this work, you (the licensee) agree that you have read, understood, and will comply with the following terms and conditions. +Permission to copy, modify, and distribute this work, with or without modification, for any purpose and without fee or royalty is hereby granted, provided that you include the following on ALL copies of the work or portions thereof, including modifications: +The full text of this NOTICE in a location viewable to users of the redistributed or derivative work. +Any pre-existing intellectual property disclaimers, notices, or terms and conditions. If none exist, the W3C Software and Document Short Notice should be included. +Notice of any changes or modifications, through a copyright statement on the new code or document such as "This software or document includes material copied from or derived from [title and URI of the W3C document]. Copyright © [YEAR] W3C® (MIT, ERCIM, Keio, Beihang)." +Disclaimers +THIS WORK IS PROVIDED "AS IS," AND COPYRIGHT HOLDERS MAKE NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO, WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT THE USE OF THE SOFTWARE OR DOCUMENT WILL NOT INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER RIGHTS. +COPYRIGHT HOLDERS WILL NOT BE LIABLE FOR ANY DIRECT, INDIRECT, SPECIAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF ANY USE OF THE SOFTWARE OR DOCUMENT. +The name and trademarks of copyright holders may NOT be used in advertising or publicity pertaining to the work without specific, written prior permission. Title to copyright in this work will at all times remain with copyright holders." + +License notice for Bit Twiddling Hacks +-------------------------------------- + +Bit Twiddling Hacks + +By Sean Eron Anderson +seander@cs.stanford.edu + +Individually, the code snippets here are in the public domain (unless otherwise +noted) — feel free to use them however you please. The aggregate collection and +descriptions are © 1997-2005 Sean Eron Anderson. The code and descriptions are +distributed in the hope that they will be useful, but WITHOUT ANY WARRANTY and +without even the implied warranty of merchantability or fitness for a particular +purpose. + +License notice for Brotli +-------------------------------------- + +Copyright (c) 2009, 2010, 2013-2016 by the Brotli Authors. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +compress_fragment.c: +Copyright (c) 2011, Google Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. + * Neither the name of Google Inc. nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +""AS IS"" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +decode_fuzzer.c: +Copyright (c) 2015 The Chromium Authors. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. + * Neither the name of Google Inc. nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +""AS IS"" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + +License notice for Json.NET +------------------------------- + +https://github.com/JamesNK/Newtonsoft.Json/blob/master/LICENSE.md + +The MIT License (MIT) + +Copyright (c) 2007 James Newton-King + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for vectorized base64 encoding / decoding +-------------------------------------------------------- + +Copyright (c) 2005-2007, Nick Galbreath +Copyright (c) 2013-2017, Alfred Klomp +Copyright (c) 2015-2017, Wojciech Mula +Copyright (c) 2016-2017, Matthieu Darbois +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for RFC 3492 +--------------------------- + +The punycode implementation is based on the sample code in RFC 3492 + +Copyright (C) The Internet Society (2003). All Rights Reserved. + +This document and translations of it may be copied and furnished to +others, and derivative works that comment on or otherwise explain it +or assist in its implementation may be prepared, copied, published +and distributed, in whole or in part, without restriction of any +kind, provided that the above copyright notice and this paragraph are +included on all such copies and derivative works. However, this +document itself may not be modified in any way, such as by removing +the copyright notice or references to the Internet Society or other +Internet organizations, except as needed for the purpose of +developing Internet standards in which case the procedures for +copyrights defined in the Internet Standards process must be +followed, or as required to translate it into languages other than +English. + +The limited permissions granted above are perpetual and will not be +revoked by the Internet Society or its successors or assigns. + +This document and the information contained herein is provided on an +"AS IS" basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING +TASK FORCE DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING +BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE INFORMATION +HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF +MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. + +Copyright(C) The Internet Society 1997. All Rights Reserved. + +This document and translations of it may be copied and furnished to others, +and derivative works that comment on or otherwise explain it or assist in +its implementation may be prepared, copied, published and distributed, in +whole or in part, without restriction of any kind, provided that the above +copyright notice and this paragraph are included on all such copies and +derivative works.However, this document itself may not be modified in any +way, such as by removing the copyright notice or references to the Internet +Society or other Internet organizations, except as needed for the purpose of +developing Internet standards in which case the procedures for copyrights +defined in the Internet Standards process must be followed, or as required +to translate it into languages other than English. + +The limited permissions granted above are perpetual and will not be revoked +by the Internet Society or its successors or assigns. + +This document and the information contained herein is provided on an "AS IS" +basis and THE INTERNET SOCIETY AND THE INTERNET ENGINEERING TASK FORCE +DISCLAIMS ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO +ANY WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY +RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A +PARTICULAR PURPOSE. + +License notice for Algorithm from RFC 4122 - +A Universally Unique IDentifier (UUID) URN Namespace +---------------------------------------------------- + +Copyright (c) 1990- 1993, 1996 Open Software Foundation, Inc. +Copyright (c) 1989 by Hewlett-Packard Company, Palo Alto, Ca. & +Digital Equipment Corporation, Maynard, Mass. +Copyright (c) 1998 Microsoft. +To anyone who acknowledges that this file is provided "AS IS" +without any express or implied warranty: permission to use, copy, +modify, and distribute this file for any purpose is hereby +granted without fee, provided that the above copyright notices and +this notice appears in all source code copies, and that none of +the names of Open Software Foundation, Inc., Hewlett-Packard +Company, Microsoft, or Digital Equipment Corporation be used in +advertising or publicity pertaining to distribution of the software +without specific, written prior permission. Neither Open Software +Foundation, Inc., Hewlett-Packard Company, Microsoft, nor Digital +Equipment Corporation makes any representations about the +suitability of this software for any purpose." + +License notice for The LLVM Compiler Infrastructure +--------------------------------------------------- + +Developed by: + + LLVM Team + + University of Illinois at Urbana-Champaign + + http://llvm.org + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal with +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the + documentation and/or other materials provided with the distribution. + + * Neither the names of the LLVM Team, University of Illinois at + Urbana-Champaign, nor the names of its contributors may be used to + endorse or promote products derived from this Software without specific + prior written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE +SOFTWARE. + +License notice for Bob Jenkins +------------------------------ + +By Bob Jenkins, 1996. bob_jenkins@burtleburtle.net. You may use this +code any way you wish, private, educational, or commercial. It's free. + +License notice for Greg Parker +------------------------------ + +Greg Parker gparker@cs.stanford.edu December 2000 +This code is in the public domain and may be copied or modified without +permission. + +License notice for libunwind based code +---------------------------------------- + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for Printing Floating-Point Numbers (Dragon4) +------------------------------------------------------------ + +/****************************************************************************** + Copyright (c) 2014 Ryan Juckett + http://www.ryanjuckett.com/ + + This software is provided 'as-is', without any express or implied + warranty. In no event will the authors be held liable for any damages + arising from the use of this software. + + Permission is granted to anyone to use this software for any purpose, + including commercial applications, and to alter it and redistribute it + freely, subject to the following restrictions: + + 1. The origin of this software must not be misrepresented; you must not + claim that you wrote the original software. If you use this software + in a product, an acknowledgment in the product documentation would be + appreciated but is not required. + + 2. Altered source versions must be plainly marked as such, and must not be + misrepresented as being the original software. + + 3. This notice may not be removed or altered from any source + distribution. +******************************************************************************/ + +License notice for Printing Floating-point Numbers (Grisu3) +----------------------------------------------------------- + +Copyright 2012 the V8 project authors. All rights reserved. +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + * Neither the name of Google Inc. nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for xxHash +------------------------- + +xxHash Library +Copyright (c) 2012-2014, Yann Collet +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for Berkeley SoftFloat Release 3e +------------------------------------------------ + +https://github.com/ucb-bar/berkeley-softfloat-3 +https://github.com/ucb-bar/berkeley-softfloat-3/blob/master/COPYING.txt + +License for Berkeley SoftFloat Release 3e + +John R. Hauser +2018 January 20 + +The following applies to the whole of SoftFloat Release 3e as well as to +each source file individually. + +Copyright 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 The Regents of the +University of California. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions, and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions, and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS", AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, ARE +DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for xoshiro RNGs +-------------------------------- + +Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) + +To the extent possible under law, the author has dedicated all copyright +and related and neighboring rights to this software to the public domain +worldwide. This software is distributed without any warranty. + +See . + +License for fastmod (https://github.com/lemire/fastmod) +-------------------------------------- + + Copyright 2018 Daniel Lemire + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + +License notice for The C++ REST SDK +----------------------------------- + +C++ REST SDK + +The MIT License (MIT) + +Copyright (c) Microsoft Corporation + +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for MessagePack-CSharp +------------------------------------- + +MessagePack for C# + +MIT License + +Copyright (c) 2017 Yoshifumi Kawai + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for lz4net +------------------------------------- + +lz4net + +Copyright (c) 2013-2017, Milosz Krajewski + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +License notice for Nerdbank.Streams +----------------------------------- + +The MIT License (MIT) + +Copyright (c) Andrew Arnott + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for RapidJSON +---------------------------- + +Tencent is pleased to support the open source community by making RapidJSON available. + +Copyright (C) 2015 THL A29 Limited, a Tencent company, and Milo Yip. All rights reserved. + +Licensed under the MIT License (the "License"); you may not use this file except +in compliance with the License. You may obtain a copy of the License at + +http://opensource.org/licenses/MIT + +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. + +License notice for DirectX Math Library +--------------------------------------- + +https://github.com/microsoft/DirectXMath/blob/master/LICENSE + + The MIT License (MIT) + +Copyright (c) 2011-2020 Microsoft Corp + +Permission is hereby granted, free of charge, to any person obtaining a copy of this +software and associated documentation files (the "Software"), to deal in the Software +without restriction, including without limitation the rights to use, copy, modify, +merge, publish, distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be included in all copies +or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, +INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF +CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE +OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for ldap4net +--------------------------- + +The MIT License (MIT) + +Copyright (c) 2018 Alexander Chermyanin + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for vectorized sorting code +------------------------------------------ + +MIT License + +Copyright (c) 2020 Dan Shechter + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for musl +----------------------- + +musl as a whole is licensed under the following standard MIT license: + +Copyright © 2005-2020 Rich Felker, et al. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for "Faster Unsigned Division by Constants" +---------------------------------------------------------- + +Reference implementations of computing and using the "magic number" approach to dividing +by constants, including codegen instructions. The unsigned division incorporates the +"round down" optimization per ridiculous_fish. + +This is free and unencumbered software. Any copyright is dedicated to the Public Domain. + +License notice for mimalloc +--------------------------- + +MIT License + +Copyright (c) 2019 Microsoft Corporation, Daan Leijen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for Apple header files +------------------------------------- + +Copyright (c) 1980, 1986, 1993 + The Regents of the University of California. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. All advertising materials mentioning features or use of this software + must display the following acknowledgement: + This product includes software developed by the University of + California, Berkeley and its contributors. +4. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + +License notice for Angular v8.0 +-------------------------------- +The MIT License (MIT) +===================== + +Copyright (c) 2010-2019 Google LLC. http://angular.io/license + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +License notice for corefx + +License notice for BedrockFramework +=================================== + +MIT License + +Copyright (c) 2019 David Fowler + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for Swashbuckle +=================================== + +The MIT License (MIT) + +Copyright (c) 2016 Richard Morris + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for cli-spinners +============================================= + +MIT License + +Copyright (c) Sindre Sorhus (https://sindresorhus.com) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for dotnet-deb-tool +------------------------------------ + +The MIT License (MIT) + +Copyright (c) .NET Foundation and Contributors + +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License notice for IIS-Common +------------------------------------ + +MIT License + +Copyright (c) Microsoft Corporation. All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE + +License notice for IIS-Setup +------------------------------------ + +MIT License + +Copyright (c) Microsoft Corporation. All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE + +License notice for LZMA SDK +--------------------------- + +http://7-zip.org/sdk.html + +LZMA SDK is placed in the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or distribute the +original LZMA SDK code, either in source code form or as a compiled binary, +for any purpose, commercial or non-commercial, and by any means. + +License notice for MonoDevelop +------------------------------ + +Copyright (c) 2015 Xamarin, Inc (http://www.xamarin.com) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +Copyright (c) 2011 Novell, Inc (http://www.novell.com) + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +License notice for Nuget.Client +------------------------------- + +Copyright (c) .NET Foundation. All rights reserved. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use +these files except in compliance with the License. You may obtain a copy of the +License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. + +License notice for Ookie.Dialogs +-------------------------------- + +http://www.ookii.org/software/dialogs/ + +Copyright © Sven Groot (Ookii.org) 2009 +All rights reserved. + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1) Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. +2) Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. +3) Neither the name of the ORGANIZATION nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF +THE POSSIBILITY OF SUCH DAMAGE. + +License notice for viz.js +------------------------------------ + +Copyright (c) 2014-2018 Michael Daines + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for West Wind Live Reload ASP.NET Core Middleware +============================================= + + + +--- + +lz4net + +Copyright (c) 2013-2017, Milosz Krajewski + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MIT License +----------- + +Copyright (c) 2019-2020 West Wind Technologies + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +License for fastmod (https://github.com/lemire/fastmod) and ibm-fpgen (https://github.com/nigeltao/parse-number-fxx-test-data) +-------------------------------------- + + Copyright 2018 Daniel Lemire + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + +License notice for Angular v8.0 +-------------------------------------------- +The MIT License (MIT) +===================== + +Copyright (c) 2010-2019 Google LLC. http://angular.io/license + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +License notice for corefx + +License notice for JavaScript queues +------------------------------------- + +CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED HEREUNDER. + +Statement of Purpose +The laws of most jurisdictions throughout the world automatically confer exclusive Copyright and Related Rights (defined below) upon the creator and subsequent owner(s) (each and all, an "owner") of an original work of authorship and/or a database (each, a "Work"). +Certain owners wish to permanently relinquish those rights to a Work for the purpose of contributing to a commons of creative, cultural and scientific works ("Commons") that the public can reliably and without fear of later claims of infringement build upon, modify, incorporate in other works, reuse and redistribute as freely as possible in any form whatsoever and for any purposes, including without limitation commercial purposes. These owners may contribute to the Commons to promote the ideal of a free culture and the further production of creative, cultural and scientific works, or to gain reputation or greater distribution for their Work in part through the use and efforts of others. +For these and/or other purposes and motivations, and without any expectation of additional consideration or compensation, the person associating CC0 with a Work (the "Affirmer"), to the extent that he or she is an owner of Copyright and Related Rights in the Work, voluntarily elects to apply CC0 to the Work and publicly distribute the Work under its terms, with knowledge of his or her Copyright and Related Rights in the Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be protected by copyright and related or neighboring rights ("Copyright and Related Rights"). Copyright and Related Rights include, but are not limited to, the following: +the right to reproduce, adapt, distribute, perform, display, communicate, and translate a Work; +moral rights retained by the original author(s) and/or performer(s); +publicity and privacy rights pertaining to a person's image or likeness depicted in a Work; +rights protecting against unfair competition in regards to a Work, subject to the limitations in paragraph 4(a), below; +rights protecting the extraction, dissemination, use and reuse of data in a Work; +database rights (such as those arising under Directive 96/9/EC of the European Parliament and of the Council of 11 March 1996 on the legal protection of databases, and under any national implementation thereof, including any amended or successor version of such directive); and +other similar, equivalent or corresponding rights throughout the world based on applicable law or treaty, and any national implementations thereof. +2. Waiver. To the greatest extent permitted by, but not in contravention of, applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and unconditionally waives, abandons, and surrenders all of Affirmer's Copyright and Related Rights and associated claims and causes of action, whether now known or unknown (including existing as well as future claims and causes of action), in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each member of the public at large and to the detriment of Affirmer's heirs and successors, fully intending that such Waiver shall not be subject to revocation, rescission, cancellation, termination, or any other legal or equitable action to disrupt the quiet enjoyment of the Work by the public as contemplated by Affirmer's express Statement of Purpose. +3. Public License Fallback. Should any part of the Waiver for any reason be judged legally invalid or ineffective under applicable law, then the Waiver shall be preserved to the maximum extent permitted taking into account Affirmer's express Statement of Purpose. In addition, to the extent the Waiver is so judged Affirmer hereby grants to each affected person a royalty-free, non transferable, non sublicensable, non exclusive, irrevocable and unconditional license to exercise Affirmer's Copyright and Related Rights in the Work (i) in all territories worldwide, (ii) for the maximum duration provided by applicable law or treaty (including future time extensions), (iii) in any current or future medium and for any number of copies, and (iv) for any purpose whatsoever, including without limitation commercial, advertising or promotional purposes (the "License"). The License shall be deemed effective as of the date CC0 was applied by Affirmer to the Work. Should any part of the License for any reason be judged legally invalid or ineffective under applicable law, such partial invalidity or ineffectiveness shall not invalidate the remainder of the License, and in such case Affirmer hereby affirms that he or she will not (i) exercise any of his or her remaining Copyright and Related Rights in the Work or (ii) assert any associated claims and causes of action with respect to the Work, in either case contrary to Affirmer's express Statement of Purpose. +4. Limitations and Disclaimers. +a. No trademark or patent rights held by Affirmer are waived, abandoned, surrendered, licensed or otherwise affected by this document. +b. Affirmer offers the Work as-is and makes no representations or warranties of any kind concerning the Work, express, implied, statutory or otherwise, including without limitation warranties of title, merchantability, fitness for a particular purpose, non infringement, or the absence of latent or other defects, accuracy, or the present or absence of errors, whether or not discoverable, all to the greatest extent permissible under applicable law. +c. Affirmer disclaims responsibility for clearing rights of other persons that may apply to the Work or any use thereof, including without limitation any person's Copyright and Related Rights in the Work. Further, Affirmer disclaims responsibility for obtaining any necessary consents, permissions or other rights required for any use of the Work. +d. Affirmer understands and acknowledges that Creative Commons is not a party to this document and has no duty or obligation with respect to this CC0 or use of the Work. + +License notice for MSBuild Locator +------------------------------------- + +https://github.com/Microsoft/MSBuildLocator + +Copyright (c) 2018 .NET Foundation and Contributors + +This software is licensed subject to the MIT license, available at +https://opensource.org/licenses/MIT + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for Newtonsoft.Json +=================================== + +The MIT License (MIT) + +Copyright (c) 2007 James Newton-King + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +License notice for NuGet.Client +------------------------------- + +In reference to: https://github.com/dotnet/templating/blob/main/build/nuget.exe + +https://github.com/NuGet/NuGet.Client/blob/dev/LICENSE.txt + +Copyright (c) .NET Foundation. All rights reserved. + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use +these files except in compliance with the License. You may obtain a copy of the +License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed +under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR +CONDITIONS OF ANY KIND, either express or implied. See the License for the +specific language governing permissions and limitations under the License. + +License notice for Roslyn Clr Heap Allocation Analyzer +------------------------------------- + +https://github.com/Microsoft/RoslynClrHeapAllocationAnalyzer + +Copyright (c) 2018 Microsoft Corporation + +Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. + +License notice for StyleCop Analyzers +------------------------------------- + +The MIT License (MIT) + +Copyright (c) Tunnel Vision Laboratories, LLC + +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +------------------------------------------------ + +The MIT License (MIT) + +Copyright (c) .NET Foundation and Contributors + +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/public/engines/dotnet/_framework/RegexTools.DotNet.nq07srqsrv.wasm b/public/engines/dotnet/_framework/RegexTools.DotNet.nq07srqsrv.wasm new file mode 100644 index 0000000..d82dd08 Binary files /dev/null and b/public/engines/dotnet/_framework/RegexTools.DotNet.nq07srqsrv.wasm differ diff --git a/public/engines/dotnet/_framework/System.Collections.035l5xddsu.wasm b/public/engines/dotnet/_framework/System.Collections.035l5xddsu.wasm new file mode 100644 index 0000000..2416410 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Collections.035l5xddsu.wasm differ diff --git a/public/engines/dotnet/_framework/System.IO.Pipelines.9846faqurl.wasm b/public/engines/dotnet/_framework/System.IO.Pipelines.9846faqurl.wasm new file mode 100644 index 0000000..5329ef8 Binary files /dev/null and b/public/engines/dotnet/_framework/System.IO.Pipelines.9846faqurl.wasm differ diff --git a/public/engines/dotnet/_framework/System.Linq.0mnik33gd9.wasm b/public/engines/dotnet/_framework/System.Linq.0mnik33gd9.wasm new file mode 100644 index 0000000..200b108 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Linq.0mnik33gd9.wasm differ diff --git a/public/engines/dotnet/_framework/System.Memory.1p33wui4du.wasm b/public/engines/dotnet/_framework/System.Memory.1p33wui4du.wasm new file mode 100644 index 0000000..727d8ae Binary files /dev/null and b/public/engines/dotnet/_framework/System.Memory.1p33wui4du.wasm differ diff --git a/public/engines/dotnet/_framework/System.Private.CoreLib.kprynbd0oq.wasm b/public/engines/dotnet/_framework/System.Private.CoreLib.kprynbd0oq.wasm new file mode 100644 index 0000000..3f45fd2 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Private.CoreLib.kprynbd0oq.wasm differ diff --git a/public/engines/dotnet/_framework/System.Runtime.8ovzk6bt8k.wasm b/public/engines/dotnet/_framework/System.Runtime.8ovzk6bt8k.wasm new file mode 100644 index 0000000..3ec72b4 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Runtime.8ovzk6bt8k.wasm differ diff --git a/public/engines/dotnet/_framework/System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm b/public/engines/dotnet/_framework/System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm new file mode 100644 index 0000000..5a866b2 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm differ diff --git a/public/engines/dotnet/_framework/System.Security.Cryptography.nx98zbj2m5.wasm b/public/engines/dotnet/_framework/System.Security.Cryptography.nx98zbj2m5.wasm new file mode 100644 index 0000000..8be318c Binary files /dev/null and b/public/engines/dotnet/_framework/System.Security.Cryptography.nx98zbj2m5.wasm differ diff --git a/public/engines/dotnet/_framework/System.Text.Encodings.Web.efde74c33p.wasm b/public/engines/dotnet/_framework/System.Text.Encodings.Web.efde74c33p.wasm new file mode 100644 index 0000000..56570b4 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Text.Encodings.Web.efde74c33p.wasm differ diff --git a/public/engines/dotnet/_framework/System.Text.Json.yzatygskj6.wasm b/public/engines/dotnet/_framework/System.Text.Json.yzatygskj6.wasm new file mode 100644 index 0000000..a5587b2 Binary files /dev/null and b/public/engines/dotnet/_framework/System.Text.Json.yzatygskj6.wasm differ diff --git a/public/engines/dotnet/_framework/System.Text.RegularExpressions.imqsl0y08u.wasm b/public/engines/dotnet/_framework/System.Text.RegularExpressions.imqsl0y08u.wasm new file mode 100644 index 0000000..3433acc Binary files /dev/null and b/public/engines/dotnet/_framework/System.Text.RegularExpressions.imqsl0y08u.wasm differ diff --git a/public/engines/dotnet/_framework/dotnet.js b/public/engines/dotnet/_framework/dotnet.js new file mode 100644 index 0000000..fa93a1c --- /dev/null +++ b/public/engines/dotnet/_framework/dotnet.js @@ -0,0 +1,140 @@ +//! Licensed to the .NET Foundation under one or more agreements. +//! The .NET Foundation licenses this file to you under the MIT license. + +var e=!1;const t=async()=>WebAssembly.validate(new Uint8Array([0,97,115,109,1,0,0,0,1,4,1,96,0,0,3,2,1,0,10,8,1,6,0,6,64,25,11,11])),o=async()=>WebAssembly.validate(new Uint8Array([0,97,115,109,1,0,0,0,1,5,1,96,0,1,123,3,2,1,0,10,15,1,13,0,65,1,253,15,65,2,253,15,253,128,2,11])),n=async()=>WebAssembly.validate(new Uint8Array([0,97,115,109,1,0,0,0,1,5,1,96,0,1,123,3,2,1,0,10,10,1,8,0,65,0,253,15,253,98,11])),r=Symbol.for("wasm promise_control");function i(e,t){let o=null;const n=new Promise((function(n,r){o={isDone:!1,promise:null,resolve:t=>{o.isDone||(o.isDone=!0,n(t),e&&e())},reject:e=>{o.isDone||(o.isDone=!0,r(e),t&&t())}}}));o.promise=n;const i=n;return i[r]=o,{promise:i,promise_control:o}}function s(e){return e[r]}function a(e){e&&function(e){return void 0!==e[r]}(e)||Be(!1,"Promise is not controllable")}const l="__mono_message__",c=["debug","log","trace","warn","info","error"],d="MONO_WASM: ";let u,f,m,g,p,h;function w(e){g=e}function b(e){if(Pe.diagnosticTracing){const t="function"==typeof e?e():e;console.debug(d+t)}}function y(e,...t){console.info(d+e,...t)}function v(e,...t){console.info(e,...t)}function E(e,...t){console.warn(d+e,...t)}function _(e,...t){if(t&&t.length>0&&t[0]&&"object"==typeof t[0]){if(t[0].silent)return;if(t[0].toString)return void console.error(d+e,t[0].toString())}console.error(d+e,...t)}function x(e,t,o){return function(...n){try{let r=n[0];if(void 0===r)r="undefined";else if(null===r)r="null";else if("function"==typeof r)r=r.toString();else if("string"!=typeof r)try{r=JSON.stringify(r)}catch(e){r=r.toString()}t(o?JSON.stringify({method:e,payload:r,arguments:n.slice(1)}):[e+r,...n.slice(1)])}catch(e){m.error(`proxyConsole failed: ${e}`)}}}function j(e,t,o){f=t,g=e,m={...t};const n=`${o}/console`.replace("https://","wss://").replace("http://","ws://");u=new WebSocket(n),u.addEventListener("error",A),u.addEventListener("close",S),function(){for(const e of c)f[e]=x(`console.${e}`,T,!0)}()}function R(e){let t=30;const o=()=>{u?0==u.bufferedAmount||0==t?(e&&v(e),function(){for(const e of c)f[e]=x(`console.${e}`,m.log,!1)}(),u.removeEventListener("error",A),u.removeEventListener("close",S),u.close(1e3,e),u=void 0):(t--,globalThis.setTimeout(o,100)):e&&m&&m.log(e)};o()}function T(e){u&&u.readyState===WebSocket.OPEN?u.send(e):m.log(e)}function A(e){m.error(`[${g}] proxy console websocket error: ${e}`,e)}function S(e){m.debug(`[${g}] proxy console websocket closed: ${e}`,e)}function D(){Pe.preferredIcuAsset=O(Pe.config);let e="invariant"==Pe.config.globalizationMode;if(!e)if(Pe.preferredIcuAsset)Pe.diagnosticTracing&&b("ICU data archive(s) available, disabling invariant mode");else{if("custom"===Pe.config.globalizationMode||"all"===Pe.config.globalizationMode||"sharded"===Pe.config.globalizationMode){const e="invariant globalization mode is inactive and no ICU data archives are available";throw _(`ERROR: ${e}`),new Error(e)}Pe.diagnosticTracing&&b("ICU data archive(s) not available, using invariant globalization mode"),e=!0,Pe.preferredIcuAsset=null}const t="DOTNET_SYSTEM_GLOBALIZATION_INVARIANT",o=Pe.config.environmentVariables;if(void 0===o[t]&&e&&(o[t]="1"),void 0===o.TZ)try{const e=Intl.DateTimeFormat().resolvedOptions().timeZone||null;e&&(o.TZ=e)}catch(e){y("failed to detect timezone, will fallback to UTC")}}function O(e){var t;if((null===(t=e.resources)||void 0===t?void 0:t.icu)&&"invariant"!=e.globalizationMode){const t=e.applicationCulture||(ke?globalThis.navigator&&globalThis.navigator.languages&&globalThis.navigator.languages[0]:Intl.DateTimeFormat().resolvedOptions().locale),o=e.resources.icu;let n=null;if("custom"===e.globalizationMode){if(o.length>=1)return o[0].name}else t&&"all"!==e.globalizationMode?"sharded"===e.globalizationMode&&(n=function(e){const t=e.split("-")[0];return"en"===t||["fr","fr-FR","it","it-IT","de","de-DE","es","es-ES"].includes(e)?"icudt_EFIGS.dat":["zh","ko","ja"].includes(t)?"icudt_CJK.dat":"icudt_no_CJK.dat"}(t)):n="icudt.dat";if(n)for(let e=0;enull},url:e,arrayBuffer:()=>r,json:()=>JSON.parse(r),text:()=>{throw new Error("NotImplementedException")}}}if(o)return globalThis.fetch(e,t||{credentials:"same-origin"});if("function"==typeof read)return{ok:!0,url:e,headers:{length:0,get:()=>null},arrayBuffer:()=>new Uint8Array(read(e,"binary")),json:()=>JSON.parse(read(e,"utf8")),text:()=>read(e,"utf8")}}catch(t){return{ok:!1,url:e,status:500,headers:{length:0,get:()=>null},statusText:"ERR28: "+t,arrayBuffer:()=>{throw t},json:()=>{throw t},text:()=>{throw t}}}throw new Error("No fetch implementation available")}function I(e){return"string"!=typeof e&&Be(!1,"url must be a string"),!M(e)&&0!==e.indexOf("./")&&0!==e.indexOf("../")&&globalThis.URL&&globalThis.document&&globalThis.document.baseURI&&(e=new URL(e,globalThis.document.baseURI).toString()),e}const U=/^[a-zA-Z][a-zA-Z\d+\-.]*?:\/\//,P=/[a-zA-Z]:[\\/]/;function M(e){return Se||Ie?e.startsWith("/")||e.startsWith("\\")||-1!==e.indexOf("///")||P.test(e):U.test(e)}let L,N=0;const $=[],z=[],W=new Map,F={"js-module-threads":!0,"js-module-runtime":!0,"js-module-dotnet":!0,"js-module-native":!0,"js-module-diagnostics":!0},B={...F,"js-module-library-initializer":!0},V={...F,dotnetwasm:!0,heap:!0,manifest:!0},q={...B,manifest:!0},H={...B,dotnetwasm:!0},J={dotnetwasm:!0,symbols:!0},Z={...B,dotnetwasm:!0,symbols:!0},Q={symbols:!0};function G(e){return!("icu"==e.behavior&&e.name!=Pe.preferredIcuAsset)}function K(e,t,o){null!=t||(t=[]),Be(1==t.length,`Expect to have one ${o} asset in resources`);const n=t[0];return n.behavior=o,X(n),e.push(n),n}function X(e){V[e.behavior]&&W.set(e.behavior,e)}function Y(e){Be(V[e],`Unknown single asset behavior ${e}`);const t=W.get(e);if(t&&!t.resolvedUrl)if(t.resolvedUrl=Pe.locateFile(t.name),F[t.behavior]){const e=ge(t);e?("string"!=typeof e&&Be(!1,"loadBootResource response for 'dotnetjs' type should be a URL string"),t.resolvedUrl=e):t.resolvedUrl=ce(t.resolvedUrl,t.behavior)}else if("dotnetwasm"!==t.behavior)throw new Error(`Unknown single asset behavior ${e}`);return t}function ee(e){const t=Y(e);return Be(t,`Single asset for ${e} not found`),t}let te=!1;async function oe(){if(!te){te=!0,Pe.diagnosticTracing&&b("mono_download_assets");try{const e=[],t=[],o=(e,t)=>{!Z[e.behavior]&&G(e)&&Pe.expected_instantiated_assets_count++,!H[e.behavior]&&G(e)&&(Pe.expected_downloaded_assets_count++,t.push(se(e)))};for(const t of $)o(t,e);for(const e of z)o(e,t);Pe.allDownloadsQueued.promise_control.resolve(),Promise.all([...e,...t]).then((()=>{Pe.allDownloadsFinished.promise_control.resolve()})).catch((e=>{throw Pe.err("Error in mono_download_assets: "+e),Xe(1,e),e})),await Pe.runtimeModuleLoaded.promise;const n=async e=>{const t=await e;if(t.buffer){if(!Z[t.behavior]){t.buffer&&"object"==typeof t.buffer||Be(!1,"asset buffer must be array-like or buffer-like or promise of these"),"string"!=typeof t.resolvedUrl&&Be(!1,"resolvedUrl must be string");const e=t.resolvedUrl,o=await t.buffer,n=new Uint8Array(o);pe(t),await Ue.beforeOnRuntimeInitialized.promise,Ue.instantiate_asset(t,e,n)}}else J[t.behavior]?("symbols"===t.behavior&&(await Ue.instantiate_symbols_asset(t),pe(t)),J[t.behavior]&&++Pe.actual_downloaded_assets_count):(t.isOptional||Be(!1,"Expected asset to have the downloaded buffer"),!H[t.behavior]&&G(t)&&Pe.expected_downloaded_assets_count--,!Z[t.behavior]&&G(t)&&Pe.expected_instantiated_assets_count--)},r=[],i=[];for(const t of e)r.push(n(t));for(const e of t)i.push(n(e));Promise.all(r).then((()=>{Ce||Ue.coreAssetsInMemory.promise_control.resolve()})).catch((e=>{throw Pe.err("Error in mono_download_assets: "+e),Xe(1,e),e})),Promise.all(i).then((async()=>{Ce||(await Ue.coreAssetsInMemory.promise,Ue.allAssetsInMemory.promise_control.resolve())})).catch((e=>{throw Pe.err("Error in mono_download_assets: "+e),Xe(1,e),e}))}catch(e){throw Pe.err("Error in mono_download_assets: "+e),e}}}let ne=!1;function re(){if(ne)return;ne=!0;const e=Pe.config,t=[];if(e.assets)for(const t of e.assets)"object"!=typeof t&&Be(!1,`asset must be object, it was ${typeof t} : ${t}`),"string"!=typeof t.behavior&&Be(!1,"asset behavior must be known string"),"string"!=typeof t.name&&Be(!1,"asset name must be string"),t.resolvedUrl&&"string"!=typeof t.resolvedUrl&&Be(!1,"asset resolvedUrl could be string"),t.hash&&"string"!=typeof t.hash&&Be(!1,"asset resolvedUrl could be string"),t.pendingDownload&&"object"!=typeof t.pendingDownload&&Be(!1,"asset pendingDownload could be object"),t.isCore?$.push(t):z.push(t),X(t);else if(e.resources){const o=e.resources;o.wasmNative||Be(!1,"resources.wasmNative must be defined"),o.jsModuleNative||Be(!1,"resources.jsModuleNative must be defined"),o.jsModuleRuntime||Be(!1,"resources.jsModuleRuntime must be defined"),K(z,o.wasmNative,"dotnetwasm"),K(t,o.jsModuleNative,"js-module-native"),K(t,o.jsModuleRuntime,"js-module-runtime"),o.jsModuleDiagnostics&&K(t,o.jsModuleDiagnostics,"js-module-diagnostics");const n=(e,t,o)=>{const n=e;n.behavior=t,o?(n.isCore=!0,$.push(n)):z.push(n)};if(o.coreAssembly)for(let e=0;eglobalThis.setTimeout(e,100))),Pe.diagnosticTracing&&b(`Retrying download (2) '${e.name}' after delay`),await ae(e)}}}async function ae(e){for(;L;)await L.promise;try{++N,N==Pe.maxParallelDownloads&&(Pe.diagnosticTracing&&b("Throttling further parallel downloads"),L=i());const t=await async function(e){if(e.pendingDownload&&(e.pendingDownloadInternal=e.pendingDownload),e.pendingDownloadInternal&&e.pendingDownloadInternal.response)return e.pendingDownloadInternal.response;if(e.buffer){const t=await e.buffer;return e.resolvedUrl||(e.resolvedUrl="undefined://"+e.name),e.pendingDownloadInternal={url:e.resolvedUrl,name:e.name,response:Promise.resolve({ok:!0,arrayBuffer:()=>t,json:()=>JSON.parse(new TextDecoder("utf-8").decode(t)),text:()=>{throw new Error("NotImplementedException")},headers:{get:()=>{}}})},e.pendingDownloadInternal.response}const t=e.loadRemote&&Pe.config.remoteSources?Pe.config.remoteSources:[""];let o;for(let n of t){n=n.trim(),"./"===n&&(n="");const t=le(e,n);e.name===t?Pe.diagnosticTracing&&b(`Attempting to download '${t}'`):Pe.diagnosticTracing&&b(`Attempting to download '${t}' for ${e.name}`);try{e.resolvedUrl=t;const n=fe(e);if(e.pendingDownloadInternal=n,o=await n.response,!o||!o.ok)continue;return o}catch(e){o||(o={ok:!1,url:t,status:0,statusText:""+e});continue}}const n=e.isOptional||e.name.match(/\.pdb$/)&&Pe.config.ignorePdbLoadErrors;if(o||Be(!1,`Response undefined ${e.name}`),!n){const t=new Error(`download '${o.url}' for ${e.name} failed ${o.status} ${o.statusText}`);throw t.status=o.status,t}y(`optional download '${o.url}' for ${e.name} failed ${o.status} ${o.statusText}`)}(e);return t?(J[e.behavior]||(e.buffer=await t.arrayBuffer(),++Pe.actual_downloaded_assets_count),e):e}finally{if(--N,L&&N==Pe.maxParallelDownloads-1){Pe.diagnosticTracing&&b("Resuming more parallel downloads");const e=L;L=void 0,e.promise_control.resolve()}}}function le(e,t){let o;return null==t&&Be(!1,`sourcePrefix must be provided for ${e.name}`),e.resolvedUrl?o=e.resolvedUrl:(o=""===t?"assembly"===e.behavior||"pdb"===e.behavior?e.name:"resource"===e.behavior&&e.culture&&""!==e.culture?`${e.culture}/${e.name}`:e.name:t+e.name,o=ce(Pe.locateFile(o),e.behavior)),o&&"string"==typeof o||Be(!1,"attemptUrl need to be path or url string"),o}function ce(e,t){return Pe.modulesUniqueQuery&&q[t]&&(e+=Pe.modulesUniqueQuery),e}let de=0;const ue=new Set;function fe(e){try{e.resolvedUrl||Be(!1,"Request's resolvedUrl must be set");const t=function(e){let t=e.resolvedUrl;if(Pe.loadBootResource){const o=ge(e);if(o instanceof Promise)return o;"string"==typeof o&&(t=o)}const o={};return e.cache?o.cache=e.cache:Pe.config.disableNoCacheFetch||(o.cache="no-cache"),e.useCredentials?o.credentials="include":!Pe.config.disableIntegrityCheck&&e.hash&&(o.integrity=e.hash),Pe.fetch_like(t,o)}(e),o={name:e.name,url:e.resolvedUrl,response:t};return ue.add(e.name),o.response.then((()=>{"assembly"==e.behavior&&Pe.loadedAssemblies.push(e.name),de++,Pe.onDownloadResourceProgress&&Pe.onDownloadResourceProgress(de,ue.size)})),o}catch(t){const o={ok:!1,url:e.resolvedUrl,status:500,statusText:"ERR29: "+t,arrayBuffer:()=>{throw t},json:()=>{throw t}};return{name:e.name,url:e.resolvedUrl,response:Promise.resolve(o)}}}const me={resource:"assembly",assembly:"assembly",pdb:"pdb",icu:"globalization",vfs:"configuration",manifest:"manifest",dotnetwasm:"dotnetwasm","js-module-dotnet":"dotnetjs","js-module-native":"dotnetjs","js-module-runtime":"dotnetjs","js-module-threads":"dotnetjs"};function ge(e){var t;if(Pe.loadBootResource){const o=null!==(t=e.hash)&&void 0!==t?t:"",n=e.resolvedUrl,r=me[e.behavior];if(r){const t=Pe.loadBootResource(r,e.name,n,o,e.behavior);return"string"==typeof t?I(t):t}}}function pe(e){e.pendingDownloadInternal=null,e.pendingDownload=null,e.buffer=null,e.moduleExports=null}function he(e){let t=e.lastIndexOf("/");return t>=0&&t++,e.substring(t)}async function we(e){e&&await Promise.all((null!=e?e:[]).map((e=>async function(e){try{const t=e.name;if(!e.moduleExports){const o=ce(Pe.locateFile(t),"js-module-library-initializer");Pe.diagnosticTracing&&b(`Attempting to import '${o}' for ${e}`),e.moduleExports=await import(/*! webpackIgnore: true */o)}Pe.libraryInitializers.push({scriptName:t,exports:e.moduleExports})}catch(t){E(`Failed to import library initializer '${e}': ${t}`)}}(e))))}async function be(e,t){if(!Pe.libraryInitializers)return;const o=[];for(let n=0;nr.exports[e](...t))))}await Promise.all(o)}async function ye(e,t,o){try{await o()}catch(o){throw E(`Failed to invoke '${t}' on library initializer '${e}': ${o}`),Xe(1,o),o}}function ve(e,t){if(e===t)return e;const o={...t};return void 0!==o.assets&&o.assets!==e.assets&&(o.assets=[...e.assets||[],...o.assets||[]]),void 0!==o.resources&&(o.resources=_e(e.resources||{assembly:[],jsModuleNative:[],jsModuleRuntime:[],wasmNative:[]},o.resources)),void 0!==o.environmentVariables&&(o.environmentVariables={...e.environmentVariables||{},...o.environmentVariables||{}}),void 0!==o.runtimeOptions&&o.runtimeOptions!==e.runtimeOptions&&(o.runtimeOptions=[...e.runtimeOptions||[],...o.runtimeOptions||[]]),Object.assign(e,o)}function Ee(e,t){if(e===t)return e;const o={...t};return o.config&&(e.config||(e.config={}),o.config=ve(e.config,o.config)),Object.assign(e,o)}function _e(e,t){if(e===t)return e;const o={...t};return void 0!==o.coreAssembly&&(o.coreAssembly=[...e.coreAssembly||[],...o.coreAssembly||[]]),void 0!==o.assembly&&(o.assembly=[...e.assembly||[],...o.assembly||[]]),void 0!==o.lazyAssembly&&(o.lazyAssembly=[...e.lazyAssembly||[],...o.lazyAssembly||[]]),void 0!==o.corePdb&&(o.corePdb=[...e.corePdb||[],...o.corePdb||[]]),void 0!==o.pdb&&(o.pdb=[...e.pdb||[],...o.pdb||[]]),void 0!==o.jsModuleWorker&&(o.jsModuleWorker=[...e.jsModuleWorker||[],...o.jsModuleWorker||[]]),void 0!==o.jsModuleNative&&(o.jsModuleNative=[...e.jsModuleNative||[],...o.jsModuleNative||[]]),void 0!==o.jsModuleDiagnostics&&(o.jsModuleDiagnostics=[...e.jsModuleDiagnostics||[],...o.jsModuleDiagnostics||[]]),void 0!==o.jsModuleRuntime&&(o.jsModuleRuntime=[...e.jsModuleRuntime||[],...o.jsModuleRuntime||[]]),void 0!==o.wasmSymbols&&(o.wasmSymbols=[...e.wasmSymbols||[],...o.wasmSymbols||[]]),void 0!==o.wasmNative&&(o.wasmNative=[...e.wasmNative||[],...o.wasmNative||[]]),void 0!==o.icu&&(o.icu=[...e.icu||[],...o.icu||[]]),void 0!==o.satelliteResources&&(o.satelliteResources=function(e,t){if(e===t)return e;for(const o in t)e[o]=[...e[o]||[],...t[o]||[]];return e}(e.satelliteResources||{},o.satelliteResources||{})),void 0!==o.modulesAfterConfigLoaded&&(o.modulesAfterConfigLoaded=[...e.modulesAfterConfigLoaded||[],...o.modulesAfterConfigLoaded||[]]),void 0!==o.modulesAfterRuntimeReady&&(o.modulesAfterRuntimeReady=[...e.modulesAfterRuntimeReady||[],...o.modulesAfterRuntimeReady||[]]),void 0!==o.extensions&&(o.extensions={...e.extensions||{},...o.extensions||{}}),void 0!==o.vfs&&(o.vfs=[...e.vfs||[],...o.vfs||[]]),Object.assign(e,o)}function xe(){const e=Pe.config;if(e.environmentVariables=e.environmentVariables||{},e.runtimeOptions=e.runtimeOptions||[],e.resources=e.resources||{assembly:[],jsModuleNative:[],jsModuleWorker:[],jsModuleRuntime:[],wasmNative:[],vfs:[],satelliteResources:{}},e.assets){Pe.diagnosticTracing&&b("config.assets is deprecated, use config.resources instead");for(const t of e.assets){const o={};switch(t.behavior){case"assembly":o.assembly=[t];break;case"pdb":o.pdb=[t];break;case"resource":o.satelliteResources={},o.satelliteResources[t.culture]=[t];break;case"icu":o.icu=[t];break;case"symbols":o.wasmSymbols=[t];break;case"vfs":o.vfs=[t];break;case"dotnetwasm":o.wasmNative=[t];break;case"js-module-threads":o.jsModuleWorker=[t];break;case"js-module-runtime":o.jsModuleRuntime=[t];break;case"js-module-native":o.jsModuleNative=[t];break;case"js-module-diagnostics":o.jsModuleDiagnostics=[t];break;case"js-module-dotnet":break;default:throw new Error(`Unexpected behavior ${t.behavior} of asset ${t.name}`)}_e(e.resources,o)}}e.debugLevel,e.applicationEnvironment||(e.applicationEnvironment="Production"),e.applicationCulture&&(e.environmentVariables.LANG=`${e.applicationCulture}.UTF-8`),Ue.diagnosticTracing=Pe.diagnosticTracing=!!e.diagnosticTracing,Ue.waitForDebugger=e.waitForDebugger,Pe.maxParallelDownloads=e.maxParallelDownloads||Pe.maxParallelDownloads,Pe.enableDownloadRetry=void 0!==e.enableDownloadRetry?e.enableDownloadRetry:Pe.enableDownloadRetry}let je=!1;async function Re(e){var t;if(je)return void await Pe.afterConfigLoaded.promise;let o;try{if(e.configSrc||Pe.config&&0!==Object.keys(Pe.config).length&&(Pe.config.assets||Pe.config.resources)||(e.configSrc="dotnet.boot.js"),o=e.configSrc,je=!0,o&&(Pe.diagnosticTracing&&b("mono_wasm_load_config"),await async function(e){const t=e.configSrc,o=Pe.locateFile(t);let n=null;void 0!==Pe.loadBootResource&&(n=Pe.loadBootResource("manifest",t,o,"","manifest"));let r,i=null;if(n)if("string"==typeof n)n.includes(".json")?(i=await s(I(n)),r=await Ae(i)):r=(await import(I(n))).config;else{const e=await n;"function"==typeof e.json?(i=e,r=await Ae(i)):r=e.config}else o.includes(".json")?(i=await s(ce(o,"manifest")),r=await Ae(i)):r=(await import(ce(o,"manifest"))).config;function s(e){return Pe.fetch_like(e,{method:"GET",credentials:"include",cache:"no-cache"})}Pe.config.applicationEnvironment&&(r.applicationEnvironment=Pe.config.applicationEnvironment),ve(Pe.config,r)}(e)),xe(),await we(null===(t=Pe.config.resources)||void 0===t?void 0:t.modulesAfterConfigLoaded),await be("onRuntimeConfigLoaded",[Pe.config]),e.onConfigLoaded)try{await e.onConfigLoaded(Pe.config,Le),xe()}catch(e){throw _("onConfigLoaded() failed",e),e}xe(),Pe.afterConfigLoaded.promise_control.resolve(Pe.config)}catch(t){const n=`Failed to load config file ${o} ${t} ${null==t?void 0:t.stack}`;throw Pe.config=e.config=Object.assign(Pe.config,{message:n,error:t,isError:!0}),Xe(1,new Error(n)),t}}function Te(){return!!globalThis.navigator&&(Pe.isChromium||Pe.isFirefox)}async function Ae(e){const t=Pe.config,o=await e.json();t.applicationEnvironment||o.applicationEnvironment||(o.applicationEnvironment=e.headers.get("Blazor-Environment")||e.headers.get("DotNet-Environment")||void 0),o.environmentVariables||(o.environmentVariables={});const n=e.headers.get("DOTNET-MODIFIABLE-ASSEMBLIES");n&&(o.environmentVariables.DOTNET_MODIFIABLE_ASSEMBLIES=n);const r=e.headers.get("ASPNETCORE-BROWSER-TOOLS");return r&&(o.environmentVariables.__ASPNETCORE_BROWSER_TOOLS=r),o}"function"!=typeof importScripts||globalThis.onmessage||(globalThis.dotnetSidecar=!0);const Se="object"==typeof process&&"object"==typeof process.versions&&"string"==typeof process.versions.node,De="function"==typeof importScripts,Oe=De&&"undefined"!=typeof dotnetSidecar,Ce=De&&!Oe,ke="object"==typeof window||De&&!Se,Ie=!ke&&!Se;let Ue={},Pe={},Me={},Le={},Ne={},$e=!1;const ze={},We={config:ze},Fe={mono:{},binding:{},internal:Ne,module:We,loaderHelpers:Pe,runtimeHelpers:Ue,diagnosticHelpers:Me,api:Le};function Be(e,t){if(e)return;const o="Assert failed: "+("function"==typeof t?t():t),n=new Error(o);_(o,n),Ue.nativeAbort(n)}function Ve(){return void 0!==Pe.exitCode}function qe(){return Ue.runtimeReady&&!Ve()}function He(){Ve()&&Be(!1,`.NET runtime already exited with ${Pe.exitCode} ${Pe.exitReason}. You can use runtime.runMain() which doesn't exit the runtime.`),Ue.runtimeReady||Be(!1,".NET runtime didn't start yet. Please call dotnet.create() first.")}function Je(){ke&&(globalThis.addEventListener("unhandledrejection",et),globalThis.addEventListener("error",tt))}let Ze,Qe;function Ge(e){Qe&&Qe(e),Xe(e,Pe.exitReason)}function Ke(e){Ze&&Ze(e||Pe.exitReason),Xe(1,e||Pe.exitReason)}function Xe(t,o){var n,r;const i=o&&"object"==typeof o;t=i&&"number"==typeof o.status?o.status:void 0===t?-1:t;const s=i&&"string"==typeof o.message?o.message:""+o;(o=i?o:Ue.ExitStatus?function(e,t){const o=new Ue.ExitStatus(e);return o.message=t,o.toString=()=>t,o}(t,s):new Error("Exit with code "+t+" "+s)).status=t,o.message||(o.message=s);const a=""+(o.stack||(new Error).stack);try{Object.defineProperty(o,"stack",{get:()=>a})}catch(e){}const l=!!o.silent;if(o.silent=!0,Ve())Pe.diagnosticTracing&&b("mono_exit called after exit");else{try{We.onAbort==Ke&&(We.onAbort=Ze),We.onExit==Ge&&(We.onExit=Qe),ke&&(globalThis.removeEventListener("unhandledrejection",et),globalThis.removeEventListener("error",tt)),Ue.runtimeReady?(Ue.jiterpreter_dump_stats&&Ue.jiterpreter_dump_stats(!1),0===t&&(null===(n=Pe.config)||void 0===n?void 0:n.interopCleanupOnExit)&&Ue.forceDisposeProxies(!0,!0),e&&0!==t&&(null===(r=Pe.config)||void 0===r||r.dumpThreadsOnNonZeroExit)):(Pe.diagnosticTracing&&b(`abort_startup, reason: ${o}`),function(e){Pe.allDownloadsQueued.promise_control.reject(e),Pe.allDownloadsFinished.promise_control.reject(e),Pe.afterConfigLoaded.promise_control.reject(e),Pe.wasmCompilePromise.promise_control.reject(e),Pe.runtimeModuleLoaded.promise_control.reject(e),Ue.dotnetReady&&(Ue.dotnetReady.promise_control.reject(e),Ue.afterInstantiateWasm.promise_control.reject(e),Ue.beforePreInit.promise_control.reject(e),Ue.afterPreInit.promise_control.reject(e),Ue.afterPreRun.promise_control.reject(e),Ue.beforeOnRuntimeInitialized.promise_control.reject(e),Ue.afterOnRuntimeInitialized.promise_control.reject(e),Ue.afterPostRun.promise_control.reject(e))}(o))}catch(e){E("mono_exit A failed",e)}try{l||(function(e,t){if(0!==e&&t){const e=Ue.ExitStatus&&t instanceof Ue.ExitStatus?b:_;"string"==typeof t?e(t):(void 0===t.stack&&(t.stack=(new Error).stack+""),t.message?e(Ue.stringify_as_error_with_stack?Ue.stringify_as_error_with_stack(t.message+"\n"+t.stack):t.message+"\n"+t.stack):e(JSON.stringify(t)))}!Ce&&Pe.config&&(Pe.config.logExitCode?Pe.config.forwardConsoleLogsToWS?R("WASM EXIT "+e):v("WASM EXIT "+e):Pe.config.forwardConsoleLogsToWS&&R())}(t,o),function(e){if(ke&&!Ce&&Pe.config&&Pe.config.appendElementOnExit&&document){const t=document.createElement("label");t.id="tests_done",0!==e&&(t.style.background="red"),t.innerHTML=""+e,document.body.appendChild(t)}}(t))}catch(e){E("mono_exit B failed",e)}Pe.exitCode=t,Pe.exitReason||(Pe.exitReason=o),!Ce&&Ue.runtimeReady&&We.runtimeKeepalivePop()}if(Pe.config&&Pe.config.asyncFlushOnExit&&0===t)throw(async()=>{try{await async function(){try{const e=await import(/*! webpackIgnore: true */"process"),t=e=>new Promise(((t,o)=>{e.on("error",o),e.end("","utf8",t)})),o=t(e.stderr),n=t(e.stdout);let r;const i=new Promise((e=>{r=setTimeout((()=>e("timeout")),1e3)}));await Promise.race([Promise.all([n,o]),i]),clearTimeout(r)}catch(e){_(`flushing std* streams failed: ${e}`)}}()}finally{Ye(t,o)}})(),o;Ye(t,o)}function Ye(e,t){if(Ue.runtimeReady&&Ue.nativeExit)try{Ue.nativeExit(e)}catch(e){!Ue.ExitStatus||e instanceof Ue.ExitStatus||E("set_exit_code_and_quit_now failed: "+e.toString())}if(0!==e||!ke)throw Se&&Ne.process?Ne.process.exit(e):Ue.quit&&Ue.quit(e,t),t}function et(e){ot(e,e.reason,"rejection")}function tt(e){ot(e,e.error,"error")}function ot(e,t,o){e.preventDefault();try{t||(t=new Error("Unhandled "+o)),void 0===t.stack&&(t.stack=(new Error).stack),t.stack=t.stack+"",t.silent||(_("Unhandled error:",t),Xe(1,t))}catch(e){}}!function(e){if($e)throw new Error("Loader module already loaded");$e=!0,Ue=e.runtimeHelpers,Pe=e.loaderHelpers,Me=e.diagnosticHelpers,Le=e.api,Ne=e.internal,Object.assign(Le,{INTERNAL:Ne,invokeLibraryInitializers:be}),Object.assign(e.module,{config:ve(ze,{environmentVariables:{}})});const r={mono_wasm_bindings_is_ready:!1,config:e.module.config,diagnosticTracing:!1,nativeAbort:e=>{throw e||new Error("abort")},nativeExit:e=>{throw new Error("exit:"+e)}},l={gitHash:"f7d90799ce4ef09a0bb257852a57248d2a8fb8dd",config:e.module.config,diagnosticTracing:!1,maxParallelDownloads:16,enableDownloadRetry:!0,_loaded_files:[],loadedFiles:[],loadedAssemblies:[],libraryInitializers:[],workerNextNumber:1,actual_downloaded_assets_count:0,actual_instantiated_assets_count:0,expected_downloaded_assets_count:0,expected_instantiated_assets_count:0,afterConfigLoaded:i(),allDownloadsQueued:i(),allDownloadsFinished:i(),wasmCompilePromise:i(),runtimeModuleLoaded:i(),loadingWorkers:i(),is_exited:Ve,is_runtime_running:qe,assert_runtime_running:He,mono_exit:Xe,createPromiseController:i,getPromiseController:s,assertIsControllablePromise:a,mono_download_assets:oe,resolve_single_asset_path:ee,setup_proxy_console:j,set_thread_prefix:w,installUnhandledErrorHandler:Je,retrieve_asset_download:ie,invokeLibraryInitializers:be,isDebuggingSupported:Te,exceptions:t,simd:n,relaxedSimd:o};Object.assign(Ue,r),Object.assign(Pe,l)}(Fe);let nt,rt,it,st=!1,at=!1;async function lt(e){if(!at){if(at=!0,ke&&Pe.config.forwardConsoleLogsToWS&&void 0!==globalThis.WebSocket&&j("main",globalThis.console,globalThis.location.origin),We||Be(!1,"Null moduleConfig"),Pe.config||Be(!1,"Null moduleConfig.config"),"function"==typeof e){const t=e(Fe.api);if(t.ready)throw new Error("Module.ready couldn't be redefined.");Object.assign(We,t),Ee(We,t)}else{if("object"!=typeof e)throw new Error("Can't use moduleFactory callback of createDotnetRuntime function.");Ee(We,e)}await async function(e){if(Se){const e=await import(/*! webpackIgnore: true */"process"),t=14;if(e.versions.node.split(".")[0]0&&(Pe.modulesUniqueQuery=t.substring(o)),Pe.scriptUrl=t.replace(/\\/g,"/").replace(/[?#].*/,""),Pe.scriptDirectory=(n=Pe.scriptUrl).slice(0,n.lastIndexOf("/"))+"/",Pe.locateFile=e=>"URL"in globalThis&&globalThis.URL!==C?new URL(e,Pe.scriptDirectory).toString():M(e)?e:Pe.scriptDirectory+e,Pe.fetch_like=k,Pe.out=console.log,Pe.err=console.error,Pe.onDownloadResourceProgress=e.onDownloadResourceProgress,ke&&globalThis.navigator){const e=globalThis.navigator,t=e.userAgentData&&e.userAgentData.brands;t&&t.length>0?Pe.isChromium=t.some((e=>"Google Chrome"===e.brand||"Microsoft Edge"===e.brand||"Chromium"===e.brand)):e.userAgent&&(Pe.isChromium=e.userAgent.includes("Chrome"),Pe.isFirefox=e.userAgent.includes("Firefox"))}Ne.require=Se?await import(/*! webpackIgnore: true */"module").then((e=>e.createRequire(/*! webpackIgnore: true */import.meta.url))):Promise.resolve((()=>{throw new Error("require not supported")})),void 0===globalThis.URL&&(globalThis.URL=C)}(We)}}async function ct(e){return await lt(e),Ze=We.onAbort,Qe=We.onExit,We.onAbort=Ke,We.onExit=Ge,We.ENVIRONMENT_IS_PTHREAD?async function(){(function(){const e=new MessageChannel,t=e.port1,o=e.port2;t.addEventListener("message",(e=>{var n,r;n=JSON.parse(e.data.config),r=JSON.parse(e.data.monoThreadInfo),st?Pe.diagnosticTracing&&b("mono config already received"):(ve(Pe.config,n),Ue.monoThreadInfo=r,xe(),Pe.diagnosticTracing&&b("mono config received"),st=!0,Pe.afterConfigLoaded.promise_control.resolve(Pe.config),ke&&n.forwardConsoleLogsToWS&&void 0!==globalThis.WebSocket&&Pe.setup_proxy_console("worker-idle",console,globalThis.location.origin)),t.close(),o.close()}),{once:!0}),t.start(),self.postMessage({[l]:{monoCmd:"preload",port:o}},[o])})(),await Pe.afterConfigLoaded.promise,function(){const e=Pe.config;e.assets||Be(!1,"config.assets must be defined");for(const t of e.assets)X(t),Q[t.behavior]&&z.push(t)}(),setTimeout((async()=>{try{await oe()}catch(e){Xe(1,e)}}),0);const e=dt(),t=await Promise.all(e);return await ut(t),We}():async function(){var e;await Re(We),re();const t=dt();(async function(){try{const e=ee("dotnetwasm");await se(e),e&&e.pendingDownloadInternal&&e.pendingDownloadInternal.response||Be(!1,"Can't load dotnet.native.wasm");const t=await e.pendingDownloadInternal.response,o=t.headers&&t.headers.get?t.headers.get("Content-Type"):void 0;let n;if("function"==typeof WebAssembly.compileStreaming&&"application/wasm"===o)n=await WebAssembly.compileStreaming(t);else{ke&&"application/wasm"!==o&&E('WebAssembly resource does not have the expected content type "application/wasm", so falling back to slower ArrayBuffer instantiation.');const e=await t.arrayBuffer();Pe.diagnosticTracing&&b("instantiate_wasm_module buffered"),n=Ie?await Promise.resolve(new WebAssembly.Module(e)):await WebAssembly.compile(e)}e.pendingDownloadInternal=null,e.pendingDownload=null,e.buffer=null,e.moduleExports=null,Pe.wasmCompilePromise.promise_control.resolve(n)}catch(e){Pe.wasmCompilePromise.promise_control.reject(e)}})(),setTimeout((async()=>{try{D(),await oe()}catch(e){Xe(1,e)}}),0);const o=await Promise.all(t);return await ut(o),await Ue.dotnetReady.promise,await we(null===(e=Pe.config.resources)||void 0===e?void 0:e.modulesAfterRuntimeReady),await be("onRuntimeReady",[Fe.api]),Le}()}function dt(){const e=ee("js-module-runtime"),t=ee("js-module-native");if(nt&&rt)return[nt,rt,it];"object"==typeof e.moduleExports?nt=e.moduleExports:(Pe.diagnosticTracing&&b(`Attempting to import '${e.resolvedUrl}' for ${e.name}`),nt=import(/*! webpackIgnore: true */e.resolvedUrl)),"object"==typeof t.moduleExports?rt=t.moduleExports:(Pe.diagnosticTracing&&b(`Attempting to import '${t.resolvedUrl}' for ${t.name}`),rt=import(/*! webpackIgnore: true */t.resolvedUrl));const o=Y("js-module-diagnostics");return o&&("object"==typeof o.moduleExports?it=o.moduleExports:(Pe.diagnosticTracing&&b(`Attempting to import '${o.resolvedUrl}' for ${o.name}`),it=import(/*! webpackIgnore: true */o.resolvedUrl))),[nt,rt,it]}async function ut(e){const{initializeExports:t,initializeReplacements:o,configureRuntimeStartup:n,configureEmscriptenStartup:r,configureWorkerStartup:i,setRuntimeGlobals:s,passEmscriptenInternals:a}=e[0],{default:l}=e[1],c=e[2];s(Fe),t(Fe),c&&c.setRuntimeGlobals(Fe),await n(We),Pe.runtimeModuleLoaded.promise_control.resolve(),l((e=>(Object.assign(We,{ready:e.ready,__dotnet_runtime:{initializeReplacements:o,configureEmscriptenStartup:r,configureWorkerStartup:i,passEmscriptenInternals:a}}),We))).catch((e=>{if(e.message&&e.message.toLowerCase().includes("out of memory"))throw new Error(".NET runtime has failed to start, because too much memory was requested. Please decrease the memory by adjusting EmccMaximumHeapSize. See also https://aka.ms/dotnet-wasm-features");throw e}))}const ft=new class{withModuleConfig(e){try{return Ee(We,e),this}catch(e){throw Xe(1,e),e}}withOnConfigLoaded(e){try{return Ee(We,{onConfigLoaded:e}),this}catch(e){throw Xe(1,e),e}}withConsoleForwarding(){try{return ve(ze,{forwardConsoleLogsToWS:!0}),this}catch(e){throw Xe(1,e),e}}withExitOnUnhandledError(){try{return ve(ze,{exitOnUnhandledError:!0}),Je(),this}catch(e){throw Xe(1,e),e}}withAsyncFlushOnExit(){try{return ve(ze,{asyncFlushOnExit:!0}),this}catch(e){throw Xe(1,e),e}}withExitCodeLogging(){try{return ve(ze,{logExitCode:!0}),this}catch(e){throw Xe(1,e),e}}withElementOnExit(){try{return ve(ze,{appendElementOnExit:!0}),this}catch(e){throw Xe(1,e),e}}withInteropCleanupOnExit(){try{return ve(ze,{interopCleanupOnExit:!0}),this}catch(e){throw Xe(1,e),e}}withDumpThreadsOnNonZeroExit(){try{return ve(ze,{dumpThreadsOnNonZeroExit:!0}),this}catch(e){throw Xe(1,e),e}}withWaitingForDebugger(e){try{return ve(ze,{waitForDebugger:e}),this}catch(e){throw Xe(1,e),e}}withInterpreterPgo(e,t){try{return ve(ze,{interpreterPgo:e,interpreterPgoSaveDelay:t}),ze.runtimeOptions?ze.runtimeOptions.push("--interp-pgo-recording"):ze.runtimeOptions=["--interp-pgo-recording"],this}catch(e){throw Xe(1,e),e}}withConfig(e){try{return ve(ze,e),this}catch(e){throw Xe(1,e),e}}withConfigSrc(e){try{return e&&"string"==typeof e||Be(!1,"must be file path or URL"),Ee(We,{configSrc:e}),this}catch(e){throw Xe(1,e),e}}withVirtualWorkingDirectory(e){try{return e&&"string"==typeof e||Be(!1,"must be directory path"),ve(ze,{virtualWorkingDirectory:e}),this}catch(e){throw Xe(1,e),e}}withEnvironmentVariable(e,t){try{const o={};return o[e]=t,ve(ze,{environmentVariables:o}),this}catch(e){throw Xe(1,e),e}}withEnvironmentVariables(e){try{return e&&"object"==typeof e||Be(!1,"must be dictionary object"),ve(ze,{environmentVariables:e}),this}catch(e){throw Xe(1,e),e}}withDiagnosticTracing(e){try{return"boolean"!=typeof e&&Be(!1,"must be boolean"),ve(ze,{diagnosticTracing:e}),this}catch(e){throw Xe(1,e),e}}withDebugging(e){try{return null!=e&&"number"==typeof e||Be(!1,"must be number"),ve(ze,{debugLevel:e}),this}catch(e){throw Xe(1,e),e}}withApplicationArguments(...e){try{return e&&Array.isArray(e)||Be(!1,"must be array of strings"),ve(ze,{applicationArguments:e}),this}catch(e){throw Xe(1,e),e}}withRuntimeOptions(e){try{return e&&Array.isArray(e)||Be(!1,"must be array of strings"),ze.runtimeOptions?ze.runtimeOptions.push(...e):ze.runtimeOptions=e,this}catch(e){throw Xe(1,e),e}}withMainAssembly(e){try{return ve(ze,{mainAssemblyName:e}),this}catch(e){throw Xe(1,e),e}}withApplicationArgumentsFromQuery(){try{if(!globalThis.window)throw new Error("Missing window to the query parameters from");if(void 0===globalThis.URLSearchParams)throw new Error("URLSearchParams is supported");const e=new URLSearchParams(globalThis.window.location.search).getAll("arg");return this.withApplicationArguments(...e)}catch(e){throw Xe(1,e),e}}withApplicationEnvironment(e){try{return ve(ze,{applicationEnvironment:e}),this}catch(e){throw Xe(1,e),e}}withApplicationCulture(e){try{return ve(ze,{applicationCulture:e}),this}catch(e){throw Xe(1,e),e}}withResourceLoader(e){try{return Pe.loadBootResource=e,this}catch(e){throw Xe(1,e),e}}async download(){try{await async function(){lt(We),await Re(We),re(),D(),oe(),await Pe.allDownloadsFinished.promise}()}catch(e){throw Xe(1,e),e}}async create(){try{return this.instance||(this.instance=await async function(){return await ct(We),Fe.api}()),this.instance}catch(e){throw Xe(1,e),e}}async run(){try{return We.config||Be(!1,"Null moduleConfig.config"),this.instance||await this.create(),this.instance.runMainAndExit()}catch(e){throw Xe(1,e),e}}},mt=Xe,gt=ct;Ie||"function"==typeof globalThis.URL||Be(!1,"This browser/engine doesn't support URL API. Please use a modern version. See also https://aka.ms/dotnet-wasm-features"),"function"!=typeof globalThis.BigInt64Array&&Be(!1,"This browser/engine doesn't support BigInt64Array API. Please use a modern version. See also https://aka.ms/dotnet-wasm-features"),ft.withConfig(/*json-start*/{ + "mainAssemblyName": "RegexTools.DotNet", + "resources": { + "hash": "sha256-0dKGLGjxCtg+vMV/O8q+VZkHxNocu4J/oL6IgS0TtrM=", + "jsModuleNative": [ + { + "name": "dotnet.native.224bc09dfc8b.js" + } + ], + "jsModuleRuntime": [ + { + "name": "dotnet.runtime.web2r9gqbh.js" + } + ], + "wasmNative": [ + { + "name": "dotnet.native.6k8j5v15h5.wasm", + "hash": "sha256-FgPDDOo3u/wVTTdSi5n/1fz3yoM9BxErwjnXzuWYv/c=", + "cache": "force-cache" + } + ], + "coreAssembly": [ + { + "virtualPath": "System.Runtime.InteropServices.JavaScript.wasm", + "name": "System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm", + "hash": "sha256-8Dzt2syxeoLo4n4q5x97zqgVXFJ/UFaflLUhmeoR1FE=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Private.CoreLib.wasm", + "name": "System.Private.CoreLib.kprynbd0oq.wasm", + "hash": "sha256-yBPf6mmpFhtuchxmO5YBk1l/4Uj0isuuVzFcrnmIaB0=", + "cache": "force-cache" + } + ], + "assembly": [ + { + "virtualPath": "System.Collections.wasm", + "name": "System.Collections.035l5xddsu.wasm", + "hash": "sha256-/GXvYYLQYz5dp/tjTzxrvJzaAMBPuTGAI6DXXJH9C+Y=", + "cache": "force-cache" + }, + { + "virtualPath": "System.IO.Pipelines.wasm", + "name": "System.IO.Pipelines.9846faqurl.wasm", + "hash": "sha256-6VGB2CWIgnAnGVt747oqTfixWAsKGpjPPkJ1N49nOYQ=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Linq.wasm", + "name": "System.Linq.0mnik33gd9.wasm", + "hash": "sha256-CPj/ee9JXmQsHwALfZ4tjWUWdfZ888O5dKzIW/ujjsw=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Memory.wasm", + "name": "System.Memory.1p33wui4du.wasm", + "hash": "sha256-i1L9lb2q/d3pwEH6r5CBU/83Y3Euu4wnSJffHpe9iEA=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Runtime.wasm", + "name": "System.Runtime.8ovzk6bt8k.wasm", + "hash": "sha256-GOfE4YFsqwU4SPpGi+7cGRxdV7f4BQ6C4tdFQcnAVGc=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Security.Cryptography.wasm", + "name": "System.Security.Cryptography.nx98zbj2m5.wasm", + "hash": "sha256-S6Ow6V6Xo4l/xd1II9+5HeBJcWbzicv9HhvcnfVIqLM=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Text.Encodings.Web.wasm", + "name": "System.Text.Encodings.Web.efde74c33p.wasm", + "hash": "sha256-hk3haKTOgqmqje6hC/MPdtDeMCo4KyDy/qafMk/w6ts=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Text.Json.wasm", + "name": "System.Text.Json.yzatygskj6.wasm", + "hash": "sha256-EsELE2h2ZDKtwxG0inlw9nvCz/x2+SM2IkofhGZz4UY=", + "cache": "force-cache" + }, + { + "virtualPath": "System.Text.RegularExpressions.wasm", + "name": "System.Text.RegularExpressions.imqsl0y08u.wasm", + "hash": "sha256-ysqeEdwN8ZF6ixTyE79sLEBPrt20OrEFUfGAfQfH/EM=", + "cache": "force-cache" + }, + { + "virtualPath": "RegexTools.DotNet.wasm", + "name": "RegexTools.DotNet.nq07srqsrv.wasm", + "hash": "sha256-gXjQgL+LE52iQXGErWB2ZPCruL9fe8Os/dGdrBwBvlc=", + "cache": "force-cache" + } + ] + }, + "debugLevel": 0, + "linkerEnabled": true, + "globalizationMode": "invariant", + "runtimeConfig": { + "runtimeOptions": { + "configProperties": { + "Microsoft.Extensions.DependencyInjection.VerifyOpenGenericServiceTrimmability": true, + "System.ComponentModel.DefaultValueAttribute.IsSupported": false, + "System.ComponentModel.Design.IDesignerHost.IsSupported": false, + "System.ComponentModel.TypeConverter.EnableUnsafeBinaryFormatterInDesigntimeLicenseContextSerialization": false, + "System.ComponentModel.TypeDescriptor.IsComObjectDescriptorSupported": false, + "System.Data.DataSet.XmlSerializationIsSupported": false, + "System.Diagnostics.Debugger.IsSupported": false, + "System.Diagnostics.Metrics.Meter.IsSupported": false, + "System.Diagnostics.Tracing.EventSource.IsSupported": false, + "System.Globalization.Invariant": true, + "System.TimeZoneInfo.Invariant": false, + "System.Globalization.PredefinedCulturesOnly": true, + "System.Linq.Enumerable.IsSizeOptimized": true, + "System.Net.Http.EnableActivityPropagation": false, + "System.Net.Http.WasmEnableStreamingResponse": true, + "System.Net.SocketsHttpHandler.Http3Support": false, + "System.Reflection.Metadata.MetadataUpdater.IsSupported": false, + "System.Resources.ResourceManager.AllowCustomResourceTypes": false, + "System.Resources.UseSystemResourceKeys": true, + "System.Runtime.CompilerServices.RuntimeFeature.IsDynamicCodeSupported": true, + "System.Runtime.InteropServices.BuiltInComInterop.IsSupported": false, + "System.Runtime.InteropServices.EnableConsumingManagedCodeFromNativeHosting": false, + "System.Runtime.InteropServices.EnableCppCLIHostActivation": false, + "System.Runtime.InteropServices.Marshalling.EnableGeneratedComInterfaceComImportInterop": false, + "System.Runtime.Serialization.EnableUnsafeBinaryFormatterSerialization": false, + "System.StartupHookProvider.IsSupported": false, + "System.Text.Encoding.EnableUnsafeUTF7Encoding": false, + "System.Text.Json.JsonSerializer.IsReflectionEnabledByDefault": false, + "System.Threading.Thread.EnableAutoreleasePool": false + } + } + } +}/*json-end*/);export{gt as default,ft as dotnet,mt as exit}; diff --git a/public/engines/dotnet/_framework/dotnet.native.224bc09dfc8b.js b/public/engines/dotnet/_framework/dotnet.native.224bc09dfc8b.js new file mode 100644 index 0000000..828b40c --- /dev/null +++ b/public/engines/dotnet/_framework/dotnet.native.224bc09dfc8b.js @@ -0,0 +1,5485 @@ + +var createDotnetRuntime = (() => { + var _scriptDir = import.meta.url; + + return ( +async function(moduleArg = {}) { + +// include: shell.js +// The Module object: Our interface to the outside world. We import +// and export values on it. There are various ways Module can be used: +// 1. Not defined. We create it here +// 2. A function parameter, function(Module) { ..generated code.. } +// 3. pre-run appended it, var Module = {}; ..generated code.. +// 4. External script tag defines var Module. +// We need to check if Module already exists (e.g. case 3 above). +// Substitution will be replaced with actual code on later stage of the build, +// this way Closure Compiler will not mangle it (e.g. case 4. above). +// Note that if you want to run closure, and also to use Module +// after the generated code, you will need to define var Module = {}; +// before the code. Then that object will be used in the code, and you +// can continue to use Module afterwards as well. +var Module = moduleArg; + +// Set up the promise that indicates the Module is initialized +var readyPromiseResolve, readyPromiseReject; +Module['ready'] = new Promise((resolve, reject) => { + readyPromiseResolve = resolve; + readyPromiseReject = reject; +}); + +// --pre-jses are emitted after the Module integration code, so that they can +// refer to Module (if they choose; they can also define Module) +// include: dotnet-sdk-10.0.302/packs/Microsoft.NETCore.App.Runtime.Mono.browser-wasm/10.0.10/runtimes/browser-wasm/native/src/es6/dotnet.es6.pre.js +if (_nativeModuleLoaded) throw new Error("Native module already loaded"); +_nativeModuleLoaded = true; +createDotnetRuntime = Module = moduleArg(Module); +// end include: dotnet-sdk-10.0.302/packs/Microsoft.NETCore.App.Runtime.Mono.browser-wasm/10.0.10/runtimes/browser-wasm/native/src/es6/dotnet.es6.pre.js + + +// Sometimes an existing Module object exists with properties +// meant to overwrite the default module functionality. Here +// we collect those properties and reapply _after_ we configure +// the current environment's defaults to avoid having to be so +// defensive during initialization. +var moduleOverrides = Object.assign({}, Module); + +var arguments_ = []; +var thisProgram = './this.program'; +var quit_ = (status, toThrow) => { + throw toThrow; +}; + +// Determine the runtime environment we are in. You can customize this by +// setting the ENVIRONMENT setting at compile time (see settings.js). + +// Attempt to auto-detect the environment +var ENVIRONMENT_IS_WEB = typeof window == 'object'; +var ENVIRONMENT_IS_WORKER = typeof importScripts == 'function'; +// N.b. Electron.js environment is simultaneously a NODE-environment, but +// also a web environment. +var ENVIRONMENT_IS_NODE = typeof process == 'object' && typeof process.versions == 'object' && typeof process.versions.node == 'string'; +var ENVIRONMENT_IS_SHELL = !ENVIRONMENT_IS_WEB && !ENVIRONMENT_IS_NODE && !ENVIRONMENT_IS_WORKER; + +// `/` should be present at the end if `scriptDirectory` is not empty +var scriptDirectory = ''; +function locateFile(path) { + if (Module['locateFile']) { + return Module['locateFile'](path, scriptDirectory); + } + return scriptDirectory + path; +} + +// Hooks that are implemented differently in different runtime environments. +var read_, + readAsync, + readBinary; + +if (ENVIRONMENT_IS_NODE) { + + // `require()` is no-op in an ESM module, use `createRequire()` to construct + // the require()` function. This is only necessary for multi-environment + // builds, `-sENVIRONMENT=node` emits a static import declaration instead. + // TODO: Swap all `require()`'s with `import()`'s? + const { createRequire } = await import('module'); + /** @suppress{duplicate} */ + var require = createRequire(import.meta.url); + // These modules will usually be used on Node.js. Load them eagerly to avoid + // the complexity of lazy-loading. + var fs = require('fs'); + var nodePath = require('path'); + + if (ENVIRONMENT_IS_WORKER) { + scriptDirectory = nodePath.dirname(scriptDirectory) + '/'; + } else { + // EXPORT_ES6 + ENVIRONMENT_IS_NODE always requires use of import.meta.url, + // since there's no way getting the current absolute path of the module when + // support for that is not available. + scriptDirectory = require('url').fileURLToPath(new URL('./', import.meta.url)); // includes trailing slash + } + +// include: node_shell_read.js +read_ = (filename, binary) => { + // We need to re-wrap `file://` strings to URLs. Normalizing isn't + // necessary in that case, the path should already be absolute. + filename = isFileURI(filename) ? new URL(filename) : nodePath.normalize(filename); + return fs.readFileSync(filename, binary ? undefined : 'utf8'); +}; + +readBinary = (filename) => { + var ret = read_(filename, true); + if (!ret.buffer) { + ret = new Uint8Array(ret); + } + return ret; +}; + +readAsync = (filename, onload, onerror, binary = true) => { + // See the comment in the `read_` function. + filename = isFileURI(filename) ? new URL(filename) : nodePath.normalize(filename); + fs.readFile(filename, binary ? undefined : 'utf8', (err, data) => { + if (err) onerror(err); + else onload(binary ? data.buffer : data); + }); +}; +// end include: node_shell_read.js + if (!Module['thisProgram'] && process.argv.length > 1) { + thisProgram = process.argv[1].replace(/\\/g, '/'); + } + + arguments_ = process.argv.slice(2); + + // MODULARIZE will export the module in the proper place outside, we don't need to export here + + quit_ = (status, toThrow) => { + process.exitCode = status; + throw toThrow; + }; + +} else +if (ENVIRONMENT_IS_SHELL) { + + if (typeof read != 'undefined') { + read_ = read; + } + + readBinary = (f) => { + if (typeof readbuffer == 'function') { + return new Uint8Array(readbuffer(f)); + } + let data = read(f, 'binary'); + assert(typeof data == 'object'); + return data; + }; + + readAsync = (f, onload, onerror) => { + setTimeout(() => onload(readBinary(f))); + }; + + if (typeof clearTimeout == 'undefined') { + globalThis.clearTimeout = (id) => {}; + } + + if (typeof setTimeout == 'undefined') { + // spidermonkey lacks setTimeout but we use it above in readAsync. + globalThis.setTimeout = (f) => (typeof f == 'function') ? f() : abort(); + } + + if (typeof scriptArgs != 'undefined') { + arguments_ = scriptArgs; + } else if (typeof arguments != 'undefined') { + arguments_ = arguments; + } + + if (typeof quit == 'function') { + quit_ = (status, toThrow) => { + // Unlike node which has process.exitCode, d8 has no such mechanism. So we + // have no way to set the exit code and then let the program exit with + // that code when it naturally stops running (say, when all setTimeouts + // have completed). For that reason, we must call `quit` - the only way to + // set the exit code - but quit also halts immediately. To increase + // consistency with node (and the web) we schedule the actual quit call + // using a setTimeout to give the current stack and any exception handlers + // a chance to run. This enables features such as addOnPostRun (which + // expected to be able to run code after main returns). + setTimeout(() => { + if (!(toThrow instanceof ExitStatus)) { + let toLog = toThrow; + if (toThrow && typeof toThrow == 'object' && toThrow.stack) { + toLog = [toThrow, toThrow.stack]; + } + err(`exiting due to exception: ${toLog}`); + } + quit(status); + }); + throw toThrow; + }; + } + + if (typeof print != 'undefined') { + // Prefer to use print/printErr where they exist, as they usually work better. + if (typeof console == 'undefined') console = /** @type{!Console} */({}); + console.log = /** @type{!function(this:Console, ...*): undefined} */ (print); + console.warn = console.error = /** @type{!function(this:Console, ...*): undefined} */ (typeof printErr != 'undefined' ? printErr : print); + } + +} else + +// Note that this includes Node.js workers when relevant (pthreads is enabled). +// Node.js workers are detected as a combination of ENVIRONMENT_IS_WORKER and +// ENVIRONMENT_IS_NODE. +if (ENVIRONMENT_IS_WEB || ENVIRONMENT_IS_WORKER) { + if (ENVIRONMENT_IS_WORKER) { // Check worker, not web, since window could be polyfilled + scriptDirectory = self.location.href; + } else if (typeof document != 'undefined' && document.currentScript) { // web + scriptDirectory = document.currentScript.src; + } + // When MODULARIZE, this JS may be executed later, after document.currentScript + // is gone, so we saved it, and we use it here instead of any other info. + if (_scriptDir) { + scriptDirectory = _scriptDir; + } + // blob urls look like blob:http://site.com/etc/etc and we cannot infer anything from them. + // otherwise, slice off the final part of the url to find the script directory. + // if scriptDirectory does not contain a slash, lastIndexOf will return -1, + // and scriptDirectory will correctly be replaced with an empty string. + // If scriptDirectory contains a query (starting with ?) or a fragment (starting with #), + // they are removed because they could contain a slash. + if (scriptDirectory.startsWith('blob:')) { + scriptDirectory = ''; + } else { + scriptDirectory = scriptDirectory.substr(0, scriptDirectory.replace(/[?#].*/, '').lastIndexOf('/')+1); + } + + // Differentiate the Web Worker from the Node Worker case, as reading must + // be done differently. + { +// include: web_or_worker_shell_read.js +read_ = (url) => { + var xhr = new XMLHttpRequest(); + xhr.open('GET', url, false); + xhr.send(null); + return xhr.responseText; + } + + if (ENVIRONMENT_IS_WORKER) { + readBinary = (url) => { + var xhr = new XMLHttpRequest(); + xhr.open('GET', url, false); + xhr.responseType = 'arraybuffer'; + xhr.send(null); + return new Uint8Array(/** @type{!ArrayBuffer} */(xhr.response)); + }; + } + + readAsync = (url, onload, onerror) => { + var xhr = new XMLHttpRequest(); + xhr.open('GET', url, true); + xhr.responseType = 'arraybuffer'; + xhr.onload = () => { + if (xhr.status == 200 || (xhr.status == 0 && xhr.response)) { // file URLs can return 0 + onload(xhr.response); + return; + } + onerror(); + }; + xhr.onerror = onerror; + xhr.send(null); + } + +// end include: web_or_worker_shell_read.js + } +} else +{ +} + +var out = Module['print'] || console.log.bind(console); +var err = Module['printErr'] || console.error.bind(console); + +// Merge back in the overrides +Object.assign(Module, moduleOverrides); +// Free the object hierarchy contained in the overrides, this lets the GC +// reclaim data used. +moduleOverrides = null; + +// Emit code to handle expected values on the Module object. This applies Module.x +// to the proper local x. This has two benefits: first, we only emit it if it is +// expected to arrive, and second, by using a local everywhere else that can be +// minified. + +if (Module['arguments']) arguments_ = Module['arguments']; + +if (Module['thisProgram']) thisProgram = Module['thisProgram']; + +if (Module['quit']) quit_ = Module['quit']; + +// perform assertions in shell.js after we set up out() and err(), as otherwise if an assertion fails it cannot print the message +// end include: shell.js + +// include: preamble.js +// === Preamble library stuff === + +// Documentation for the public APIs defined in this file must be updated in: +// site/source/docs/api_reference/preamble.js.rst +// A prebuilt local version of the documentation is available at: +// site/build/text/docs/api_reference/preamble.js.txt +// You can also build docs locally as HTML or other formats in site/ +// An online HTML version (which may be of a different version of Emscripten) +// is up at http://kripken.github.io/emscripten-site/docs/api_reference/preamble.js.html + +var wasmBinary; +if (Module['wasmBinary']) wasmBinary = Module['wasmBinary']; + +// include: base64Utils.js +// include: polyfill/atob.js +// Copied from https://github.com/strophe/strophejs/blob/e06d027/src/polyfills.js#L149 + +// This code was written by Tyler Akins and has been placed in the +// public domain. It would be nice if you left this header intact. +// Base64 code from Tyler Akins -- http://rumkin.com + +if (typeof atob == 'undefined') { + if (typeof global != 'undefined' && typeof globalThis == 'undefined') { + globalThis = global; + } + + /** + * Decodes a base64 string. + * @param {string} input The string to decode. + */ + globalThis.atob = function(input) { + var keyStr = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='; + + var output = ''; + var chr1, chr2, chr3; + var enc1, enc2, enc3, enc4; + var i = 0; + // remove all characters that are not A-Z, a-z, 0-9, +, /, or = + input = input.replace(/[^A-Za-z0-9\+\/\=]/g, ''); + do { + enc1 = keyStr.indexOf(input.charAt(i++)); + enc2 = keyStr.indexOf(input.charAt(i++)); + enc3 = keyStr.indexOf(input.charAt(i++)); + enc4 = keyStr.indexOf(input.charAt(i++)); + + chr1 = (enc1 << 2) | (enc2 >> 4); + chr2 = ((enc2 & 15) << 4) | (enc3 >> 2); + chr3 = ((enc3 & 3) << 6) | enc4; + + output = output + String.fromCharCode(chr1); + + if (enc3 !== 64) { + output = output + String.fromCharCode(chr2); + } + if (enc4 !== 64) { + output = output + String.fromCharCode(chr3); + } + } while (i < input.length); + return output; + }; +} +// end include: polyfill/atob.js +// Converts a string of base64 into a byte array (Uint8Array). +function intArrayFromBase64(s) { + if (typeof ENVIRONMENT_IS_NODE != 'undefined' && ENVIRONMENT_IS_NODE) { + var buf = Buffer.from(s, 'base64'); + return new Uint8Array(buf.buffer, buf.byteOffset, buf.length); + } + + var decoded = atob(s); + var bytes = new Uint8Array(decoded.length); + for (var i = 0 ; i < decoded.length ; ++i) { + bytes[i] = decoded.charCodeAt(i); + } + return bytes; +} + +// If filename is a base64 data URI, parses and returns data (Buffer on node, +// Uint8Array otherwise). If filename is not a base64 data URI, returns undefined. +function tryParseAsDataURI(filename) { + if (!isDataURI(filename)) { + return; + } + + return intArrayFromBase64(filename.slice(dataURIPrefix.length)); +} +// end include: base64Utils.js +// Wasm globals + +var wasmMemory; + +//======================================== +// Runtime essentials +//======================================== + +// whether we are quitting the application. no code should run after this. +// set in exit() and abort() +var ABORT = false; + +// set by exit() and abort(). Passed to 'onExit' handler. +// NOTE: This is also used as the process return code code in shell environments +// but only when noExitRuntime is false. +var EXITSTATUS; + +// In STRICT mode, we only define assert() when ASSERTIONS is set. i.e. we +// don't define it at all in release modes. This matches the behaviour of +// MINIMAL_RUNTIME. +// TODO(sbc): Make this the default even without STRICT enabled. +/** @type {function(*, string=)} */ +function assert(condition, text) { + if (!condition) { + // This build was created without ASSERTIONS defined. `assert()` should not + // ever be called in this configuration but in case there are callers in + // the wild leave this simple abort() implementation here for now. + abort(text); + } +} + +// Memory management + +var HEAP, +/** @type {!Int8Array} */ + HEAP8, +/** @type {!Uint8Array} */ + HEAPU8, +/** @type {!Int16Array} */ + HEAP16, +/** @type {!Uint16Array} */ + HEAPU16, +/** @type {!Int32Array} */ + HEAP32, +/** @type {!Uint32Array} */ + HEAPU32, +/** @type {!Float32Array} */ + HEAPF32, +/* BigInt64Array type is not correctly defined in closure +/** not-@type {!BigInt64Array} */ + HEAP64, +/* BigUInt64Array type is not correctly defined in closure +/** not-t@type {!BigUint64Array} */ + HEAPU64, +/** @type {!Float64Array} */ + HEAPF64; + +// include: runtime_shared.js +function updateMemoryViews() { + var b = wasmMemory.buffer; + Module['HEAP8'] = HEAP8 = new Int8Array(b); + Module['HEAP16'] = HEAP16 = new Int16Array(b); + Module['HEAPU8'] = HEAPU8 = new Uint8Array(b); + Module['HEAPU16'] = HEAPU16 = new Uint16Array(b); + Module['HEAP32'] = HEAP32 = new Int32Array(b); + Module['HEAPU32'] = HEAPU32 = new Uint32Array(b); + Module['HEAPF32'] = HEAPF32 = new Float32Array(b); + Module['HEAPF64'] = HEAPF64 = new Float64Array(b); + Module['HEAP64'] = HEAP64 = new BigInt64Array(b); + Module['HEAPU64'] = HEAPU64 = new BigUint64Array(b); +} +// end include: runtime_shared.js +// include: runtime_stack_check.js +// end include: runtime_stack_check.js +// include: runtime_assertions.js +// end include: runtime_assertions.js +var __ATPRERUN__ = []; // functions called before the runtime is initialized +var __ATINIT__ = []; // functions called during startup +var __ATEXIT__ = []; // functions called during shutdown +var __ATPOSTRUN__ = []; // functions called after the main() is called + +var runtimeInitialized = false; + +var runtimeExited = false; + +function preRun() { + if (Module['preRun']) { + if (typeof Module['preRun'] == 'function') Module['preRun'] = [Module['preRun']]; + while (Module['preRun'].length) { + addOnPreRun(Module['preRun'].shift()); + } + } + callRuntimeCallbacks(__ATPRERUN__); +} + +function initRuntime() { + runtimeInitialized = true; + + +if (!Module['noFSInit'] && !FS.init.initialized) + FS.init(); +FS.ignorePermissions = false; + +TTY.init(); + callRuntimeCallbacks(__ATINIT__); +} + +function exitRuntime() { + ___funcs_on_exit(); // Native atexit() functions + callRuntimeCallbacks(__ATEXIT__); + FS.quit(); +TTY.shutdown(); + runtimeExited = true; +} + +function postRun() { + + if (Module['postRun']) { + if (typeof Module['postRun'] == 'function') Module['postRun'] = [Module['postRun']]; + while (Module['postRun'].length) { + addOnPostRun(Module['postRun'].shift()); + } + } + + callRuntimeCallbacks(__ATPOSTRUN__); +} + +function addOnPreRun(cb) { + __ATPRERUN__.unshift(cb); +} + +function addOnInit(cb) { + __ATINIT__.unshift(cb); +} + +function addOnExit(cb) { + __ATEXIT__.unshift(cb); +} + +function addOnPostRun(cb) { + __ATPOSTRUN__.unshift(cb); +} + +// include: runtime_math.js +// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/imul + +// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/fround + +// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/clz32 + +// https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/trunc + +// end include: runtime_math.js +// A counter of dependencies for calling run(). If we need to +// do asynchronous work before running, increment this and +// decrement it. Incrementing must happen in a place like +// Module.preRun (used by emcc to add file preloading). +// Note that you can add dependencies in preRun, even though +// it happens right before run - run will be postponed until +// the dependencies are met. +var runDependencies = 0; +var runDependencyWatcher = null; +var dependenciesFulfilled = null; // overridden to take different actions when all run dependencies are fulfilled + +function getUniqueRunDependency(id) { + return id; +} + +function addRunDependency(id) { + runDependencies++; + + Module['monitorRunDependencies']?.(runDependencies); + +} + +function removeRunDependency(id) { + runDependencies--; + + Module['monitorRunDependencies']?.(runDependencies); + + if (runDependencies == 0) { + if (runDependencyWatcher !== null) { + clearInterval(runDependencyWatcher); + runDependencyWatcher = null; + } + if (dependenciesFulfilled) { + var callback = dependenciesFulfilled; + dependenciesFulfilled = null; + callback(); // can add another dependenciesFulfilled + } + } +} + +/** @param {string|number=} what */ +function abort(what) { + Module['onAbort']?.(what); + + what = 'Aborted(' + what + ')'; + // TODO(sbc): Should we remove printing and leave it up to whoever + // catches the exception? + err(what); + + ABORT = true; + EXITSTATUS = 1; + + what += '. Build with -sASSERTIONS for more info.'; + + // Use a wasm runtime error, because a JS error might be seen as a foreign + // exception, which means we'd run destructors on it. We need the error to + // simply make the program stop. + // FIXME This approach does not work in Wasm EH because it currently does not assume + // all RuntimeErrors are from traps; it decides whether a RuntimeError is from + // a trap or not based on a hidden field within the object. So at the moment + // we don't have a way of throwing a wasm trap from JS. TODO Make a JS API that + // allows this in the wasm spec. + + // Suppress closure compiler warning here. Closure compiler's builtin extern + // definition for WebAssembly.RuntimeError claims it takes no arguments even + // though it can. + // TODO(https://github.com/google/closure-compiler/pull/3913): Remove if/when upstream closure gets fixed. + // See above, in the meantime, we resort to wasm code for trapping. + // + // In case abort() is called before the module is initialized, wasmExports + // and its exported '__trap' function is not available, in which case we throw + // a RuntimeError. + // + // We trap instead of throwing RuntimeError to prevent infinite-looping in + // Wasm EH code (because RuntimeError is considered as a foreign exception and + // caught by 'catch_all'), but in case throwing RuntimeError is fine because + // the module has not even been instantiated, even less running. + if (runtimeInitialized) { + ___trap(); + } + /** @suppress {checkTypes} */ + var e = new WebAssembly.RuntimeError(what); + + readyPromiseReject(e); + // Throw the error whether or not MODULARIZE is set because abort is used + // in code paths apart from instantiation where an exception is expected + // to be thrown when abort is called. + throw e; +} + +// include: memoryprofiler.js +// end include: memoryprofiler.js +// include: URIUtils.js +// Prefix of data URIs emitted by SINGLE_FILE and related options. +var dataURIPrefix = 'data:application/octet-stream;base64,'; + +/** + * Indicates whether filename is a base64 data URI. + * @noinline + */ +var isDataURI = (filename) => filename.startsWith(dataURIPrefix); + +/** + * Indicates whether filename is delivered via file protocol (as opposed to http/https) + * @noinline + */ +var isFileURI = (filename) => filename.startsWith('file://'); +// end include: URIUtils.js +// include: runtime_exceptions.js +// end include: runtime_exceptions.js +var wasmBinaryFile; +if (Module['locateFile']) { + wasmBinaryFile = 'dotnet.native.wasm'; + if (!isDataURI(wasmBinaryFile)) { + wasmBinaryFile = locateFile(wasmBinaryFile); + } +} else { + if (ENVIRONMENT_IS_SHELL) + wasmBinaryFile = 'dotnet.native.wasm'; + else + // Use bundler-friendly `new URL(..., import.meta.url)` pattern; works in browsers too. + wasmBinaryFile = new URL('dotnet.native.wasm', import.meta.url).href; +} + +function getBinarySync(file) { + if (file == wasmBinaryFile && wasmBinary) { + return new Uint8Array(wasmBinary); + } + if (readBinary) { + return readBinary(file); + } + throw 'both async and sync fetching of the wasm failed'; +} + +function getBinaryPromise(binaryFile) { + // If we don't have the binary yet, try to load it asynchronously. + // Fetch has some additional restrictions over XHR, like it can't be used on a file:// url. + // See https://github.com/github/fetch/pull/92#issuecomment-140665932 + // Cordova or Electron apps are typically loaded from a file:// url. + // So use fetch if it is available and the url is not a file, otherwise fall back to XHR. + if (!wasmBinary + && (ENVIRONMENT_IS_WEB || ENVIRONMENT_IS_WORKER)) { + if (typeof fetch == 'function' + && !isFileURI(binaryFile) + ) { + return fetch(binaryFile, { credentials: 'same-origin' }).then((response) => { + if (!response['ok']) { + throw `failed to load wasm binary file at '${binaryFile}'`; + } + return response['arrayBuffer'](); + }).catch(() => getBinarySync(binaryFile)); + } + else if (readAsync) { + // fetch is not available or url is file => try XHR (readAsync uses XHR internally) + return new Promise((resolve, reject) => { + readAsync(binaryFile, (response) => resolve(new Uint8Array(/** @type{!ArrayBuffer} */(response))), reject) + }); + } + } + + // Otherwise, getBinarySync should be able to get it synchronously + return Promise.resolve().then(() => getBinarySync(binaryFile)); +} + +function instantiateArrayBuffer(binaryFile, imports, receiver) { + return getBinaryPromise(binaryFile).then((binary) => { + return WebAssembly.instantiate(binary, imports); + }).then(receiver, (reason) => { + err(`failed to asynchronously prepare wasm: ${reason}`); + + abort(reason); + }); +} + +function instantiateAsync(binary, binaryFile, imports, callback) { + if (!binary && + typeof WebAssembly.instantiateStreaming == 'function' && + !isDataURI(binaryFile) && + // Don't use streaming for file:// delivered objects in a webview, fetch them synchronously. + !isFileURI(binaryFile) && + // Avoid instantiateStreaming() on Node.js environment for now, as while + // Node.js v18.1.0 implements it, it does not have a full fetch() + // implementation yet. + // + // Reference: + // https://github.com/emscripten-core/emscripten/pull/16917 + !ENVIRONMENT_IS_NODE && + typeof fetch == 'function') { + return fetch(binaryFile, { credentials: 'same-origin' }).then((response) => { + // Suppress closure warning here since the upstream definition for + // instantiateStreaming only allows Promise rather than + // an actual Response. + // TODO(https://github.com/google/closure-compiler/pull/3913): Remove if/when upstream closure is fixed. + /** @suppress {checkTypes} */ + var result = WebAssembly.instantiateStreaming(response, imports); + + return result.then( + callback, + function(reason) { + // We expect the most common failure cause to be a bad MIME type for the binary, + // in which case falling back to ArrayBuffer instantiation should work. + err(`wasm streaming compile failed: ${reason}`); + err('falling back to ArrayBuffer instantiation'); + return instantiateArrayBuffer(binaryFile, imports, callback); + }); + }); + } + return instantiateArrayBuffer(binaryFile, imports, callback); +} + +// Create the wasm instance. +// Receives the wasm imports, returns the exports. +function createWasm() { + // prepare imports + var info = { + 'env': wasmImports, + 'wasi_snapshot_preview1': wasmImports, + }; + // Load the wasm module and create an instance of using native support in the JS engine. + // handle a generated wasm instance, receiving its exports and + // performing other necessary setup + /** @param {WebAssembly.Module=} module*/ + function receiveInstance(instance, module) { + wasmExports = instance.exports; + + Module['wasmExports'] = wasmExports; + + wasmMemory = wasmExports['memory']; + + updateMemoryViews(); + + wasmTable = wasmExports['__indirect_function_table']; + + + addOnInit(wasmExports['__wasm_call_ctors']); + + removeRunDependency('wasm-instantiate'); + return wasmExports; + } + // wait for the pthread pool (if any) + addRunDependency('wasm-instantiate'); + + // Prefer streaming instantiation if available. + function receiveInstantiationResult(result) { + // 'result' is a ResultObject object which has both the module and instance. + // receiveInstance() will swap in the exports (to Module.asm) so they can be called + // TODO: Due to Closure regression https://github.com/google/closure-compiler/issues/3193, the above line no longer optimizes out down to the following line. + // When the regression is fixed, can restore the above PTHREADS-enabled path. + receiveInstance(result['instance']); + } + + // User shell pages can write their own Module.instantiateWasm = function(imports, successCallback) callback + // to manually instantiate the Wasm module themselves. This allows pages to + // run the instantiation parallel to any other async startup actions they are + // performing. + // Also pthreads and wasm workers initialize the wasm instance through this + // path. + if (Module['instantiateWasm']) { + + try { + return Module['instantiateWasm'](info, receiveInstance); + } catch(e) { + err(`Module.instantiateWasm callback failed with error: ${e}`); + // If instantiation fails, reject the module ready promise. + readyPromiseReject(e); + } + } + + // If instantiation fails, reject the module ready promise. + instantiateAsync(wasmBinary, wasmBinaryFile, info, receiveInstantiationResult).catch(readyPromiseReject); + return {}; // no exports yet; we'll fill them in later +} + +// include: runtime_debug.js +// end include: runtime_debug.js +// === Body === +// end include: preamble.js + + + /** @constructor */ + function ExitStatus(status) { + this.name = 'ExitStatus'; + this.message = `Program terminated with exit(${status})`; + this.status = status; + } + + var callRuntimeCallbacks = (callbacks) => { + while (callbacks.length > 0) { + // Pass the module as the first argument. + callbacks.shift()(Module); + } + }; + + + /** + * @param {number} ptr + * @param {string} type + */ + function getValue(ptr, type = 'i8') { + if (type.endsWith('*')) type = '*'; + switch (type) { + case 'i1': return HEAP8[ptr]; + case 'i8': return HEAP8[ptr]; + case 'i16': return HEAP16[((ptr)>>1)]; + case 'i32': return HEAP32[((ptr)>>2)]; + case 'i64': return HEAP64[((ptr)>>3)]; + case 'float': return HEAPF32[((ptr)>>2)]; + case 'double': return HEAPF64[((ptr)>>3)]; + case '*': return HEAPU32[((ptr)>>2)]; + default: abort(`invalid type for getValue: ${type}`); + } + } + + var noExitRuntime = Module['noExitRuntime'] || false; + + + /** + * @param {number} ptr + * @param {number} value + * @param {string} type + */ + function setValue(ptr, value, type = 'i8') { + if (type.endsWith('*')) type = '*'; + switch (type) { + case 'i1': HEAP8[ptr] = value; break; + case 'i8': HEAP8[ptr] = value; break; + case 'i16': HEAP16[((ptr)>>1)] = value; break; + case 'i32': HEAP32[((ptr)>>2)] = value; break; + case 'i64': HEAP64[((ptr)>>3)] = BigInt(value); break; + case 'float': HEAPF32[((ptr)>>2)] = value; break; + case 'double': HEAPF64[((ptr)>>3)] = value; break; + case '*': HEAPU32[((ptr)>>2)] = value; break; + default: abort(`invalid type for setValue: ${type}`); + } + } + + var UTF8Decoder = typeof TextDecoder != 'undefined' ? new TextDecoder('utf8') : undefined; + + /** + * Given a pointer 'idx' to a null-terminated UTF8-encoded string in the given + * array that contains uint8 values, returns a copy of that string as a + * Javascript String object. + * heapOrArray is either a regular array, or a JavaScript typed array view. + * @param {number} idx + * @param {number=} maxBytesToRead + * @return {string} + */ + var UTF8ArrayToString = (heapOrArray, idx, maxBytesToRead) => { + var endIdx = idx + maxBytesToRead; + var endPtr = idx; + // TextDecoder needs to know the byte length in advance, it doesn't stop on + // null terminator by itself. Also, use the length info to avoid running tiny + // strings through TextDecoder, since .subarray() allocates garbage. + // (As a tiny code save trick, compare endPtr against endIdx using a negation, + // so that undefined means Infinity) + while (heapOrArray[endPtr] && !(endPtr >= endIdx)) ++endPtr; + + if (endPtr - idx > 16 && heapOrArray.buffer && UTF8Decoder) { + return UTF8Decoder.decode(heapOrArray.subarray(idx, endPtr)); + } + var str = ''; + // If building with TextDecoder, we have already computed the string length + // above, so test loop end condition against that + while (idx < endPtr) { + // For UTF8 byte structure, see: + // http://en.wikipedia.org/wiki/UTF-8#Description + // https://www.ietf.org/rfc/rfc2279.txt + // https://tools.ietf.org/html/rfc3629 + var u0 = heapOrArray[idx++]; + if (!(u0 & 0x80)) { str += String.fromCharCode(u0); continue; } + var u1 = heapOrArray[idx++] & 63; + if ((u0 & 0xE0) == 0xC0) { str += String.fromCharCode(((u0 & 31) << 6) | u1); continue; } + var u2 = heapOrArray[idx++] & 63; + if ((u0 & 0xF0) == 0xE0) { + u0 = ((u0 & 15) << 12) | (u1 << 6) | u2; + } else { + u0 = ((u0 & 7) << 18) | (u1 << 12) | (u2 << 6) | (heapOrArray[idx++] & 63); + } + + if (u0 < 0x10000) { + str += String.fromCharCode(u0); + } else { + var ch = u0 - 0x10000; + str += String.fromCharCode(0xD800 | (ch >> 10), 0xDC00 | (ch & 0x3FF)); + } + } + return str; + }; + + /** + * Given a pointer 'ptr' to a null-terminated UTF8-encoded string in the + * emscripten HEAP, returns a copy of that string as a Javascript String object. + * + * @param {number} ptr + * @param {number=} maxBytesToRead - An optional length that specifies the + * maximum number of bytes to read. You can omit this parameter to scan the + * string until the first 0 byte. If maxBytesToRead is passed, and the string + * at [ptr, ptr+maxBytesToReadr[ contains a null byte in the middle, then the + * string will cut short at that byte index (i.e. maxBytesToRead will not + * produce a string of exact length [ptr, ptr+maxBytesToRead[) N.B. mixing + * frequent uses of UTF8ToString() with and without maxBytesToRead may throw + * JS JIT optimizations off, so it is worth to consider consistently using one + * @return {string} + */ + var UTF8ToString = (ptr, maxBytesToRead) => { + return ptr ? UTF8ArrayToString(HEAPU8, ptr, maxBytesToRead) : ''; + }; + var ___assert_fail = (condition, filename, line, func) => { + abort(`Assertion failed: ${UTF8ToString(condition)}, at: ` + [filename ? UTF8ToString(filename) : 'unknown filename', line, func ? UTF8ToString(func) : 'unknown function']); + }; + + var PATH = { + isAbs:(path) => path.charAt(0) === '/', + splitPath:(filename) => { + var splitPathRe = /^(\/?|)([\s\S]*?)((?:\.{1,2}|[^\/]+?|)(\.[^.\/]*|))(?:[\/]*)$/; + return splitPathRe.exec(filename).slice(1); + }, + normalizeArray:(parts, allowAboveRoot) => { + // if the path tries to go above the root, `up` ends up > 0 + var up = 0; + for (var i = parts.length - 1; i >= 0; i--) { + var last = parts[i]; + if (last === '.') { + parts.splice(i, 1); + } else if (last === '..') { + parts.splice(i, 1); + up++; + } else if (up) { + parts.splice(i, 1); + up--; + } + } + // if the path is allowed to go above the root, restore leading ..s + if (allowAboveRoot) { + for (; up; up--) { + parts.unshift('..'); + } + } + return parts; + }, + normalize:(path) => { + var isAbsolute = PATH.isAbs(path), + trailingSlash = path.substr(-1) === '/'; + // Normalize the path + path = PATH.normalizeArray(path.split('/').filter((p) => !!p), !isAbsolute).join('/'); + if (!path && !isAbsolute) { + path = '.'; + } + if (path && trailingSlash) { + path += '/'; + } + return (isAbsolute ? '/' : '') + path; + }, + dirname:(path) => { + var result = PATH.splitPath(path), + root = result[0], + dir = result[1]; + if (!root && !dir) { + // No dirname whatsoever + return '.'; + } + if (dir) { + // It has a dirname, strip trailing slash + dir = dir.substr(0, dir.length - 1); + } + return root + dir; + }, + basename:(path) => { + // EMSCRIPTEN return '/'' for '/', not an empty string + if (path === '/') return '/'; + path = PATH.normalize(path); + path = path.replace(/\/$/, ""); + var lastSlash = path.lastIndexOf('/'); + if (lastSlash === -1) return path; + return path.substr(lastSlash+1); + }, + join:(...paths) => PATH.normalize(paths.join('/')), + join2:(l, r) => PATH.normalize(l + '/' + r), + }; + + var initRandomFill = () => { + if (typeof crypto == 'object' && typeof crypto['getRandomValues'] == 'function') { + // for modern web browsers + return (view) => crypto.getRandomValues(view); + } else + if (ENVIRONMENT_IS_NODE) { + // for nodejs with or without crypto support included + try { + var crypto_module = require('crypto'); + var randomFillSync = crypto_module['randomFillSync']; + if (randomFillSync) { + // nodejs with LTS crypto support + return (view) => crypto_module['randomFillSync'](view); + } + // very old nodejs with the original crypto API + var randomBytes = crypto_module['randomBytes']; + return (view) => ( + view.set(randomBytes(view.byteLength)), + // Return the original view to match modern native implementations. + view + ); + } catch (e) { + // nodejs doesn't have crypto support + } + } + // we couldn't find a proper implementation, as Math.random() is not suitable for /dev/random, see emscripten-core/emscripten/pull/7096 + abort('initRandomDevice'); + }; + var randomFill = (view) => { + // Lazily init on the first invocation. + return (randomFill = initRandomFill())(view); + }; + + + + var PATH_FS = { + resolve:(...args) => { + var resolvedPath = '', + resolvedAbsolute = false; + for (var i = args.length - 1; i >= -1 && !resolvedAbsolute; i--) { + var path = (i >= 0) ? args[i] : FS.cwd(); + // Skip empty and invalid entries + if (typeof path != 'string') { + throw new TypeError('Arguments to path.resolve must be strings'); + } else if (!path) { + return ''; // an invalid portion invalidates the whole thing + } + resolvedPath = path + '/' + resolvedPath; + resolvedAbsolute = PATH.isAbs(path); + } + // At this point the path should be resolved to a full absolute path, but + // handle relative paths to be safe (might happen when process.cwd() fails) + resolvedPath = PATH.normalizeArray(resolvedPath.split('/').filter((p) => !!p), !resolvedAbsolute).join('/'); + return ((resolvedAbsolute ? '/' : '') + resolvedPath) || '.'; + }, + relative:(from, to) => { + from = PATH_FS.resolve(from).substr(1); + to = PATH_FS.resolve(to).substr(1); + function trim(arr) { + var start = 0; + for (; start < arr.length; start++) { + if (arr[start] !== '') break; + } + var end = arr.length - 1; + for (; end >= 0; end--) { + if (arr[end] !== '') break; + } + if (start > end) return []; + return arr.slice(start, end - start + 1); + } + var fromParts = trim(from.split('/')); + var toParts = trim(to.split('/')); + var length = Math.min(fromParts.length, toParts.length); + var samePartsLength = length; + for (var i = 0; i < length; i++) { + if (fromParts[i] !== toParts[i]) { + samePartsLength = i; + break; + } + } + var outputParts = []; + for (var i = samePartsLength; i < fromParts.length; i++) { + outputParts.push('..'); + } + outputParts = outputParts.concat(toParts.slice(samePartsLength)); + return outputParts.join('/'); + }, + }; + + + + var FS_stdin_getChar_buffer = []; + + var lengthBytesUTF8 = (str) => { + var len = 0; + for (var i = 0; i < str.length; ++i) { + // Gotcha: charCodeAt returns a 16-bit word that is a UTF-16 encoded code + // unit, not a Unicode code point of the character! So decode + // UTF16->UTF32->UTF8. + // See http://unicode.org/faq/utf_bom.html#utf16-3 + var c = str.charCodeAt(i); // possibly a lead surrogate + if (c <= 0x7F) { + len++; + } else if (c <= 0x7FF) { + len += 2; + } else if (c >= 0xD800 && c <= 0xDFFF) { + len += 4; ++i; + } else { + len += 3; + } + } + return len; + }; + + var stringToUTF8Array = (str, heap, outIdx, maxBytesToWrite) => { + // Parameter maxBytesToWrite is not optional. Negative values, 0, null, + // undefined and false each don't write out any bytes. + if (!(maxBytesToWrite > 0)) + return 0; + + var startIdx = outIdx; + var endIdx = outIdx + maxBytesToWrite - 1; // -1 for string null terminator. + for (var i = 0; i < str.length; ++i) { + // Gotcha: charCodeAt returns a 16-bit word that is a UTF-16 encoded code + // unit, not a Unicode code point of the character! So decode + // UTF16->UTF32->UTF8. + // See http://unicode.org/faq/utf_bom.html#utf16-3 + // For UTF8 byte structure, see http://en.wikipedia.org/wiki/UTF-8#Description + // and https://www.ietf.org/rfc/rfc2279.txt + // and https://tools.ietf.org/html/rfc3629 + var u = str.charCodeAt(i); // possibly a lead surrogate + if (u >= 0xD800 && u <= 0xDFFF) { + var u1 = str.charCodeAt(++i); + u = 0x10000 + ((u & 0x3FF) << 10) | (u1 & 0x3FF); + } + if (u <= 0x7F) { + if (outIdx >= endIdx) break; + heap[outIdx++] = u; + } else if (u <= 0x7FF) { + if (outIdx + 1 >= endIdx) break; + heap[outIdx++] = 0xC0 | (u >> 6); + heap[outIdx++] = 0x80 | (u & 63); + } else if (u <= 0xFFFF) { + if (outIdx + 2 >= endIdx) break; + heap[outIdx++] = 0xE0 | (u >> 12); + heap[outIdx++] = 0x80 | ((u >> 6) & 63); + heap[outIdx++] = 0x80 | (u & 63); + } else { + if (outIdx + 3 >= endIdx) break; + heap[outIdx++] = 0xF0 | (u >> 18); + heap[outIdx++] = 0x80 | ((u >> 12) & 63); + heap[outIdx++] = 0x80 | ((u >> 6) & 63); + heap[outIdx++] = 0x80 | (u & 63); + } + } + // Null-terminate the pointer to the buffer. + heap[outIdx] = 0; + return outIdx - startIdx; + }; + /** @type {function(string, boolean=, number=)} */ + function intArrayFromString(stringy, dontAddNull, length) { + var len = length > 0 ? length : lengthBytesUTF8(stringy)+1; + var u8array = new Array(len); + var numBytesWritten = stringToUTF8Array(stringy, u8array, 0, u8array.length); + if (dontAddNull) u8array.length = numBytesWritten; + return u8array; + } + var FS_stdin_getChar = () => { + if (!FS_stdin_getChar_buffer.length) { + var result = null; + if (ENVIRONMENT_IS_NODE) { + // we will read data by chunks of BUFSIZE + var BUFSIZE = 256; + var buf = Buffer.alloc(BUFSIZE); + var bytesRead = 0; + + // For some reason we must suppress a closure warning here, even though + // fd definitely exists on process.stdin, and is even the proper way to + // get the fd of stdin, + // https://github.com/nodejs/help/issues/2136#issuecomment-523649904 + // This started to happen after moving this logic out of library_tty.js, + // so it is related to the surrounding code in some unclear manner. + /** @suppress {missingProperties} */ + var fd = process.stdin.fd; + + try { + bytesRead = fs.readSync(fd, buf); + } catch(e) { + // Cross-platform differences: on Windows, reading EOF throws an exception, but on other OSes, + // reading EOF returns 0. Uniformize behavior by treating the EOF exception to return 0. + if (e.toString().includes('EOF')) bytesRead = 0; + else throw e; + } + + if (bytesRead > 0) { + result = buf.slice(0, bytesRead).toString('utf-8'); + } else { + result = null; + } + } else + if (typeof window != 'undefined' && + typeof window.prompt == 'function') { + // Browser. + result = window.prompt('Input: '); // returns null on cancel + if (result !== null) { + result += '\n'; + } + } else if (typeof readline == 'function') { + // Command line. + result = readline(); + if (result !== null) { + result += '\n'; + } + } + if (!result) { + return null; + } + FS_stdin_getChar_buffer = intArrayFromString(result, true); + } + return FS_stdin_getChar_buffer.shift(); + }; + var TTY = { + ttys:[], + init() { + // https://github.com/emscripten-core/emscripten/pull/1555 + // if (ENVIRONMENT_IS_NODE) { + // // currently, FS.init does not distinguish if process.stdin is a file or TTY + // // device, it always assumes it's a TTY device. because of this, we're forcing + // // process.stdin to UTF8 encoding to at least make stdin reading compatible + // // with text files until FS.init can be refactored. + // process.stdin.setEncoding('utf8'); + // } + }, + shutdown() { + // https://github.com/emscripten-core/emscripten/pull/1555 + // if (ENVIRONMENT_IS_NODE) { + // // inolen: any idea as to why node -e 'process.stdin.read()' wouldn't exit immediately (with process.stdin being a tty)? + // // isaacs: because now it's reading from the stream, you've expressed interest in it, so that read() kicks off a _read() which creates a ReadReq operation + // // inolen: I thought read() in that case was a synchronous operation that just grabbed some amount of buffered data if it exists? + // // isaacs: it is. but it also triggers a _read() call, which calls readStart() on the handle + // // isaacs: do process.stdin.pause() and i'd think it'd probably close the pending call + // process.stdin.pause(); + // } + }, + register(dev, ops) { + TTY.ttys[dev] = { input: [], output: [], ops: ops }; + FS.registerDevice(dev, TTY.stream_ops); + }, + stream_ops:{ + open(stream) { + var tty = TTY.ttys[stream.node.rdev]; + if (!tty) { + throw new FS.ErrnoError(43); + } + stream.tty = tty; + stream.seekable = false; + }, + close(stream) { + // flush any pending line data + stream.tty.ops.fsync(stream.tty); + }, + fsync(stream) { + stream.tty.ops.fsync(stream.tty); + }, + read(stream, buffer, offset, length, pos /* ignored */) { + if (!stream.tty || !stream.tty.ops.get_char) { + throw new FS.ErrnoError(60); + } + var bytesRead = 0; + for (var i = 0; i < length; i++) { + var result; + try { + result = stream.tty.ops.get_char(stream.tty); + } catch (e) { + throw new FS.ErrnoError(29); + } + if (result === undefined && bytesRead === 0) { + throw new FS.ErrnoError(6); + } + if (result === null || result === undefined) break; + bytesRead++; + buffer[offset+i] = result; + } + if (bytesRead) { + stream.node.timestamp = Date.now(); + } + return bytesRead; + }, + write(stream, buffer, offset, length, pos) { + if (!stream.tty || !stream.tty.ops.put_char) { + throw new FS.ErrnoError(60); + } + try { + for (var i = 0; i < length; i++) { + stream.tty.ops.put_char(stream.tty, buffer[offset+i]); + } + } catch (e) { + throw new FS.ErrnoError(29); + } + if (length) { + stream.node.timestamp = Date.now(); + } + return i; + }, + }, + default_tty_ops:{ + get_char(tty) { + return FS_stdin_getChar(); + }, + put_char(tty, val) { + if (val === null || val === 10) { + out(UTF8ArrayToString(tty.output, 0)); + tty.output = []; + } else { + if (val != 0) tty.output.push(val); // val == 0 would cut text output off in the middle. + } + }, + fsync(tty) { + if (tty.output && tty.output.length > 0) { + out(UTF8ArrayToString(tty.output, 0)); + tty.output = []; + } + }, + ioctl_tcgets(tty) { + // typical setting + return { + c_iflag: 25856, + c_oflag: 5, + c_cflag: 191, + c_lflag: 35387, + c_cc: [ + 0x03, 0x1c, 0x7f, 0x15, 0x04, 0x00, 0x01, 0x00, 0x11, 0x13, 0x1a, 0x00, + 0x12, 0x0f, 0x17, 0x16, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + ] + }; + }, + ioctl_tcsets(tty, optional_actions, data) { + // currently just ignore + return 0; + }, + ioctl_tiocgwinsz(tty) { + return [24, 80]; + }, + }, + default_tty1_ops:{ + put_char(tty, val) { + if (val === null || val === 10) { + err(UTF8ArrayToString(tty.output, 0)); + tty.output = []; + } else { + if (val != 0) tty.output.push(val); + } + }, + fsync(tty) { + if (tty.output && tty.output.length > 0) { + err(UTF8ArrayToString(tty.output, 0)); + tty.output = []; + } + }, + }, + }; + + + var zeroMemory = (address, size) => { + HEAPU8.fill(0, address, address + size); + return address; + }; + + var alignMemory = (size, alignment) => { + return Math.ceil(size / alignment) * alignment; + }; + var mmapAlloc = (size) => { + size = alignMemory(size, 65536); + var ptr = _emscripten_builtin_memalign(65536, size); + if (!ptr) return 0; + return zeroMemory(ptr, size); + }; + var MEMFS = { + ops_table:null, + mount(mount) { + return MEMFS.createNode(null, '/', 16384 | 511 /* 0777 */, 0); + }, + createNode(parent, name, mode, dev) { + if (FS.isBlkdev(mode) || FS.isFIFO(mode)) { + // no supported + throw new FS.ErrnoError(63); + } + MEMFS.ops_table ||= { + dir: { + node: { + getattr: MEMFS.node_ops.getattr, + setattr: MEMFS.node_ops.setattr, + lookup: MEMFS.node_ops.lookup, + mknod: MEMFS.node_ops.mknod, + rename: MEMFS.node_ops.rename, + unlink: MEMFS.node_ops.unlink, + rmdir: MEMFS.node_ops.rmdir, + readdir: MEMFS.node_ops.readdir, + symlink: MEMFS.node_ops.symlink + }, + stream: { + llseek: MEMFS.stream_ops.llseek + } + }, + file: { + node: { + getattr: MEMFS.node_ops.getattr, + setattr: MEMFS.node_ops.setattr + }, + stream: { + llseek: MEMFS.stream_ops.llseek, + read: MEMFS.stream_ops.read, + write: MEMFS.stream_ops.write, + allocate: MEMFS.stream_ops.allocate, + mmap: MEMFS.stream_ops.mmap, + msync: MEMFS.stream_ops.msync + } + }, + link: { + node: { + getattr: MEMFS.node_ops.getattr, + setattr: MEMFS.node_ops.setattr, + readlink: MEMFS.node_ops.readlink + }, + stream: {} + }, + chrdev: { + node: { + getattr: MEMFS.node_ops.getattr, + setattr: MEMFS.node_ops.setattr + }, + stream: FS.chrdev_stream_ops + } + }; + var node = FS.createNode(parent, name, mode, dev); + if (FS.isDir(node.mode)) { + node.node_ops = MEMFS.ops_table.dir.node; + node.stream_ops = MEMFS.ops_table.dir.stream; + node.contents = {}; + } else if (FS.isFile(node.mode)) { + node.node_ops = MEMFS.ops_table.file.node; + node.stream_ops = MEMFS.ops_table.file.stream; + node.usedBytes = 0; // The actual number of bytes used in the typed array, as opposed to contents.length which gives the whole capacity. + // When the byte data of the file is populated, this will point to either a typed array, or a normal JS array. Typed arrays are preferred + // for performance, and used by default. However, typed arrays are not resizable like normal JS arrays are, so there is a small disk size + // penalty involved for appending file writes that continuously grow a file similar to std::vector capacity vs used -scheme. + node.contents = null; + } else if (FS.isLink(node.mode)) { + node.node_ops = MEMFS.ops_table.link.node; + node.stream_ops = MEMFS.ops_table.link.stream; + } else if (FS.isChrdev(node.mode)) { + node.node_ops = MEMFS.ops_table.chrdev.node; + node.stream_ops = MEMFS.ops_table.chrdev.stream; + } + node.timestamp = Date.now(); + // add the new node to the parent + if (parent) { + parent.contents[name] = node; + parent.timestamp = node.timestamp; + } + return node; + }, + getFileDataAsTypedArray(node) { + if (!node.contents) return new Uint8Array(0); + if (node.contents.subarray) return node.contents.subarray(0, node.usedBytes); // Make sure to not return excess unused bytes. + return new Uint8Array(node.contents); + }, + expandFileStorage(node, newCapacity) { + var prevCapacity = node.contents ? node.contents.length : 0; + if (prevCapacity >= newCapacity) return; // No need to expand, the storage was already large enough. + // Don't expand strictly to the given requested limit if it's only a very small increase, but instead geometrically grow capacity. + // For small filesizes (<1MB), perform size*2 geometric increase, but for large sizes, do a much more conservative size*1.125 increase to + // avoid overshooting the allocation cap by a very large margin. + var CAPACITY_DOUBLING_MAX = 1024 * 1024; + newCapacity = Math.max(newCapacity, (prevCapacity * (prevCapacity < CAPACITY_DOUBLING_MAX ? 2.0 : 1.125)) >>> 0); + if (prevCapacity != 0) newCapacity = Math.max(newCapacity, 256); // At minimum allocate 256b for each file when expanding. + var oldContents = node.contents; + node.contents = new Uint8Array(newCapacity); // Allocate new storage. + if (node.usedBytes > 0) node.contents.set(oldContents.subarray(0, node.usedBytes), 0); // Copy old data over to the new storage. + }, + resizeFileStorage(node, newSize) { + if (node.usedBytes == newSize) return; + if (newSize == 0) { + node.contents = null; // Fully decommit when requesting a resize to zero. + node.usedBytes = 0; + } else { + var oldContents = node.contents; + node.contents = new Uint8Array(newSize); // Allocate new storage. + if (oldContents) { + node.contents.set(oldContents.subarray(0, Math.min(newSize, node.usedBytes))); // Copy old data over to the new storage. + } + node.usedBytes = newSize; + } + }, + node_ops:{ + getattr(node) { + var attr = {}; + // device numbers reuse inode numbers. + attr.dev = FS.isChrdev(node.mode) ? node.id : 1; + attr.ino = node.id; + attr.mode = node.mode; + attr.nlink = 1; + attr.uid = 0; + attr.gid = 0; + attr.rdev = node.rdev; + if (FS.isDir(node.mode)) { + attr.size = 4096; + } else if (FS.isFile(node.mode)) { + attr.size = node.usedBytes; + } else if (FS.isLink(node.mode)) { + attr.size = node.link.length; + } else { + attr.size = 0; + } + attr.atime = new Date(node.timestamp); + attr.mtime = new Date(node.timestamp); + attr.ctime = new Date(node.timestamp); + // NOTE: In our implementation, st_blocks = Math.ceil(st_size/st_blksize), + // but this is not required by the standard. + attr.blksize = 4096; + attr.blocks = Math.ceil(attr.size / attr.blksize); + return attr; + }, + setattr(node, attr) { + if (attr.mode !== undefined) { + node.mode = attr.mode; + } + if (attr.timestamp !== undefined) { + node.timestamp = attr.timestamp; + } + if (attr.size !== undefined) { + MEMFS.resizeFileStorage(node, attr.size); + } + }, + lookup(parent, name) { + throw FS.genericErrors[44]; + }, + mknod(parent, name, mode, dev) { + return MEMFS.createNode(parent, name, mode, dev); + }, + rename(old_node, new_dir, new_name) { + // if we're overwriting a directory at new_name, make sure it's empty. + if (FS.isDir(old_node.mode)) { + var new_node; + try { + new_node = FS.lookupNode(new_dir, new_name); + } catch (e) { + } + if (new_node) { + for (var i in new_node.contents) { + throw new FS.ErrnoError(55); + } + } + } + // do the internal rewiring + delete old_node.parent.contents[old_node.name]; + old_node.parent.timestamp = Date.now() + old_node.name = new_name; + new_dir.contents[new_name] = old_node; + new_dir.timestamp = old_node.parent.timestamp; + old_node.parent = new_dir; + }, + unlink(parent, name) { + delete parent.contents[name]; + parent.timestamp = Date.now(); + }, + rmdir(parent, name) { + var node = FS.lookupNode(parent, name); + for (var i in node.contents) { + throw new FS.ErrnoError(55); + } + delete parent.contents[name]; + parent.timestamp = Date.now(); + }, + readdir(node) { + var entries = ['.', '..']; + for (var key of Object.keys(node.contents)) { + entries.push(key); + } + return entries; + }, + symlink(parent, newname, oldpath) { + var node = MEMFS.createNode(parent, newname, 511 /* 0777 */ | 40960, 0); + node.link = oldpath; + return node; + }, + readlink(node) { + if (!FS.isLink(node.mode)) { + throw new FS.ErrnoError(28); + } + return node.link; + }, + }, + stream_ops:{ + read(stream, buffer, offset, length, position) { + var contents = stream.node.contents; + if (position >= stream.node.usedBytes) return 0; + var size = Math.min(stream.node.usedBytes - position, length); + if (size > 8 && contents.subarray) { // non-trivial, and typed array + buffer.set(contents.subarray(position, position + size), offset); + } else { + for (var i = 0; i < size; i++) buffer[offset + i] = contents[position + i]; + } + return size; + }, + write(stream, buffer, offset, length, position, canOwn) { + // If the buffer is located in main memory (HEAP), and if + // memory can grow, we can't hold on to references of the + // memory buffer, as they may get invalidated. That means we + // need to do copy its contents. + if (buffer.buffer === HEAP8.buffer) { + canOwn = false; + } + + if (!length) return 0; + var node = stream.node; + node.timestamp = Date.now(); + + if (buffer.subarray && (!node.contents || node.contents.subarray)) { // This write is from a typed array to a typed array? + if (canOwn) { + node.contents = buffer.subarray(offset, offset + length); + node.usedBytes = length; + return length; + } else if (node.usedBytes === 0 && position === 0) { // If this is a simple first write to an empty file, do a fast set since we don't need to care about old data. + node.contents = buffer.slice(offset, offset + length); + node.usedBytes = length; + return length; + } else if (position + length <= node.usedBytes) { // Writing to an already allocated and used subrange of the file? + node.contents.set(buffer.subarray(offset, offset + length), position); + return length; + } + } + + // Appending to an existing file and we need to reallocate, or source data did not come as a typed array. + MEMFS.expandFileStorage(node, position+length); + if (node.contents.subarray && buffer.subarray) { + // Use typed array write which is available. + node.contents.set(buffer.subarray(offset, offset + length), position); + } else { + for (var i = 0; i < length; i++) { + node.contents[position + i] = buffer[offset + i]; // Or fall back to manual write if not. + } + } + node.usedBytes = Math.max(node.usedBytes, position + length); + return length; + }, + llseek(stream, offset, whence) { + var position = offset; + if (whence === 1) { + position += stream.position; + } else if (whence === 2) { + if (FS.isFile(stream.node.mode)) { + position += stream.node.usedBytes; + } + } + if (position < 0) { + throw new FS.ErrnoError(28); + } + return position; + }, + allocate(stream, offset, length) { + MEMFS.expandFileStorage(stream.node, offset + length); + stream.node.usedBytes = Math.max(stream.node.usedBytes, offset + length); + }, + mmap(stream, length, position, prot, flags) { + if (!FS.isFile(stream.node.mode)) { + throw new FS.ErrnoError(43); + } + var ptr; + var allocated; + var contents = stream.node.contents; + // Only make a new copy when MAP_PRIVATE is specified. + if (!(flags & 2) && contents.buffer === HEAP8.buffer) { + // We can't emulate MAP_SHARED when the file is not backed by the + // buffer we're mapping to (e.g. the HEAP buffer). + allocated = false; + ptr = contents.byteOffset; + } else { + // Try to avoid unnecessary slices. + if (position > 0 || position + length < contents.length) { + if (contents.subarray) { + contents = contents.subarray(position, position + length); + } else { + contents = Array.prototype.slice.call(contents, position, position + length); + } + } + allocated = true; + ptr = mmapAlloc(length); + if (!ptr) { + throw new FS.ErrnoError(48); + } + HEAP8.set(contents, ptr); + } + return { ptr, allocated }; + }, + msync(stream, buffer, offset, length, mmapFlags) { + MEMFS.stream_ops.write(stream, buffer, 0, length, offset, false); + // should we check if bytesWritten and length are the same? + return 0; + }, + }, + }; + + /** @param {boolean=} noRunDep */ + var asyncLoad = (url, onload, onerror, noRunDep) => { + var dep = !noRunDep ? getUniqueRunDependency(`al ${url}`) : ''; + readAsync(url, (arrayBuffer) => { + onload(new Uint8Array(arrayBuffer)); + if (dep) removeRunDependency(dep); + }, (event) => { + if (onerror) { + onerror(); + } else { + throw `Loading data file "${url}" failed.`; + } + }); + if (dep) addRunDependency(dep); + }; + + + var FS_createDataFile = (parent, name, fileData, canRead, canWrite, canOwn) => { + FS.createDataFile(parent, name, fileData, canRead, canWrite, canOwn); + }; + + var preloadPlugins = Module['preloadPlugins'] || []; + var FS_handledByPreloadPlugin = (byteArray, fullname, finish, onerror) => { + // Ensure plugins are ready. + if (typeof Browser != 'undefined') Browser.init(); + + var handled = false; + preloadPlugins.forEach((plugin) => { + if (handled) return; + if (plugin['canHandle'](fullname)) { + plugin['handle'](byteArray, fullname, finish, onerror); + handled = true; + } + }); + return handled; + }; + var FS_createPreloadedFile = (parent, name, url, canRead, canWrite, onload, onerror, dontCreateFile, canOwn, preFinish) => { + // TODO we should allow people to just pass in a complete filename instead + // of parent and name being that we just join them anyways + var fullname = name ? PATH_FS.resolve(PATH.join2(parent, name)) : parent; + var dep = getUniqueRunDependency(`cp ${fullname}`); // might have several active requests for the same fullname + function processData(byteArray) { + function finish(byteArray) { + preFinish?.(); + if (!dontCreateFile) { + FS_createDataFile(parent, name, byteArray, canRead, canWrite, canOwn); + } + onload?.(); + removeRunDependency(dep); + } + if (FS_handledByPreloadPlugin(byteArray, fullname, finish, () => { + onerror?.(); + removeRunDependency(dep); + })) { + return; + } + finish(byteArray); + } + addRunDependency(dep); + if (typeof url == 'string') { + asyncLoad(url, processData, onerror); + } else { + processData(url); + } + }; + + var FS_modeStringToFlags = (str) => { + var flagModes = { + 'r': 0, + 'r+': 2, + 'w': 512 | 64 | 1, + 'w+': 512 | 64 | 2, + 'a': 1024 | 64 | 1, + 'a+': 1024 | 64 | 2, + }; + var flags = flagModes[str]; + if (typeof flags == 'undefined') { + throw new Error(`Unknown file open mode: ${str}`); + } + return flags; + }; + + var FS_getMode = (canRead, canWrite) => { + var mode = 0; + if (canRead) mode |= 292 | 73; + if (canWrite) mode |= 146; + return mode; + }; + + + + var FS = { + root:null, + mounts:[], + devices:{ + }, + streams:[], + nextInode:1, + nameTable:null, + currentPath:"/", + initialized:false, + ignorePermissions:true, + ErrnoError:class { + // We set the `name` property to be able to identify `FS.ErrnoError` + // - the `name` is a standard ECMA-262 property of error objects. Kind of good to have it anyway. + // - when using PROXYFS, an error can come from an underlying FS + // as different FS objects have their own FS.ErrnoError each, + // the test `err instanceof FS.ErrnoError` won't detect an error coming from another filesystem, causing bugs. + // we'll use the reliable test `err.name == "ErrnoError"` instead + constructor(errno) { + // TODO(sbc): Use the inline member declaration syntax once we + // support it in acorn and closure. + this.name = 'ErrnoError'; + this.errno = errno; + } + }, + genericErrors:{ + }, + filesystems:null, + syncFSRequests:0, + FSStream:class { + constructor() { + // TODO(https://github.com/emscripten-core/emscripten/issues/21414): + // Use inline field declarations. + this.shared = {}; + } + get object() { + return this.node; + } + set object(val) { + this.node = val; + } + get isRead() { + return (this.flags & 2097155) !== 1; + } + get isWrite() { + return (this.flags & 2097155) !== 0; + } + get isAppend() { + return (this.flags & 1024); + } + get flags() { + return this.shared.flags; + } + set flags(val) { + this.shared.flags = val; + } + get position() { + return this.shared.position; + } + set position(val) { + this.shared.position = val; + } + }, + FSNode:class { + constructor(parent, name, mode, rdev) { + if (!parent) { + parent = this; // root node sets parent to itself + } + this.parent = parent; + this.mount = parent.mount; + this.mounted = null; + this.id = FS.nextInode++; + this.name = name; + this.mode = mode; + this.node_ops = {}; + this.stream_ops = {}; + this.rdev = rdev; + this.readMode = 292/*292*/ | 73/*73*/; + this.writeMode = 146/*146*/; + } + get read() { + return (this.mode & this.readMode) === this.readMode; + } + set read(val) { + val ? this.mode |= this.readMode : this.mode &= ~this.readMode; + } + get write() { + return (this.mode & this.writeMode) === this.writeMode; + } + set write(val) { + val ? this.mode |= this.writeMode : this.mode &= ~this.writeMode; + } + get isFolder() { + return FS.isDir(this.mode); + } + get isDevice() { + return FS.isChrdev(this.mode); + } + }, + lookupPath(path, opts = {}) { + path = PATH_FS.resolve(path); + + if (!path) return { path: '', node: null }; + + var defaults = { + follow_mount: true, + recurse_count: 0 + }; + opts = Object.assign(defaults, opts) + + if (opts.recurse_count > 8) { // max recursive lookup of 8 + throw new FS.ErrnoError(32); + } + + // split the absolute path + var parts = path.split('/').filter((p) => !!p); + + // start at the root + var current = FS.root; + var current_path = '/'; + + for (var i = 0; i < parts.length; i++) { + var islast = (i === parts.length-1); + if (islast && opts.parent) { + // stop resolving + break; + } + + current = FS.lookupNode(current, parts[i]); + current_path = PATH.join2(current_path, parts[i]); + + // jump to the mount's root node if this is a mountpoint + if (FS.isMountpoint(current)) { + if (!islast || (islast && opts.follow_mount)) { + current = current.mounted.root; + } + } + + // by default, lookupPath will not follow a symlink if it is the final path component. + // setting opts.follow = true will override this behavior. + if (!islast || opts.follow) { + var count = 0; + while (FS.isLink(current.mode)) { + var link = FS.readlink(current_path); + current_path = PATH_FS.resolve(PATH.dirname(current_path), link); + + var lookup = FS.lookupPath(current_path, { recurse_count: opts.recurse_count + 1 }); + current = lookup.node; + + if (count++ > 40) { // limit max consecutive symlinks to 40 (SYMLOOP_MAX). + throw new FS.ErrnoError(32); + } + } + } + } + + return { path: current_path, node: current }; + }, + getPath(node) { + var path; + while (true) { + if (FS.isRoot(node)) { + var mount = node.mount.mountpoint; + if (!path) return mount; + return mount[mount.length-1] !== '/' ? `${mount}/${path}` : mount + path; + } + path = path ? `${node.name}/${path}` : node.name; + node = node.parent; + } + }, + hashName(parentid, name) { + var hash = 0; + + for (var i = 0; i < name.length; i++) { + hash = ((hash << 5) - hash + name.charCodeAt(i)) | 0; + } + return ((parentid + hash) >>> 0) % FS.nameTable.length; + }, + hashAddNode(node) { + var hash = FS.hashName(node.parent.id, node.name); + node.name_next = FS.nameTable[hash]; + FS.nameTable[hash] = node; + }, + hashRemoveNode(node) { + var hash = FS.hashName(node.parent.id, node.name); + if (FS.nameTable[hash] === node) { + FS.nameTable[hash] = node.name_next; + } else { + var current = FS.nameTable[hash]; + while (current) { + if (current.name_next === node) { + current.name_next = node.name_next; + break; + } + current = current.name_next; + } + } + }, + lookupNode(parent, name) { + var errCode = FS.mayLookup(parent); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + var hash = FS.hashName(parent.id, name); + for (var node = FS.nameTable[hash]; node; node = node.name_next) { + var nodeName = node.name; + if (node.parent.id === parent.id && nodeName === name) { + return node; + } + } + // if we failed to find it in the cache, call into the VFS + return FS.lookup(parent, name); + }, + createNode(parent, name, mode, rdev) { + var node = new FS.FSNode(parent, name, mode, rdev); + + FS.hashAddNode(node); + + return node; + }, + destroyNode(node) { + FS.hashRemoveNode(node); + }, + isRoot(node) { + return node === node.parent; + }, + isMountpoint(node) { + return !!node.mounted; + }, + isFile(mode) { + return (mode & 61440) === 32768; + }, + isDir(mode) { + return (mode & 61440) === 16384; + }, + isLink(mode) { + return (mode & 61440) === 40960; + }, + isChrdev(mode) { + return (mode & 61440) === 8192; + }, + isBlkdev(mode) { + return (mode & 61440) === 24576; + }, + isFIFO(mode) { + return (mode & 61440) === 4096; + }, + isSocket(mode) { + return (mode & 49152) === 49152; + }, + flagsToPermissionString(flag) { + var perms = ['r', 'w', 'rw'][flag & 3]; + if ((flag & 512)) { + perms += 'w'; + } + return perms; + }, + nodePermissions(node, perms) { + if (FS.ignorePermissions) { + return 0; + } + // return 0 if any user, group or owner bits are set. + if (perms.includes('r') && !(node.mode & 292)) { + return 2; + } else if (perms.includes('w') && !(node.mode & 146)) { + return 2; + } else if (perms.includes('x') && !(node.mode & 73)) { + return 2; + } + return 0; + }, + mayLookup(dir) { + if (!FS.isDir(dir.mode)) return 54; + var errCode = FS.nodePermissions(dir, 'x'); + if (errCode) return errCode; + if (!dir.node_ops.lookup) return 2; + return 0; + }, + mayCreate(dir, name) { + try { + var node = FS.lookupNode(dir, name); + return 20; + } catch (e) { + } + return FS.nodePermissions(dir, 'wx'); + }, + mayDelete(dir, name, isdir) { + var node; + try { + node = FS.lookupNode(dir, name); + } catch (e) { + return e.errno; + } + var errCode = FS.nodePermissions(dir, 'wx'); + if (errCode) { + return errCode; + } + if (isdir) { + if (!FS.isDir(node.mode)) { + return 54; + } + if (FS.isRoot(node) || FS.getPath(node) === FS.cwd()) { + return 10; + } + } else { + if (FS.isDir(node.mode)) { + return 31; + } + } + return 0; + }, + mayOpen(node, flags) { + if (!node) { + return 44; + } + if (FS.isLink(node.mode)) { + return 32; + } else if (FS.isDir(node.mode)) { + if (FS.flagsToPermissionString(flags) !== 'r' || // opening for write + (flags & 512)) { // TODO: check for O_SEARCH? (== search for dir only) + return 31; + } + } + return FS.nodePermissions(node, FS.flagsToPermissionString(flags)); + }, + MAX_OPEN_FDS:4096, + nextfd() { + for (var fd = 0; fd <= FS.MAX_OPEN_FDS; fd++) { + if (!FS.streams[fd]) { + return fd; + } + } + throw new FS.ErrnoError(33); + }, + getStreamChecked(fd) { + var stream = FS.getStream(fd); + if (!stream) { + throw new FS.ErrnoError(8); + } + return stream; + }, + getStream:(fd) => FS.streams[fd], + createStream(stream, fd = -1) { + + // clone it, so we can return an instance of FSStream + stream = Object.assign(new FS.FSStream(), stream); + if (fd == -1) { + fd = FS.nextfd(); + } + stream.fd = fd; + FS.streams[fd] = stream; + return stream; + }, + closeStream(fd) { + FS.streams[fd] = null; + }, + dupStream(origStream, fd = -1) { + var stream = FS.createStream(origStream, fd); + stream.stream_ops?.dup?.(stream); + return stream; + }, + chrdev_stream_ops:{ + open(stream) { + var device = FS.getDevice(stream.node.rdev); + // override node's stream ops with the device's + stream.stream_ops = device.stream_ops; + // forward the open call + stream.stream_ops.open?.(stream); + }, + llseek() { + throw new FS.ErrnoError(70); + }, + }, + major:(dev) => ((dev) >> 8), + minor:(dev) => ((dev) & 0xff), + makedev:(ma, mi) => ((ma) << 8 | (mi)), + registerDevice(dev, ops) { + FS.devices[dev] = { stream_ops: ops }; + }, + getDevice:(dev) => FS.devices[dev], + getMounts(mount) { + var mounts = []; + var check = [mount]; + + while (check.length) { + var m = check.pop(); + + mounts.push(m); + + check.push(...m.mounts); + } + + return mounts; + }, + syncfs(populate, callback) { + if (typeof populate == 'function') { + callback = populate; + populate = false; + } + + FS.syncFSRequests++; + + if (FS.syncFSRequests > 1) { + err(`warning: ${FS.syncFSRequests} FS.syncfs operations in flight at once, probably just doing extra work`); + } + + var mounts = FS.getMounts(FS.root.mount); + var completed = 0; + + function doCallback(errCode) { + FS.syncFSRequests--; + return callback(errCode); + } + + function done(errCode) { + if (errCode) { + if (!done.errored) { + done.errored = true; + return doCallback(errCode); + } + return; + } + if (++completed >= mounts.length) { + doCallback(null); + } + }; + + // sync all mounts + mounts.forEach((mount) => { + if (!mount.type.syncfs) { + return done(null); + } + mount.type.syncfs(mount, populate, done); + }); + }, + mount(type, opts, mountpoint) { + var root = mountpoint === '/'; + var pseudo = !mountpoint; + var node; + + if (root && FS.root) { + throw new FS.ErrnoError(10); + } else if (!root && !pseudo) { + var lookup = FS.lookupPath(mountpoint, { follow_mount: false }); + + mountpoint = lookup.path; // use the absolute path + node = lookup.node; + + if (FS.isMountpoint(node)) { + throw new FS.ErrnoError(10); + } + + if (!FS.isDir(node.mode)) { + throw new FS.ErrnoError(54); + } + } + + var mount = { + type, + opts, + mountpoint, + mounts: [] + }; + + // create a root node for the fs + var mountRoot = type.mount(mount); + mountRoot.mount = mount; + mount.root = mountRoot; + + if (root) { + FS.root = mountRoot; + } else if (node) { + // set as a mountpoint + node.mounted = mount; + + // add the new mount to the current mount's children + if (node.mount) { + node.mount.mounts.push(mount); + } + } + + return mountRoot; + }, + unmount(mountpoint) { + var lookup = FS.lookupPath(mountpoint, { follow_mount: false }); + + if (!FS.isMountpoint(lookup.node)) { + throw new FS.ErrnoError(28); + } + + // destroy the nodes for this mount, and all its child mounts + var node = lookup.node; + var mount = node.mounted; + var mounts = FS.getMounts(mount); + + Object.keys(FS.nameTable).forEach((hash) => { + var current = FS.nameTable[hash]; + + while (current) { + var next = current.name_next; + + if (mounts.includes(current.mount)) { + FS.destroyNode(current); + } + + current = next; + } + }); + + // no longer a mountpoint + node.mounted = null; + + // remove this mount from the child mounts + var idx = node.mount.mounts.indexOf(mount); + node.mount.mounts.splice(idx, 1); + }, + lookup(parent, name) { + return parent.node_ops.lookup(parent, name); + }, + mknod(path, mode, dev) { + var lookup = FS.lookupPath(path, { parent: true }); + var parent = lookup.node; + var name = PATH.basename(path); + if (!name || name === '.' || name === '..') { + throw new FS.ErrnoError(28); + } + var errCode = FS.mayCreate(parent, name); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + if (!parent.node_ops.mknod) { + throw new FS.ErrnoError(63); + } + return parent.node_ops.mknod(parent, name, mode, dev); + }, + create(path, mode) { + mode = mode !== undefined ? mode : 438 /* 0666 */; + mode &= 4095; + mode |= 32768; + return FS.mknod(path, mode, 0); + }, + mkdir(path, mode) { + mode = mode !== undefined ? mode : 511 /* 0777 */; + mode &= 511 | 512; + mode |= 16384; + return FS.mknod(path, mode, 0); + }, + mkdirTree(path, mode) { + var dirs = path.split('/'); + var d = ''; + for (var i = 0; i < dirs.length; ++i) { + if (!dirs[i]) continue; + d += '/' + dirs[i]; + try { + FS.mkdir(d, mode); + } catch(e) { + if (e.errno != 20) throw e; + } + } + }, + mkdev(path, mode, dev) { + if (typeof dev == 'undefined') { + dev = mode; + mode = 438 /* 0666 */; + } + mode |= 8192; + return FS.mknod(path, mode, dev); + }, + symlink(oldpath, newpath) { + if (!PATH_FS.resolve(oldpath)) { + throw new FS.ErrnoError(44); + } + var lookup = FS.lookupPath(newpath, { parent: true }); + var parent = lookup.node; + if (!parent) { + throw new FS.ErrnoError(44); + } + var newname = PATH.basename(newpath); + var errCode = FS.mayCreate(parent, newname); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + if (!parent.node_ops.symlink) { + throw new FS.ErrnoError(63); + } + return parent.node_ops.symlink(parent, newname, oldpath); + }, + rename(old_path, new_path) { + var old_dirname = PATH.dirname(old_path); + var new_dirname = PATH.dirname(new_path); + var old_name = PATH.basename(old_path); + var new_name = PATH.basename(new_path); + // parents must exist + var lookup, old_dir, new_dir; + + // let the errors from non existent directories percolate up + lookup = FS.lookupPath(old_path, { parent: true }); + old_dir = lookup.node; + lookup = FS.lookupPath(new_path, { parent: true }); + new_dir = lookup.node; + + if (!old_dir || !new_dir) throw new FS.ErrnoError(44); + // need to be part of the same mount + if (old_dir.mount !== new_dir.mount) { + throw new FS.ErrnoError(75); + } + // source must exist + var old_node = FS.lookupNode(old_dir, old_name); + // old path should not be an ancestor of the new path + var relative = PATH_FS.relative(old_path, new_dirname); + if (relative.charAt(0) !== '.') { + throw new FS.ErrnoError(28); + } + // new path should not be an ancestor of the old path + relative = PATH_FS.relative(new_path, old_dirname); + if (relative.charAt(0) !== '.') { + throw new FS.ErrnoError(55); + } + // see if the new path already exists + var new_node; + try { + new_node = FS.lookupNode(new_dir, new_name); + } catch (e) { + // not fatal + } + // early out if nothing needs to change + if (old_node === new_node) { + return; + } + // we'll need to delete the old entry + var isdir = FS.isDir(old_node.mode); + var errCode = FS.mayDelete(old_dir, old_name, isdir); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + // need delete permissions if we'll be overwriting. + // need create permissions if new doesn't already exist. + errCode = new_node ? + FS.mayDelete(new_dir, new_name, isdir) : + FS.mayCreate(new_dir, new_name); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + if (!old_dir.node_ops.rename) { + throw new FS.ErrnoError(63); + } + if (FS.isMountpoint(old_node) || (new_node && FS.isMountpoint(new_node))) { + throw new FS.ErrnoError(10); + } + // if we are going to change the parent, check write permissions + if (new_dir !== old_dir) { + errCode = FS.nodePermissions(old_dir, 'w'); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + } + // remove the node from the lookup hash + FS.hashRemoveNode(old_node); + // do the underlying fs rename + try { + old_dir.node_ops.rename(old_node, new_dir, new_name); + } catch (e) { + throw e; + } finally { + // add the node back to the hash (in case node_ops.rename + // changed its name) + FS.hashAddNode(old_node); + } + }, + rmdir(path) { + var lookup = FS.lookupPath(path, { parent: true }); + var parent = lookup.node; + var name = PATH.basename(path); + var node = FS.lookupNode(parent, name); + var errCode = FS.mayDelete(parent, name, true); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + if (!parent.node_ops.rmdir) { + throw new FS.ErrnoError(63); + } + if (FS.isMountpoint(node)) { + throw new FS.ErrnoError(10); + } + parent.node_ops.rmdir(parent, name); + FS.destroyNode(node); + }, + readdir(path) { + var lookup = FS.lookupPath(path, { follow: true }); + var node = lookup.node; + if (!node.node_ops.readdir) { + throw new FS.ErrnoError(54); + } + return node.node_ops.readdir(node); + }, + unlink(path) { + var lookup = FS.lookupPath(path, { parent: true }); + var parent = lookup.node; + if (!parent) { + throw new FS.ErrnoError(44); + } + var name = PATH.basename(path); + var node = FS.lookupNode(parent, name); + var errCode = FS.mayDelete(parent, name, false); + if (errCode) { + // According to POSIX, we should map EISDIR to EPERM, but + // we instead do what Linux does (and we must, as we use + // the musl linux libc). + throw new FS.ErrnoError(errCode); + } + if (!parent.node_ops.unlink) { + throw new FS.ErrnoError(63); + } + if (FS.isMountpoint(node)) { + throw new FS.ErrnoError(10); + } + parent.node_ops.unlink(parent, name); + FS.destroyNode(node); + }, + readlink(path) { + var lookup = FS.lookupPath(path); + var link = lookup.node; + if (!link) { + throw new FS.ErrnoError(44); + } + if (!link.node_ops.readlink) { + throw new FS.ErrnoError(28); + } + return PATH_FS.resolve(FS.getPath(link.parent), link.node_ops.readlink(link)); + }, + stat(path, dontFollow) { + var lookup = FS.lookupPath(path, { follow: !dontFollow }); + var node = lookup.node; + if (!node) { + throw new FS.ErrnoError(44); + } + if (!node.node_ops.getattr) { + throw new FS.ErrnoError(63); + } + return node.node_ops.getattr(node); + }, + lstat(path) { + return FS.stat(path, true); + }, + chmod(path, mode, dontFollow) { + var node; + if (typeof path == 'string') { + var lookup = FS.lookupPath(path, { follow: !dontFollow }); + node = lookup.node; + } else { + node = path; + } + if (!node.node_ops.setattr) { + throw new FS.ErrnoError(63); + } + node.node_ops.setattr(node, { + mode: (mode & 4095) | (node.mode & ~4095), + timestamp: Date.now() + }); + }, + lchmod(path, mode) { + FS.chmod(path, mode, true); + }, + fchmod(fd, mode) { + var stream = FS.getStreamChecked(fd); + FS.chmod(stream.node, mode); + }, + chown(path, uid, gid, dontFollow) { + var node; + if (typeof path == 'string') { + var lookup = FS.lookupPath(path, { follow: !dontFollow }); + node = lookup.node; + } else { + node = path; + } + if (!node.node_ops.setattr) { + throw new FS.ErrnoError(63); + } + node.node_ops.setattr(node, { + timestamp: Date.now() + // we ignore the uid / gid for now + }); + }, + lchown(path, uid, gid) { + FS.chown(path, uid, gid, true); + }, + fchown(fd, uid, gid) { + var stream = FS.getStreamChecked(fd); + FS.chown(stream.node, uid, gid); + }, + truncate(path, len) { + if (len < 0) { + throw new FS.ErrnoError(28); + } + var node; + if (typeof path == 'string') { + var lookup = FS.lookupPath(path, { follow: true }); + node = lookup.node; + } else { + node = path; + } + if (!node.node_ops.setattr) { + throw new FS.ErrnoError(63); + } + if (FS.isDir(node.mode)) { + throw new FS.ErrnoError(31); + } + if (!FS.isFile(node.mode)) { + throw new FS.ErrnoError(28); + } + var errCode = FS.nodePermissions(node, 'w'); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + node.node_ops.setattr(node, { + size: len, + timestamp: Date.now() + }); + }, + ftruncate(fd, len) { + var stream = FS.getStreamChecked(fd); + if ((stream.flags & 2097155) === 0) { + throw new FS.ErrnoError(28); + } + FS.truncate(stream.node, len); + }, + utime(path, atime, mtime) { + var lookup = FS.lookupPath(path, { follow: true }); + var node = lookup.node; + node.node_ops.setattr(node, { + timestamp: Math.max(atime, mtime) + }); + }, + open(path, flags, mode) { + if (path === "") { + throw new FS.ErrnoError(44); + } + flags = typeof flags == 'string' ? FS_modeStringToFlags(flags) : flags; + mode = typeof mode == 'undefined' ? 438 /* 0666 */ : mode; + if ((flags & 64)) { + mode = (mode & 4095) | 32768; + } else { + mode = 0; + } + var node; + if (typeof path == 'object') { + node = path; + } else { + path = PATH.normalize(path); + try { + var lookup = FS.lookupPath(path, { + follow: !(flags & 131072) + }); + node = lookup.node; + } catch (e) { + // ignore + } + } + // perhaps we need to create the node + var created = false; + if ((flags & 64)) { + if (node) { + // if O_CREAT and O_EXCL are set, error out if the node already exists + if ((flags & 128)) { + throw new FS.ErrnoError(20); + } + } else { + // node doesn't exist, try to create it + node = FS.mknod(path, mode, 0); + created = true; + } + } + if (!node) { + throw new FS.ErrnoError(44); + } + // can't truncate a device + if (FS.isChrdev(node.mode)) { + flags &= ~512; + } + // if asked only for a directory, then this must be one + if ((flags & 65536) && !FS.isDir(node.mode)) { + throw new FS.ErrnoError(54); + } + // check permissions, if this is not a file we just created now (it is ok to + // create and write to a file with read-only permissions; it is read-only + // for later use) + if (!created) { + var errCode = FS.mayOpen(node, flags); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + } + // do truncation if necessary + if ((flags & 512) && !created) { + FS.truncate(node, 0); + } + // we've already handled these, don't pass down to the underlying vfs + flags &= ~(128 | 512 | 131072); + + // register the stream with the filesystem + var stream = FS.createStream({ + node, + path: FS.getPath(node), // we want the absolute path to the node + flags, + seekable: true, + position: 0, + stream_ops: node.stream_ops, + // used by the file family libc calls (fopen, fwrite, ferror, etc.) + ungotten: [], + error: false + }); + // call the new stream's open function + if (stream.stream_ops.open) { + stream.stream_ops.open(stream); + } + if (Module['logReadFiles'] && !(flags & 1)) { + if (!FS.readFiles) FS.readFiles = {}; + if (!(path in FS.readFiles)) { + FS.readFiles[path] = 1; + } + } + return stream; + }, + close(stream) { + if (FS.isClosed(stream)) { + throw new FS.ErrnoError(8); + } + if (stream.getdents) stream.getdents = null; // free readdir state + try { + if (stream.stream_ops.close) { + stream.stream_ops.close(stream); + } + } catch (e) { + throw e; + } finally { + FS.closeStream(stream.fd); + } + stream.fd = null; + }, + isClosed(stream) { + return stream.fd === null; + }, + llseek(stream, offset, whence) { + if (FS.isClosed(stream)) { + throw new FS.ErrnoError(8); + } + if (!stream.seekable || !stream.stream_ops.llseek) { + throw new FS.ErrnoError(70); + } + if (whence != 0 && whence != 1 && whence != 2) { + throw new FS.ErrnoError(28); + } + stream.position = stream.stream_ops.llseek(stream, offset, whence); + stream.ungotten = []; + return stream.position; + }, + read(stream, buffer, offset, length, position) { + if (length < 0 || position < 0) { + throw new FS.ErrnoError(28); + } + if (FS.isClosed(stream)) { + throw new FS.ErrnoError(8); + } + if ((stream.flags & 2097155) === 1) { + throw new FS.ErrnoError(8); + } + if (FS.isDir(stream.node.mode)) { + throw new FS.ErrnoError(31); + } + if (!stream.stream_ops.read) { + throw new FS.ErrnoError(28); + } + var seeking = typeof position != 'undefined'; + if (!seeking) { + position = stream.position; + } else if (!stream.seekable) { + throw new FS.ErrnoError(70); + } + var bytesRead = stream.stream_ops.read(stream, buffer, offset, length, position); + if (!seeking) stream.position += bytesRead; + return bytesRead; + }, + write(stream, buffer, offset, length, position, canOwn) { + if (length < 0 || position < 0) { + throw new FS.ErrnoError(28); + } + if (FS.isClosed(stream)) { + throw new FS.ErrnoError(8); + } + if ((stream.flags & 2097155) === 0) { + throw new FS.ErrnoError(8); + } + if (FS.isDir(stream.node.mode)) { + throw new FS.ErrnoError(31); + } + if (!stream.stream_ops.write) { + throw new FS.ErrnoError(28); + } + if (stream.seekable && stream.flags & 1024) { + // seek to the end before writing in append mode + FS.llseek(stream, 0, 2); + } + var seeking = typeof position != 'undefined'; + if (!seeking) { + position = stream.position; + } else if (!stream.seekable) { + throw new FS.ErrnoError(70); + } + var bytesWritten = stream.stream_ops.write(stream, buffer, offset, length, position, canOwn); + if (!seeking) stream.position += bytesWritten; + return bytesWritten; + }, + allocate(stream, offset, length) { + if (FS.isClosed(stream)) { + throw new FS.ErrnoError(8); + } + if (offset < 0 || length <= 0) { + throw new FS.ErrnoError(28); + } + if ((stream.flags & 2097155) === 0) { + throw new FS.ErrnoError(8); + } + if (!FS.isFile(stream.node.mode) && !FS.isDir(stream.node.mode)) { + throw new FS.ErrnoError(43); + } + if (!stream.stream_ops.allocate) { + throw new FS.ErrnoError(138); + } + stream.stream_ops.allocate(stream, offset, length); + }, + mmap(stream, length, position, prot, flags) { + // User requests writing to file (prot & PROT_WRITE != 0). + // Checking if we have permissions to write to the file unless + // MAP_PRIVATE flag is set. According to POSIX spec it is possible + // to write to file opened in read-only mode with MAP_PRIVATE flag, + // as all modifications will be visible only in the memory of + // the current process. + if ((prot & 2) !== 0 + && (flags & 2) === 0 + && (stream.flags & 2097155) !== 2) { + throw new FS.ErrnoError(2); + } + if ((stream.flags & 2097155) === 1) { + throw new FS.ErrnoError(2); + } + if (!stream.stream_ops.mmap) { + throw new FS.ErrnoError(43); + } + return stream.stream_ops.mmap(stream, length, position, prot, flags); + }, + msync(stream, buffer, offset, length, mmapFlags) { + if (!stream.stream_ops.msync) { + return 0; + } + return stream.stream_ops.msync(stream, buffer, offset, length, mmapFlags); + }, + ioctl(stream, cmd, arg) { + if (!stream.stream_ops.ioctl) { + throw new FS.ErrnoError(59); + } + return stream.stream_ops.ioctl(stream, cmd, arg); + }, + readFile(path, opts = {}) { + opts.flags = opts.flags || 0; + opts.encoding = opts.encoding || 'binary'; + if (opts.encoding !== 'utf8' && opts.encoding !== 'binary') { + throw new Error(`Invalid encoding type "${opts.encoding}"`); + } + var ret; + var stream = FS.open(path, opts.flags); + var stat = FS.stat(path); + var length = stat.size; + var buf = new Uint8Array(length); + FS.read(stream, buf, 0, length, 0); + if (opts.encoding === 'utf8') { + ret = UTF8ArrayToString(buf, 0); + } else if (opts.encoding === 'binary') { + ret = buf; + } + FS.close(stream); + return ret; + }, + writeFile(path, data, opts = {}) { + opts.flags = opts.flags || 577; + var stream = FS.open(path, opts.flags, opts.mode); + if (typeof data == 'string') { + var buf = new Uint8Array(lengthBytesUTF8(data)+1); + var actualNumBytes = stringToUTF8Array(data, buf, 0, buf.length); + FS.write(stream, buf, 0, actualNumBytes, undefined, opts.canOwn); + } else if (ArrayBuffer.isView(data)) { + FS.write(stream, data, 0, data.byteLength, undefined, opts.canOwn); + } else { + throw new Error('Unsupported data type'); + } + FS.close(stream); + }, + cwd:() => FS.currentPath, + chdir(path) { + var lookup = FS.lookupPath(path, { follow: true }); + if (lookup.node === null) { + throw new FS.ErrnoError(44); + } + if (!FS.isDir(lookup.node.mode)) { + throw new FS.ErrnoError(54); + } + var errCode = FS.nodePermissions(lookup.node, 'x'); + if (errCode) { + throw new FS.ErrnoError(errCode); + } + FS.currentPath = lookup.path; + }, + createDefaultDirectories() { + FS.mkdir('/tmp'); + FS.mkdir('/home'); + FS.mkdir('/home/web_user'); + }, + createDefaultDevices() { + // create /dev + FS.mkdir('/dev'); + // setup /dev/null + FS.registerDevice(FS.makedev(1, 3), { + read: () => 0, + write: (stream, buffer, offset, length, pos) => length, + }); + FS.mkdev('/dev/null', FS.makedev(1, 3)); + // setup /dev/tty and /dev/tty1 + // stderr needs to print output using err() rather than out() + // so we register a second tty just for it. + TTY.register(FS.makedev(5, 0), TTY.default_tty_ops); + TTY.register(FS.makedev(6, 0), TTY.default_tty1_ops); + FS.mkdev('/dev/tty', FS.makedev(5, 0)); + FS.mkdev('/dev/tty1', FS.makedev(6, 0)); + // setup /dev/[u]random + // use a buffer to avoid overhead of individual crypto calls per byte + var randomBuffer = new Uint8Array(1024), randomLeft = 0; + var randomByte = () => { + if (randomLeft === 0) { + randomLeft = randomFill(randomBuffer).byteLength; + } + return randomBuffer[--randomLeft]; + }; + FS.createDevice('/dev', 'random', randomByte); + FS.createDevice('/dev', 'urandom', randomByte); + // we're not going to emulate the actual shm device, + // just create the tmp dirs that reside in it commonly + FS.mkdir('/dev/shm'); + FS.mkdir('/dev/shm/tmp'); + }, + createSpecialDirectories() { + // create /proc/self/fd which allows /proc/self/fd/6 => readlink gives the + // name of the stream for fd 6 (see test_unistd_ttyname) + FS.mkdir('/proc'); + var proc_self = FS.mkdir('/proc/self'); + FS.mkdir('/proc/self/fd'); + FS.mount({ + mount() { + var node = FS.createNode(proc_self, 'fd', 16384 | 511 /* 0777 */, 73); + node.node_ops = { + lookup(parent, name) { + var fd = +name; + var stream = FS.getStreamChecked(fd); + var ret = { + parent: null, + mount: { mountpoint: 'fake' }, + node_ops: { readlink: () => stream.path }, + }; + ret.parent = ret; // make it look like a simple root node + return ret; + } + }; + return node; + } + }, {}, '/proc/self/fd'); + }, + createStandardStreams() { + // TODO deprecate the old functionality of a single + // input / output callback and that utilizes FS.createDevice + // and instead require a unique set of stream ops + + // by default, we symlink the standard streams to the + // default tty devices. however, if the standard streams + // have been overwritten we create a unique device for + // them instead. + if (Module['stdin']) { + FS.createDevice('/dev', 'stdin', Module['stdin']); + } else { + FS.symlink('/dev/tty', '/dev/stdin'); + } + if (Module['stdout']) { + FS.createDevice('/dev', 'stdout', null, Module['stdout']); + } else { + FS.symlink('/dev/tty', '/dev/stdout'); + } + if (Module['stderr']) { + FS.createDevice('/dev', 'stderr', null, Module['stderr']); + } else { + FS.symlink('/dev/tty1', '/dev/stderr'); + } + + // open default streams for the stdin, stdout and stderr devices + var stdin = FS.open('/dev/stdin', 0); + var stdout = FS.open('/dev/stdout', 1); + var stderr = FS.open('/dev/stderr', 1); + }, + staticInit() { + // Some errors may happen quite a bit, to avoid overhead we reuse them (and suffer a lack of stack info) + [44].forEach((code) => { + FS.genericErrors[code] = new FS.ErrnoError(code); + FS.genericErrors[code].stack = ''; + }); + + FS.nameTable = new Array(4096); + + FS.mount(MEMFS, {}, '/'); + + FS.createDefaultDirectories(); + FS.createDefaultDevices(); + FS.createSpecialDirectories(); + + FS.filesystems = { + 'MEMFS': MEMFS, + }; + }, + init(input, output, error) { + FS.init.initialized = true; + + // Allow Module.stdin etc. to provide defaults, if none explicitly passed to us here + Module['stdin'] = input || Module['stdin']; + Module['stdout'] = output || Module['stdout']; + Module['stderr'] = error || Module['stderr']; + + FS.createStandardStreams(); + }, + quit() { + FS.init.initialized = false; + // force-flush all streams, so we get musl std streams printed out + _fflush(0); + // close all of our streams + for (var i = 0; i < FS.streams.length; i++) { + var stream = FS.streams[i]; + if (!stream) { + continue; + } + FS.close(stream); + } + }, + findObject(path, dontResolveLastLink) { + var ret = FS.analyzePath(path, dontResolveLastLink); + if (!ret.exists) { + return null; + } + return ret.object; + }, + analyzePath(path, dontResolveLastLink) { + // operate from within the context of the symlink's target + try { + var lookup = FS.lookupPath(path, { follow: !dontResolveLastLink }); + path = lookup.path; + } catch (e) { + } + var ret = { + isRoot: false, exists: false, error: 0, name: null, path: null, object: null, + parentExists: false, parentPath: null, parentObject: null + }; + try { + var lookup = FS.lookupPath(path, { parent: true }); + ret.parentExists = true; + ret.parentPath = lookup.path; + ret.parentObject = lookup.node; + ret.name = PATH.basename(path); + lookup = FS.lookupPath(path, { follow: !dontResolveLastLink }); + ret.exists = true; + ret.path = lookup.path; + ret.object = lookup.node; + ret.name = lookup.node.name; + ret.isRoot = lookup.path === '/'; + } catch (e) { + ret.error = e.errno; + }; + return ret; + }, + createPath(parent, path, canRead, canWrite) { + parent = typeof parent == 'string' ? parent : FS.getPath(parent); + var parts = path.split('/').reverse(); + while (parts.length) { + var part = parts.pop(); + if (!part) continue; + var current = PATH.join2(parent, part); + try { + FS.mkdir(current); + } catch (e) { + // ignore EEXIST + } + parent = current; + } + return current; + }, + createFile(parent, name, properties, canRead, canWrite) { + var path = PATH.join2(typeof parent == 'string' ? parent : FS.getPath(parent), name); + var mode = FS_getMode(canRead, canWrite); + return FS.create(path, mode); + }, + createDataFile(parent, name, data, canRead, canWrite, canOwn) { + var path = name; + if (parent) { + parent = typeof parent == 'string' ? parent : FS.getPath(parent); + path = name ? PATH.join2(parent, name) : parent; + } + var mode = FS_getMode(canRead, canWrite); + var node = FS.create(path, mode); + if (data) { + if (typeof data == 'string') { + var arr = new Array(data.length); + for (var i = 0, len = data.length; i < len; ++i) arr[i] = data.charCodeAt(i); + data = arr; + } + // make sure we can write to the file + FS.chmod(node, mode | 146); + var stream = FS.open(node, 577); + FS.write(stream, data, 0, data.length, 0, canOwn); + FS.close(stream); + FS.chmod(node, mode); + } + }, + createDevice(parent, name, input, output) { + var path = PATH.join2(typeof parent == 'string' ? parent : FS.getPath(parent), name); + var mode = FS_getMode(!!input, !!output); + if (!FS.createDevice.major) FS.createDevice.major = 64; + var dev = FS.makedev(FS.createDevice.major++, 0); + // Create a fake device that a set of stream ops to emulate + // the old behavior. + FS.registerDevice(dev, { + open(stream) { + stream.seekable = false; + }, + close(stream) { + // flush any pending line data + if (output?.buffer?.length) { + output(10); + } + }, + read(stream, buffer, offset, length, pos /* ignored */) { + var bytesRead = 0; + for (var i = 0; i < length; i++) { + var result; + try { + result = input(); + } catch (e) { + throw new FS.ErrnoError(29); + } + if (result === undefined && bytesRead === 0) { + throw new FS.ErrnoError(6); + } + if (result === null || result === undefined) break; + bytesRead++; + buffer[offset+i] = result; + } + if (bytesRead) { + stream.node.timestamp = Date.now(); + } + return bytesRead; + }, + write(stream, buffer, offset, length, pos) { + for (var i = 0; i < length; i++) { + try { + output(buffer[offset+i]); + } catch (e) { + throw new FS.ErrnoError(29); + } + } + if (length) { + stream.node.timestamp = Date.now(); + } + return i; + } + }); + return FS.mkdev(path, mode, dev); + }, + forceLoadFile(obj) { + if (obj.isDevice || obj.isFolder || obj.link || obj.contents) return true; + if (typeof XMLHttpRequest != 'undefined') { + throw new Error("Lazy loading should have been performed (contents set) in createLazyFile, but it was not. Lazy loading only works in web workers. Use --embed-file or --preload-file in emcc on the main thread."); + } else if (read_) { + // Command-line. + try { + // WARNING: Can't read binary files in V8's d8 or tracemonkey's js, as + // read() will try to parse UTF8. + obj.contents = intArrayFromString(read_(obj.url), true); + obj.usedBytes = obj.contents.length; + } catch (e) { + throw new FS.ErrnoError(29); + } + } else { + throw new Error('Cannot load without read() or XMLHttpRequest.'); + } + }, + createLazyFile(parent, name, url, canRead, canWrite) { + // Lazy chunked Uint8Array (implements get and length from Uint8Array). + // Actual getting is abstracted away for eventual reuse. + class LazyUint8Array { + constructor() { + this.lengthKnown = false; + this.chunks = []; // Loaded chunks. Index is the chunk number + } + get(idx) { + if (idx > this.length-1 || idx < 0) { + return undefined; + } + var chunkOffset = idx % this.chunkSize; + var chunkNum = (idx / this.chunkSize)|0; + return this.getter(chunkNum)[chunkOffset]; + } + setDataGetter(getter) { + this.getter = getter; + } + cacheLength() { + // Find length + var xhr = new XMLHttpRequest(); + xhr.open('HEAD', url, false); + xhr.send(null); + if (!(xhr.status >= 200 && xhr.status < 300 || xhr.status === 304)) throw new Error("Couldn't load " + url + ". Status: " + xhr.status); + var datalength = Number(xhr.getResponseHeader("Content-length")); + var header; + var hasByteServing = (header = xhr.getResponseHeader("Accept-Ranges")) && header === "bytes"; + var usesGzip = (header = xhr.getResponseHeader("Content-Encoding")) && header === "gzip"; + + var chunkSize = 1024*1024; // Chunk size in bytes + + if (!hasByteServing) chunkSize = datalength; + + // Function to get a range from the remote URL. + var doXHR = (from, to) => { + if (from > to) throw new Error("invalid range (" + from + ", " + to + ") or no bytes requested!"); + if (to > datalength-1) throw new Error("only " + datalength + " bytes available! programmer error!"); + + // TODO: Use mozResponseArrayBuffer, responseStream, etc. if available. + var xhr = new XMLHttpRequest(); + xhr.open('GET', url, false); + if (datalength !== chunkSize) xhr.setRequestHeader("Range", "bytes=" + from + "-" + to); + + // Some hints to the browser that we want binary data. + xhr.responseType = 'arraybuffer'; + if (xhr.overrideMimeType) { + xhr.overrideMimeType('text/plain; charset=x-user-defined'); + } + + xhr.send(null); + if (!(xhr.status >= 200 && xhr.status < 300 || xhr.status === 304)) throw new Error("Couldn't load " + url + ". Status: " + xhr.status); + if (xhr.response !== undefined) { + return new Uint8Array(/** @type{Array} */(xhr.response || [])); + } + return intArrayFromString(xhr.responseText || '', true); + }; + var lazyArray = this; + lazyArray.setDataGetter((chunkNum) => { + var start = chunkNum * chunkSize; + var end = (chunkNum+1) * chunkSize - 1; // including this byte + end = Math.min(end, datalength-1); // if datalength-1 is selected, this is the last block + if (typeof lazyArray.chunks[chunkNum] == 'undefined') { + lazyArray.chunks[chunkNum] = doXHR(start, end); + } + if (typeof lazyArray.chunks[chunkNum] == 'undefined') throw new Error('doXHR failed!'); + return lazyArray.chunks[chunkNum]; + }); + + if (usesGzip || !datalength) { + // if the server uses gzip or doesn't supply the length, we have to download the whole file to get the (uncompressed) length + chunkSize = datalength = 1; // this will force getter(0)/doXHR do download the whole file + datalength = this.getter(0).length; + chunkSize = datalength; + out("LazyFiles on gzip forces download of the whole file when length is accessed"); + } + + this._length = datalength; + this._chunkSize = chunkSize; + this.lengthKnown = true; + } + get length() { + if (!this.lengthKnown) { + this.cacheLength(); + } + return this._length; + } + get chunkSize() { + if (!this.lengthKnown) { + this.cacheLength(); + } + return this._chunkSize; + } + } + + if (typeof XMLHttpRequest != 'undefined') { + if (!ENVIRONMENT_IS_WORKER) throw 'Cannot do synchronous binary XHRs outside webworkers in modern browsers. Use --embed-file or --preload-file in emcc'; + var lazyArray = new LazyUint8Array(); + var properties = { isDevice: false, contents: lazyArray }; + } else { + var properties = { isDevice: false, url: url }; + } + + var node = FS.createFile(parent, name, properties, canRead, canWrite); + // This is a total hack, but I want to get this lazy file code out of the + // core of MEMFS. If we want to keep this lazy file concept I feel it should + // be its own thin LAZYFS proxying calls to MEMFS. + if (properties.contents) { + node.contents = properties.contents; + } else if (properties.url) { + node.contents = null; + node.url = properties.url; + } + // Add a function that defers querying the file size until it is asked the first time. + Object.defineProperties(node, { + usedBytes: { + get: function() { return this.contents.length; } + } + }); + // override each stream op with one that tries to force load the lazy file first + var stream_ops = {}; + var keys = Object.keys(node.stream_ops); + keys.forEach((key) => { + var fn = node.stream_ops[key]; + stream_ops[key] = (...args) => { + FS.forceLoadFile(node); + return fn(...args); + }; + }); + function writeChunks(stream, buffer, offset, length, position) { + var contents = stream.node.contents; + if (position >= contents.length) + return 0; + var size = Math.min(contents.length - position, length); + if (contents.slice) { // normal array + for (var i = 0; i < size; i++) { + buffer[offset + i] = contents[position + i]; + } + } else { + for (var i = 0; i < size; i++) { // LazyUint8Array from sync binary XHR + buffer[offset + i] = contents.get(position + i); + } + } + return size; + } + // use a custom read function + stream_ops.read = (stream, buffer, offset, length, position) => { + FS.forceLoadFile(node); + return writeChunks(stream, buffer, offset, length, position) + }; + // use a custom mmap function + stream_ops.mmap = (stream, length, position, prot, flags) => { + FS.forceLoadFile(node); + var ptr = mmapAlloc(length); + if (!ptr) { + throw new FS.ErrnoError(48); + } + writeChunks(stream, HEAP8, ptr, length, position); + return { ptr, allocated: true }; + }; + node.stream_ops = stream_ops; + return node; + }, + }; + + var SYSCALLS = { + DEFAULT_POLLMASK:5, + calculateAt(dirfd, path, allowEmpty) { + if (PATH.isAbs(path)) { + return path; + } + // relative path + var dir; + if (dirfd === -100) { + dir = FS.cwd(); + } else { + var dirstream = SYSCALLS.getStreamFromFD(dirfd); + dir = dirstream.path; + } + if (path.length == 0) { + if (!allowEmpty) { + throw new FS.ErrnoError(44);; + } + return dir; + } + return PATH.join2(dir, path); + }, + doStat(func, path, buf) { + var stat = func(path); + HEAP32[((buf)>>2)] = stat.dev; + HEAP32[(((buf)+(4))>>2)] = stat.mode; + HEAPU32[(((buf)+(8))>>2)] = stat.nlink; + HEAP32[(((buf)+(12))>>2)] = stat.uid; + HEAP32[(((buf)+(16))>>2)] = stat.gid; + HEAP32[(((buf)+(20))>>2)] = stat.rdev; + HEAP64[(((buf)+(24))>>3)] = BigInt(stat.size); + HEAP32[(((buf)+(32))>>2)] = 4096; + HEAP32[(((buf)+(36))>>2)] = stat.blocks; + var atime = stat.atime.getTime(); + var mtime = stat.mtime.getTime(); + var ctime = stat.ctime.getTime(); + HEAP64[(((buf)+(40))>>3)] = BigInt(Math.floor(atime / 1000)); + HEAPU32[(((buf)+(48))>>2)] = (atime % 1000) * 1000; + HEAP64[(((buf)+(56))>>3)] = BigInt(Math.floor(mtime / 1000)); + HEAPU32[(((buf)+(64))>>2)] = (mtime % 1000) * 1000; + HEAP64[(((buf)+(72))>>3)] = BigInt(Math.floor(ctime / 1000)); + HEAPU32[(((buf)+(80))>>2)] = (ctime % 1000) * 1000; + HEAP64[(((buf)+(88))>>3)] = BigInt(stat.ino); + return 0; + }, + doMsync(addr, stream, len, flags, offset) { + if (!FS.isFile(stream.node.mode)) { + throw new FS.ErrnoError(43); + } + if (flags & 2) { + // MAP_PRIVATE calls need not to be synced back to underlying fs + return 0; + } + var buffer = HEAPU8.slice(addr, addr + len); + FS.msync(stream, buffer, offset, len, flags); + }, + varargs:undefined, + get() { + // the `+` prepended here is necessary to convince the JSCompiler that varargs is indeed a number. + var ret = HEAP32[((+SYSCALLS.varargs)>>2)]; + SYSCALLS.varargs += 4; + return ret; + }, + getp() { return SYSCALLS.get() }, + getStr(ptr) { + var ret = UTF8ToString(ptr); + return ret; + }, + getStreamFromFD(fd) { + var stream = FS.getStreamChecked(fd); + return stream; + }, + }; + function ___syscall_faccessat(dirfd, path, amode, flags) { + try { + + path = SYSCALLS.getStr(path); + path = SYSCALLS.calculateAt(dirfd, path); + if (amode & ~7) { + // need a valid mode + return -28; + } + var lookup = FS.lookupPath(path, { follow: true }); + var node = lookup.node; + if (!node) { + return -44; + } + var perms = ''; + if (amode & 4) perms += 'r'; + if (amode & 2) perms += 'w'; + if (amode & 1) perms += 'x'; + if (perms /* otherwise, they've just passed F_OK */ && FS.nodePermissions(node, perms)) { + return -2; + } + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + var ___syscall_fadvise64 = (fd, offset, len, advice) => { + return 0; // your advice is important to us (but we can't use it) + }; + + function ___syscall_fcntl64(fd, cmd, varargs) { + SYSCALLS.varargs = varargs; + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + switch (cmd) { + case 0: { + var arg = SYSCALLS.get(); + if (arg < 0) { + return -28; + } + while (FS.streams[arg]) { + arg++; + } + var newStream; + newStream = FS.dupStream(stream, arg); + return newStream.fd; + } + case 1: + case 2: + return 0; // FD_CLOEXEC makes no sense for a single process. + case 3: + return stream.flags; + case 4: { + var arg = SYSCALLS.get(); + stream.flags |= arg; + return 0; + } + case 12: { + var arg = SYSCALLS.getp(); + var offset = 0; + // We're always unlocked. + HEAP16[(((arg)+(offset))>>1)] = 2; + return 0; + } + case 13: + case 14: + return 0; // Pretend that the locking is successful. + } + return -28; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_fstat64(fd, buf) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + return SYSCALLS.doStat(FS.stat, stream.path, buf); + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_statfs64(path, size, buf) { + try { + + path = SYSCALLS.getStr(path); + // NOTE: None of the constants here are true. We're just returning safe and + // sane values. + HEAP32[(((buf)+(4))>>2)] = 4096; + HEAP32[(((buf)+(40))>>2)] = 4096; + HEAP32[(((buf)+(8))>>2)] = 1000000; + HEAP32[(((buf)+(12))>>2)] = 500000; + HEAP32[(((buf)+(16))>>2)] = 500000; + HEAP32[(((buf)+(20))>>2)] = FS.nextInode; + HEAP32[(((buf)+(24))>>2)] = 1000000; + HEAP32[(((buf)+(28))>>2)] = 42; + HEAP32[(((buf)+(44))>>2)] = 2; // ST_NOSUID + HEAP32[(((buf)+(36))>>2)] = 255; + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_fstatfs64(fd, size, buf) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + return ___syscall_statfs64(0, size, buf); + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + var MAX_INT53 = 9007199254740992; + + var MIN_INT53 = -9007199254740992; + var bigintToI53Checked = (num) => (num < MIN_INT53 || num > MAX_INT53) ? NaN : Number(num); + function ___syscall_ftruncate64(fd, length) { + length = bigintToI53Checked(length); + + + try { + + if (isNaN(length)) return 61; + FS.ftruncate(fd, length); + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + ; + } + + + var stringToUTF8 = (str, outPtr, maxBytesToWrite) => { + return stringToUTF8Array(str, HEAPU8, outPtr, maxBytesToWrite); + }; + function ___syscall_getcwd(buf, size) { + try { + + if (size === 0) return -28; + var cwd = FS.cwd(); + var cwdLengthInBytes = lengthBytesUTF8(cwd) + 1; + if (size < cwdLengthInBytes) return -68; + stringToUTF8(cwd, buf, size); + return cwdLengthInBytes; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + + function ___syscall_getdents64(fd, dirp, count) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd) + stream.getdents ||= FS.readdir(stream.path); + + var struct_size = 280; + var pos = 0; + var off = FS.llseek(stream, 0, 1); + + var idx = Math.floor(off / struct_size); + + while (idx < stream.getdents.length && pos + struct_size <= count) { + var id; + var type; + var name = stream.getdents[idx]; + if (name === '.') { + id = stream.node.id; + type = 4; // DT_DIR + } + else if (name === '..') { + var lookup = FS.lookupPath(stream.path, { parent: true }); + id = lookup.node.id; + type = 4; // DT_DIR + } + else { + var child = FS.lookupNode(stream.node, name); + id = child.id; + type = FS.isChrdev(child.mode) ? 2 : // DT_CHR, character device. + FS.isDir(child.mode) ? 4 : // DT_DIR, directory. + FS.isLink(child.mode) ? 10 : // DT_LNK, symbolic link. + 8; // DT_REG, regular file. + } + HEAP64[((dirp + pos)>>3)] = BigInt(id); + HEAP64[(((dirp + pos)+(8))>>3)] = BigInt((idx + 1) * struct_size); + HEAP16[(((dirp + pos)+(16))>>1)] = 280; + HEAP8[(dirp + pos)+(18)] = type; + stringToUTF8(name, dirp + pos + 19, 256); + pos += struct_size; + idx += 1; + } + FS.llseek(stream, idx * struct_size, 0); + return pos; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_ioctl(fd, op, varargs) { + SYSCALLS.varargs = varargs; + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + switch (op) { + case 21509: { + if (!stream.tty) return -59; + return 0; + } + case 21505: { + if (!stream.tty) return -59; + if (stream.tty.ops.ioctl_tcgets) { + var termios = stream.tty.ops.ioctl_tcgets(stream); + var argp = SYSCALLS.getp(); + HEAP32[((argp)>>2)] = termios.c_iflag || 0; + HEAP32[(((argp)+(4))>>2)] = termios.c_oflag || 0; + HEAP32[(((argp)+(8))>>2)] = termios.c_cflag || 0; + HEAP32[(((argp)+(12))>>2)] = termios.c_lflag || 0; + for (var i = 0; i < 32; i++) { + HEAP8[(argp + i)+(17)] = termios.c_cc[i] || 0; + } + return 0; + } + return 0; + } + case 21510: + case 21511: + case 21512: { + if (!stream.tty) return -59; + return 0; // no-op, not actually adjusting terminal settings + } + case 21506: + case 21507: + case 21508: { + if (!stream.tty) return -59; + if (stream.tty.ops.ioctl_tcsets) { + var argp = SYSCALLS.getp(); + var c_iflag = HEAP32[((argp)>>2)]; + var c_oflag = HEAP32[(((argp)+(4))>>2)]; + var c_cflag = HEAP32[(((argp)+(8))>>2)]; + var c_lflag = HEAP32[(((argp)+(12))>>2)]; + var c_cc = [] + for (var i = 0; i < 32; i++) { + c_cc.push(HEAP8[(argp + i)+(17)]); + } + return stream.tty.ops.ioctl_tcsets(stream.tty, op, { c_iflag, c_oflag, c_cflag, c_lflag, c_cc }); + } + return 0; // no-op, not actually adjusting terminal settings + } + case 21519: { + if (!stream.tty) return -59; + var argp = SYSCALLS.getp(); + HEAP32[((argp)>>2)] = 0; + return 0; + } + case 21520: { + if (!stream.tty) return -59; + return -28; // not supported + } + case 21531: { + var argp = SYSCALLS.getp(); + return FS.ioctl(stream, op, argp); + } + case 21523: { + // TODO: in theory we should write to the winsize struct that gets + // passed in, but for now musl doesn't read anything on it + if (!stream.tty) return -59; + if (stream.tty.ops.ioctl_tiocgwinsz) { + var winsize = stream.tty.ops.ioctl_tiocgwinsz(stream.tty); + var argp = SYSCALLS.getp(); + HEAP16[((argp)>>1)] = winsize[0]; + HEAP16[(((argp)+(2))>>1)] = winsize[1]; + } + return 0; + } + case 21524: { + // TODO: technically, this ioctl call should change the window size. + // but, since emscripten doesn't have any concept of a terminal window + // yet, we'll just silently throw it away as we do TIOCGWINSZ + if (!stream.tty) return -59; + return 0; + } + case 21515: { + if (!stream.tty) return -59; + return 0; + } + default: return -28; // not supported + } + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_lstat64(path, buf) { + try { + + path = SYSCALLS.getStr(path); + return SYSCALLS.doStat(FS.lstat, path, buf); + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_newfstatat(dirfd, path, buf, flags) { + try { + + path = SYSCALLS.getStr(path); + var nofollow = flags & 256; + var allowEmpty = flags & 4096; + flags = flags & (~6400); + path = SYSCALLS.calculateAt(dirfd, path, allowEmpty); + return SYSCALLS.doStat(nofollow ? FS.lstat : FS.stat, path, buf); + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_openat(dirfd, path, flags, varargs) { + SYSCALLS.varargs = varargs; + try { + + path = SYSCALLS.getStr(path); + path = SYSCALLS.calculateAt(dirfd, path); + var mode = varargs ? SYSCALLS.get() : 0; + return FS.open(path, flags, mode).fd; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + + + function ___syscall_readlinkat(dirfd, path, buf, bufsize) { + try { + + path = SYSCALLS.getStr(path); + path = SYSCALLS.calculateAt(dirfd, path); + if (bufsize <= 0) return -28; + var ret = FS.readlink(path); + + var len = Math.min(bufsize, lengthBytesUTF8(ret)); + var endChar = HEAP8[buf+len]; + stringToUTF8(ret, buf, bufsize+1); + // readlink is one of the rare functions that write out a C string, but does never append a null to the output buffer(!) + // stringToUTF8() always appends a null byte, so restore the character under the null byte after the write. + HEAP8[buf+len] = endChar; + return len; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_stat64(path, buf) { + try { + + path = SYSCALLS.getStr(path); + return SYSCALLS.doStat(FS.stat, path, buf); + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + function ___syscall_unlinkat(dirfd, path, flags) { + try { + + path = SYSCALLS.getStr(path); + path = SYSCALLS.calculateAt(dirfd, path); + if (flags === 0) { + FS.unlink(path); + } else if (flags === 512) { + FS.rmdir(path); + } else { + abort('Invalid flags passed to unlinkat'); + } + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + } + + var nowIsMonotonic = 1; + var __emscripten_get_now_is_monotonic = () => nowIsMonotonic; + + var isLeapYear = (year) => year%4 === 0 && (year%100 !== 0 || year%400 === 0); + + var MONTH_DAYS_LEAP_CUMULATIVE = [0,31,60,91,121,152,182,213,244,274,305,335]; + + var MONTH_DAYS_REGULAR_CUMULATIVE = [0,31,59,90,120,151,181,212,243,273,304,334]; + var ydayFromDate = (date) => { + var leap = isLeapYear(date.getFullYear()); + var monthDaysCumulative = (leap ? MONTH_DAYS_LEAP_CUMULATIVE : MONTH_DAYS_REGULAR_CUMULATIVE); + var yday = monthDaysCumulative[date.getMonth()] + date.getDate() - 1; // -1 since it's days since Jan 1 + + return yday; + }; + + function __localtime_js(time, tmPtr) { + time = bigintToI53Checked(time); + + + var date = new Date(time*1000); + HEAP32[((tmPtr)>>2)] = date.getSeconds(); + HEAP32[(((tmPtr)+(4))>>2)] = date.getMinutes(); + HEAP32[(((tmPtr)+(8))>>2)] = date.getHours(); + HEAP32[(((tmPtr)+(12))>>2)] = date.getDate(); + HEAP32[(((tmPtr)+(16))>>2)] = date.getMonth(); + HEAP32[(((tmPtr)+(20))>>2)] = date.getFullYear()-1900; + HEAP32[(((tmPtr)+(24))>>2)] = date.getDay(); + + var yday = ydayFromDate(date)|0; + HEAP32[(((tmPtr)+(28))>>2)] = yday; + HEAP32[(((tmPtr)+(36))>>2)] = -(date.getTimezoneOffset() * 60); + + // Attention: DST is in December in South, and some regions don't have DST at all. + var start = new Date(date.getFullYear(), 0, 1); + var summerOffset = new Date(date.getFullYear(), 6, 1).getTimezoneOffset(); + var winterOffset = start.getTimezoneOffset(); + var dst = (summerOffset != winterOffset && date.getTimezoneOffset() == Math.min(winterOffset, summerOffset))|0; + HEAP32[(((tmPtr)+(32))>>2)] = dst; + ; + } + + + + + + + function __mmap_js(len, prot, flags, fd, offset, allocated, addr) { + offset = bigintToI53Checked(offset); + + + try { + + if (isNaN(offset)) return 61; + var stream = SYSCALLS.getStreamFromFD(fd); + var res = FS.mmap(stream, len, offset, prot, flags); + var ptr = res.ptr; + HEAP32[((allocated)>>2)] = res.allocated; + HEAPU32[((addr)>>2)] = ptr; + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + ; + } + + + function __munmap_js(addr, len, prot, flags, fd, offset) { + offset = bigintToI53Checked(offset); + + + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + if (prot & 2) { + SYSCALLS.doMsync(addr, stream, len, flags, offset); + } + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return -e.errno; + } + ; + } + + var __tzset_js = (timezone, daylight, std_name, dst_name) => { + // TODO: Use (malleable) environment variables instead of system settings. + var currentYear = new Date().getFullYear(); + var winter = new Date(currentYear, 0, 1); + var summer = new Date(currentYear, 6, 1); + var winterOffset = winter.getTimezoneOffset(); + var summerOffset = summer.getTimezoneOffset(); + + // Local standard timezone offset. Local standard time is not adjusted for + // daylight savings. This code uses the fact that getTimezoneOffset returns + // a greater value during Standard Time versus Daylight Saving Time (DST). + // Thus it determines the expected output during Standard Time, and it + // compares whether the output of the given date the same (Standard) or less + // (DST). + var stdTimezoneOffset = Math.max(winterOffset, summerOffset); + + // timezone is specified as seconds west of UTC ("The external variable + // `timezone` shall be set to the difference, in seconds, between + // Coordinated Universal Time (UTC) and local standard time."), the same + // as returned by stdTimezoneOffset. + // See http://pubs.opengroup.org/onlinepubs/009695399/functions/tzset.html + HEAPU32[((timezone)>>2)] = stdTimezoneOffset * 60; + + HEAP32[((daylight)>>2)] = Number(winterOffset != summerOffset); + + function extractZone(date) { + var match = date.toTimeString().match(/\(([A-Za-z ]+)\)$/); + return match ? match[1] : "GMT"; + }; + var winterName = extractZone(winter); + var summerName = extractZone(summer); + if (summerOffset < winterOffset) { + // Northern hemisphere + stringToUTF8(winterName, std_name, 7); + stringToUTF8(summerName, dst_name, 7); + } else { + stringToUTF8(winterName, dst_name, 7); + stringToUTF8(summerName, std_name, 7); + } + }; + + var _abort = () => { + abort(''); + }; + + var _emscripten_date_now = () => Date.now(); + + + var runtimeKeepaliveCounter = 0; + var keepRuntimeAlive = () => noExitRuntime || runtimeKeepaliveCounter > 0; + var _proc_exit = (code) => { + EXITSTATUS = code; + if (!keepRuntimeAlive()) { + Module['onExit']?.(code); + ABORT = true; + } + quit_(code, new ExitStatus(code)); + }; + + /** @suppress {duplicate } */ + /** @param {boolean|number=} implicit */ + var exitJS = (status, implicit) => { + EXITSTATUS = status; + + if (!keepRuntimeAlive()) { + exitRuntime(); + } + + _proc_exit(status); + }; + var _exit = exitJS; + + var __emscripten_runtime_keepalive_clear = () => { + noExitRuntime = false; + runtimeKeepaliveCounter = 0; + }; + + var _emscripten_force_exit = (status) => { + __emscripten_runtime_keepalive_clear(); + _exit(status); + }; + Module['_emscripten_force_exit'] = _emscripten_force_exit; + + var getHeapMax = () => + // Stay one Wasm page short of 4GB: while e.g. Chrome is able to allocate + // full 4GB Wasm memories, the size will wrap back to 0 bytes in Wasm side + // for any code that deals with heap sizes, which would require special + // casing all heap size related code to treat 0 specially. + 2147483648; + var _emscripten_get_heap_max = () => getHeapMax(); + + var _emscripten_get_now; + // Modern environment where performance.now() is supported: + // N.B. a shorter form "_emscripten_get_now = performance.now;" is + // unfortunately not allowed even in current browsers (e.g. FF Nightly 75). + _emscripten_get_now = () => performance.now(); + ; + + var _emscripten_get_now_res = () => { // return resolution of get_now, in nanoseconds + if (ENVIRONMENT_IS_NODE) { + return 1; // nanoseconds + } + // Modern environment where performance.now() is supported: + return 1000; // microseconds (1/1000 of a millisecond) + }; + + + var growMemory = (size) => { + var b = wasmMemory.buffer; + var pages = (size - b.byteLength + 65535) / 65536; + try { + // round size grow request up to wasm page size (fixed 64KB per spec) + wasmMemory.grow(pages); // .grow() takes a delta compared to the previous size + updateMemoryViews(); + return 1 /*success*/; + } catch(e) { + } + // implicit 0 return to save code size (caller will cast "undefined" into 0 + // anyhow) + }; + var _emscripten_resize_heap = (requestedSize) => { + var oldSize = HEAPU8.length; + // With CAN_ADDRESS_2GB or MEMORY64, pointers are already unsigned. + requestedSize >>>= 0; + // With multithreaded builds, races can happen (another thread might increase the size + // in between), so return a failure, and let the caller retry. + + // Memory resize rules: + // 1. Always increase heap size to at least the requested size, rounded up + // to next page multiple. + // 2a. If MEMORY_GROWTH_LINEAR_STEP == -1, excessively resize the heap + // geometrically: increase the heap size according to + // MEMORY_GROWTH_GEOMETRIC_STEP factor (default +20%), At most + // overreserve by MEMORY_GROWTH_GEOMETRIC_CAP bytes (default 96MB). + // 2b. If MEMORY_GROWTH_LINEAR_STEP != -1, excessively resize the heap + // linearly: increase the heap size by at least + // MEMORY_GROWTH_LINEAR_STEP bytes. + // 3. Max size for the heap is capped at 2048MB-WASM_PAGE_SIZE, or by + // MAXIMUM_MEMORY, or by ASAN limit, depending on which is smallest + // 4. If we were unable to allocate as much memory, it may be due to + // over-eager decision to excessively reserve due to (3) above. + // Hence if an allocation fails, cut down on the amount of excess + // growth, in an attempt to succeed to perform a smaller allocation. + + // A limit is set for how much we can grow. We should not exceed that + // (the wasm binary specifies it, so if we tried, we'd fail anyhow). + var maxHeapSize = getHeapMax(); + if (requestedSize > maxHeapSize) { + return false; + } + + var alignUp = (x, multiple) => x + (multiple - x % multiple) % multiple; + + // Loop through potential heap size increases. If we attempt a too eager + // reservation that fails, cut down on the attempted size and reserve a + // smaller bump instead. (max 3 times, chosen somewhat arbitrarily) + for (var cutDown = 1; cutDown <= 4; cutDown *= 2) { + var overGrownHeapSize = oldSize * (1 + 0.2 / cutDown); // ensure geometric growth + // but limit overreserving (default to capping at +96MB overgrowth at most) + overGrownHeapSize = Math.min(overGrownHeapSize, requestedSize + 100663296 ); + + var newSize = Math.min(maxHeapSize, alignUp(Math.max(requestedSize, overGrownHeapSize), 65536)); + + var replacement = growMemory(newSize); + if (replacement) { + + return true; + } + } + return false; + }; + + var ENV = { + }; + + var getExecutableName = () => { + return thisProgram || './this.program'; + }; + var getEnvStrings = () => { + if (!getEnvStrings.strings) { + // Default values. + // Browser language detection #8751 + var lang = ((typeof navigator == 'object' && navigator.languages && navigator.languages[0]) || 'C').replace('-', '_') + '.UTF-8'; + var env = { + 'USER': 'web_user', + 'LOGNAME': 'web_user', + 'PATH': '/', + 'PWD': '/', + 'HOME': '/home/web_user', + 'LANG': lang, + '_': getExecutableName() + }; + // Apply the user-provided values, if any. + for (var x in ENV) { + // x is a key in ENV; if ENV[x] is undefined, that means it was + // explicitly set to be so. We allow user code to do that to + // force variables with default values to remain unset. + if (ENV[x] === undefined) delete env[x]; + else env[x] = ENV[x]; + } + var strings = []; + for (var x in env) { + strings.push(`${x}=${env[x]}`); + } + getEnvStrings.strings = strings; + } + return getEnvStrings.strings; + }; + + var stringToAscii = (str, buffer) => { + for (var i = 0; i < str.length; ++i) { + HEAP8[buffer++] = str.charCodeAt(i); + } + // Null-terminate the string + HEAP8[buffer] = 0; + }; + var _environ_get = (__environ, environ_buf) => { + var bufSize = 0; + getEnvStrings().forEach((string, i) => { + var ptr = environ_buf + bufSize; + HEAPU32[(((__environ)+(i*4))>>2)] = ptr; + stringToAscii(string, ptr); + bufSize += string.length + 1; + }); + return 0; + }; + + var _environ_sizes_get = (penviron_count, penviron_buf_size) => { + var strings = getEnvStrings(); + HEAPU32[((penviron_count)>>2)] = strings.length; + var bufSize = 0; + strings.forEach((string) => bufSize += string.length + 1); + HEAPU32[((penviron_buf_size)>>2)] = bufSize; + return 0; + }; + + + function _fd_close(fd) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + FS.close(stream); + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return e.errno; + } + } + + /** @param {number=} offset */ + var doReadv = (stream, iov, iovcnt, offset) => { + var ret = 0; + for (var i = 0; i < iovcnt; i++) { + var ptr = HEAPU32[((iov)>>2)]; + var len = HEAPU32[(((iov)+(4))>>2)]; + iov += 8; + var curr = FS.read(stream, HEAP8, ptr, len, offset); + if (curr < 0) return -1; + ret += curr; + if (curr < len) break; // nothing more to read + if (typeof offset !== 'undefined') { + offset += curr; + } + } + return ret; + }; + + + function _fd_pread(fd, iov, iovcnt, offset, pnum) { + offset = bigintToI53Checked(offset); + + + try { + + if (isNaN(offset)) return 61; + var stream = SYSCALLS.getStreamFromFD(fd) + var num = doReadv(stream, iov, iovcnt, offset); + HEAPU32[((pnum)>>2)] = num; + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return e.errno; + } + ; + } + + + function _fd_read(fd, iov, iovcnt, pnum) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + var num = doReadv(stream, iov, iovcnt); + HEAPU32[((pnum)>>2)] = num; + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return e.errno; + } + } + + + function _fd_seek(fd, offset, whence, newOffset) { + offset = bigintToI53Checked(offset); + + + try { + + if (isNaN(offset)) return 61; + var stream = SYSCALLS.getStreamFromFD(fd); + FS.llseek(stream, offset, whence); + HEAP64[((newOffset)>>3)] = BigInt(stream.position); + if (stream.getdents && offset === 0 && whence === 0) stream.getdents = null; // reset readdir state + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return e.errno; + } + ; + } + + /** @param {number=} offset */ + var doWritev = (stream, iov, iovcnt, offset) => { + var ret = 0; + for (var i = 0; i < iovcnt; i++) { + var ptr = HEAPU32[((iov)>>2)]; + var len = HEAPU32[(((iov)+(4))>>2)]; + iov += 8; + var curr = FS.write(stream, HEAP8, ptr, len, offset); + if (curr < 0) return -1; + ret += curr; + if (typeof offset !== 'undefined') { + offset += curr; + } + } + return ret; + }; + + function _fd_write(fd, iov, iovcnt, pnum) { + try { + + var stream = SYSCALLS.getStreamFromFD(fd); + var num = doWritev(stream, iov, iovcnt); + HEAPU32[((pnum)>>2)] = num; + return 0; + } catch (e) { + if (typeof FS == 'undefined' || !(e.name === 'ErrnoError')) throw e; + return e.errno; + } + } + + var DOTNET = { + setup:function setup(emscriptenBuildOptions) { + // USE_PTHREADS is emscripten's define symbol, which is passed to acorn optimizer, so we could use it here + const modulePThread = {}; + const ENVIRONMENT_IS_PTHREAD = false; + const dotnet_replacements = { + fetch: globalThis.fetch, + ENVIRONMENT_IS_WORKER, + require, + modulePThread, + scriptDirectory, + }; + + ENVIRONMENT_IS_WORKER = dotnet_replacements.ENVIRONMENT_IS_WORKER; + Module.__dotnet_runtime.initializeReplacements(dotnet_replacements); + noExitRuntime = dotnet_replacements.noExitRuntime; + fetch = dotnet_replacements.fetch; + require = dotnet_replacements.require; + _scriptDir = __dirname = scriptDirectory = dotnet_replacements.scriptDirectory; + Module.__dotnet_runtime.passEmscriptenInternals({ + isPThread: ENVIRONMENT_IS_PTHREAD, + quit_, ExitStatus, + updateMemoryViews, + getMemory: () => { return wasmMemory; }, + getWasmIndirectFunctionTable: () => { return wasmTable; }, + }, emscriptenBuildOptions); + + Module.__dotnet_runtime.configureEmscriptenStartup(Module); + }, + }; + function _mono_interp_flush_jitcall_queue( + ) { + return {runtime_idx:12};//mono_interp_flush_jitcall_queue + } + + function _mono_interp_invoke_wasm_jit_call_trampoline( + ) { + return {runtime_idx:11};//mono_interp_invoke_wasm_jit_call_trampoline + } + + function _mono_interp_jit_wasm_entry_trampoline( + ) { + return {runtime_idx:9};//mono_interp_jit_wasm_entry_trampoline + } + + function _mono_interp_jit_wasm_jit_call_trampoline( + ) { + return {runtime_idx:10};//mono_interp_jit_wasm_jit_call_trampoline + } + + function _mono_interp_record_interp_entry( + ) { + return {runtime_idx:8};//mono_interp_record_interp_entry + } + + function _mono_interp_tier_prepare_jiterpreter( + ) { + return {runtime_idx:7};//mono_interp_tier_prepare_jiterpreter + } + + function _mono_wasm_bind_js_import_ST( + ) { + return {runtime_idx:22};//mono_wasm_bind_js_import_ST + } + + function _mono_wasm_browser_entropy( + ) { + return {runtime_idx:18};//mono_wasm_browser_entropy + } + + function _mono_wasm_cancel_promise( + ) { + return {runtime_idx:26};//mono_wasm_cancel_promise + } + + function _mono_wasm_console_clear( + ) { + return {runtime_idx:20};//mono_wasm_console_clear + } + + function _mono_wasm_free_method_data( + ) { + return {runtime_idx:13};//mono_wasm_free_method_data + } + + function _mono_wasm_get_locale_info( + ) { + return {runtime_idx:27};//mono_wasm_get_locale_info + } + + function _mono_wasm_invoke_js_function( + ) { + return {runtime_idx:23};//mono_wasm_invoke_js_function + } + + function _mono_wasm_invoke_jsimport_ST( + ) { + return {runtime_idx:24};//mono_wasm_invoke_jsimport_ST + } + + function _mono_wasm_process_current_pid( + ) { + return {runtime_idx:19};//mono_wasm_process_current_pid + } + + function _mono_wasm_release_cs_owned_object( + ) { + return {runtime_idx:21};//mono_wasm_release_cs_owned_object + } + + function _mono_wasm_resolve_or_reject_promise( + ) { + return {runtime_idx:25};//mono_wasm_resolve_or_reject_promise + } + + function _mono_wasm_schedule_timer( + ) { + return {runtime_idx:0};//mono_wasm_schedule_timer + } + + function _mono_wasm_set_entrypoint_breakpoint( + ) { + return {runtime_idx:17};//mono_wasm_set_entrypoint_breakpoint + } + + function _mono_wasm_trace_logger( + ) { + return {runtime_idx:16};//mono_wasm_trace_logger + } + + function _schedule_background_exec( + ) { + return {runtime_idx:6};//schedule_background_exec + } + + + var arraySum = (array, index) => { + var sum = 0; + for (var i = 0; i <= index; sum += array[i++]) { + // no-op + } + return sum; + }; + + + var MONTH_DAYS_LEAP = [31,29,31,30,31,30,31,31,30,31,30,31]; + + var MONTH_DAYS_REGULAR = [31,28,31,30,31,30,31,31,30,31,30,31]; + var addDays = (date, days) => { + var newDate = new Date(date.getTime()); + while (days > 0) { + var leap = isLeapYear(newDate.getFullYear()); + var currentMonth = newDate.getMonth(); + var daysInCurrentMonth = (leap ? MONTH_DAYS_LEAP : MONTH_DAYS_REGULAR)[currentMonth]; + + if (days > daysInCurrentMonth-newDate.getDate()) { + // we spill over to next month + days -= (daysInCurrentMonth-newDate.getDate()+1); + newDate.setDate(1); + if (currentMonth < 11) { + newDate.setMonth(currentMonth+1) + } else { + newDate.setMonth(0); + newDate.setFullYear(newDate.getFullYear()+1); + } + } else { + // we stay in current month + newDate.setDate(newDate.getDate()+days); + return newDate; + } + } + + return newDate; + }; + + + + + var writeArrayToMemory = (array, buffer) => { + HEAP8.set(array, buffer); + }; + + var _strftime = (s, maxsize, format, tm) => { + // size_t strftime(char *restrict s, size_t maxsize, const char *restrict format, const struct tm *restrict timeptr); + // http://pubs.opengroup.org/onlinepubs/009695399/functions/strftime.html + + var tm_zone = HEAPU32[(((tm)+(40))>>2)]; + + var date = { + tm_sec: HEAP32[((tm)>>2)], + tm_min: HEAP32[(((tm)+(4))>>2)], + tm_hour: HEAP32[(((tm)+(8))>>2)], + tm_mday: HEAP32[(((tm)+(12))>>2)], + tm_mon: HEAP32[(((tm)+(16))>>2)], + tm_year: HEAP32[(((tm)+(20))>>2)], + tm_wday: HEAP32[(((tm)+(24))>>2)], + tm_yday: HEAP32[(((tm)+(28))>>2)], + tm_isdst: HEAP32[(((tm)+(32))>>2)], + tm_gmtoff: HEAP32[(((tm)+(36))>>2)], + tm_zone: tm_zone ? UTF8ToString(tm_zone) : '' + }; + + + var pattern = UTF8ToString(format); + + // expand format + var EXPANSION_RULES_1 = { + '%c': '%a %b %d %H:%M:%S %Y', // Replaced by the locale's appropriate date and time representation - e.g., Mon Aug 3 14:02:01 2013 + '%D': '%m/%d/%y', // Equivalent to %m / %d / %y + '%F': '%Y-%m-%d', // Equivalent to %Y - %m - %d + '%h': '%b', // Equivalent to %b + '%r': '%I:%M:%S %p', // Replaced by the time in a.m. and p.m. notation + '%R': '%H:%M', // Replaced by the time in 24-hour notation + '%T': '%H:%M:%S', // Replaced by the time + '%x': '%m/%d/%y', // Replaced by the locale's appropriate date representation + '%X': '%H:%M:%S', // Replaced by the locale's appropriate time representation + // Modified Conversion Specifiers + '%Ec': '%c', // Replaced by the locale's alternative appropriate date and time representation. + '%EC': '%C', // Replaced by the name of the base year (period) in the locale's alternative representation. + '%Ex': '%m/%d/%y', // Replaced by the locale's alternative date representation. + '%EX': '%H:%M:%S', // Replaced by the locale's alternative time representation. + '%Ey': '%y', // Replaced by the offset from %EC (year only) in the locale's alternative representation. + '%EY': '%Y', // Replaced by the full alternative year representation. + '%Od': '%d', // Replaced by the day of the month, using the locale's alternative numeric symbols, filled as needed with leading zeros if there is any alternative symbol for zero; otherwise, with leading characters. + '%Oe': '%e', // Replaced by the day of the month, using the locale's alternative numeric symbols, filled as needed with leading characters. + '%OH': '%H', // Replaced by the hour (24-hour clock) using the locale's alternative numeric symbols. + '%OI': '%I', // Replaced by the hour (12-hour clock) using the locale's alternative numeric symbols. + '%Om': '%m', // Replaced by the month using the locale's alternative numeric symbols. + '%OM': '%M', // Replaced by the minutes using the locale's alternative numeric symbols. + '%OS': '%S', // Replaced by the seconds using the locale's alternative numeric symbols. + '%Ou': '%u', // Replaced by the weekday as a number in the locale's alternative representation (Monday=1). + '%OU': '%U', // Replaced by the week number of the year (Sunday as the first day of the week, rules corresponding to %U ) using the locale's alternative numeric symbols. + '%OV': '%V', // Replaced by the week number of the year (Monday as the first day of the week, rules corresponding to %V ) using the locale's alternative numeric symbols. + '%Ow': '%w', // Replaced by the number of the weekday (Sunday=0) using the locale's alternative numeric symbols. + '%OW': '%W', // Replaced by the week number of the year (Monday as the first day of the week) using the locale's alternative numeric symbols. + '%Oy': '%y', // Replaced by the year (offset from %C ) using the locale's alternative numeric symbols. + }; + for (var rule in EXPANSION_RULES_1) { + pattern = pattern.replace(new RegExp(rule, 'g'), EXPANSION_RULES_1[rule]); + } + + var WEEKDAYS = ['Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday']; + var MONTHS = ['January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December']; + + function leadingSomething(value, digits, character) { + var str = typeof value == 'number' ? value.toString() : (value || ''); + while (str.length < digits) { + str = character[0]+str; + } + return str; + } + + function leadingNulls(value, digits) { + return leadingSomething(value, digits, '0'); + } + + function compareByDay(date1, date2) { + function sgn(value) { + return value < 0 ? -1 : (value > 0 ? 1 : 0); + } + + var compare; + if ((compare = sgn(date1.getFullYear()-date2.getFullYear())) === 0) { + if ((compare = sgn(date1.getMonth()-date2.getMonth())) === 0) { + compare = sgn(date1.getDate()-date2.getDate()); + } + } + return compare; + } + + function getFirstWeekStartDate(janFourth) { + switch (janFourth.getDay()) { + case 0: // Sunday + return new Date(janFourth.getFullYear()-1, 11, 29); + case 1: // Monday + return janFourth; + case 2: // Tuesday + return new Date(janFourth.getFullYear(), 0, 3); + case 3: // Wednesday + return new Date(janFourth.getFullYear(), 0, 2); + case 4: // Thursday + return new Date(janFourth.getFullYear(), 0, 1); + case 5: // Friday + return new Date(janFourth.getFullYear()-1, 11, 31); + case 6: // Saturday + return new Date(janFourth.getFullYear()-1, 11, 30); + } + } + + function getWeekBasedYear(date) { + var thisDate = addDays(new Date(date.tm_year+1900, 0, 1), date.tm_yday); + + var janFourthThisYear = new Date(thisDate.getFullYear(), 0, 4); + var janFourthNextYear = new Date(thisDate.getFullYear()+1, 0, 4); + + var firstWeekStartThisYear = getFirstWeekStartDate(janFourthThisYear); + var firstWeekStartNextYear = getFirstWeekStartDate(janFourthNextYear); + + if (compareByDay(firstWeekStartThisYear, thisDate) <= 0) { + // this date is after the start of the first week of this year + if (compareByDay(firstWeekStartNextYear, thisDate) <= 0) { + return thisDate.getFullYear()+1; + } + return thisDate.getFullYear(); + } + return thisDate.getFullYear()-1; + } + + var EXPANSION_RULES_2 = { + '%a': (date) => WEEKDAYS[date.tm_wday].substring(0,3) , + '%A': (date) => WEEKDAYS[date.tm_wday], + '%b': (date) => MONTHS[date.tm_mon].substring(0,3), + '%B': (date) => MONTHS[date.tm_mon], + '%C': (date) => { + var year = date.tm_year+1900; + return leadingNulls((year/100)|0,2); + }, + '%d': (date) => leadingNulls(date.tm_mday, 2), + '%e': (date) => leadingSomething(date.tm_mday, 2, ' '), + '%g': (date) => { + // %g, %G, and %V give values according to the ISO 8601:2000 standard week-based year. + // In this system, weeks begin on a Monday and week 1 of the year is the week that includes + // January 4th, which is also the week that includes the first Thursday of the year, and + // is also the first week that contains at least four days in the year. + // If the first Monday of January is the 2nd, 3rd, or 4th, the preceding days are part of + // the last week of the preceding year; thus, for Saturday 2nd January 1999, + // %G is replaced by 1998 and %V is replaced by 53. If December 29th, 30th, + // or 31st is a Monday, it and any following days are part of week 1 of the following year. + // Thus, for Tuesday 30th December 1997, %G is replaced by 1998 and %V is replaced by 01. + + return getWeekBasedYear(date).toString().substring(2); + }, + '%G': getWeekBasedYear, + '%H': (date) => leadingNulls(date.tm_hour, 2), + '%I': (date) => { + var twelveHour = date.tm_hour; + if (twelveHour == 0) twelveHour = 12; + else if (twelveHour > 12) twelveHour -= 12; + return leadingNulls(twelveHour, 2); + }, + '%j': (date) => { + // Day of the year (001-366) + return leadingNulls(date.tm_mday + arraySum(isLeapYear(date.tm_year+1900) ? MONTH_DAYS_LEAP : MONTH_DAYS_REGULAR, date.tm_mon-1), 3); + }, + '%m': (date) => leadingNulls(date.tm_mon+1, 2), + '%M': (date) => leadingNulls(date.tm_min, 2), + '%n': () => '\n', + '%p': (date) => { + if (date.tm_hour >= 0 && date.tm_hour < 12) { + return 'AM'; + } + return 'PM'; + }, + '%S': (date) => leadingNulls(date.tm_sec, 2), + '%t': () => '\t', + '%u': (date) => date.tm_wday || 7, + '%U': (date) => { + var days = date.tm_yday + 7 - date.tm_wday; + return leadingNulls(Math.floor(days / 7), 2); + }, + '%V': (date) => { + // Replaced by the week number of the year (Monday as the first day of the week) + // as a decimal number [01,53]. If the week containing 1 January has four + // or more days in the new year, then it is considered week 1. + // Otherwise, it is the last week of the previous year, and the next week is week 1. + // Both January 4th and the first Thursday of January are always in week 1. [ tm_year, tm_wday, tm_yday] + var val = Math.floor((date.tm_yday + 7 - (date.tm_wday + 6) % 7 ) / 7); + // If 1 Jan is just 1-3 days past Monday, the previous week + // is also in this year. + if ((date.tm_wday + 371 - date.tm_yday - 2) % 7 <= 2) { + val++; + } + if (!val) { + val = 52; + // If 31 December of prev year a Thursday, or Friday of a + // leap year, then the prev year has 53 weeks. + var dec31 = (date.tm_wday + 7 - date.tm_yday - 1) % 7; + if (dec31 == 4 || (dec31 == 5 && isLeapYear(date.tm_year%400-1))) { + val++; + } + } else if (val == 53) { + // If 1 January is not a Thursday, and not a Wednesday of a + // leap year, then this year has only 52 weeks. + var jan1 = (date.tm_wday + 371 - date.tm_yday) % 7; + if (jan1 != 4 && (jan1 != 3 || !isLeapYear(date.tm_year))) + val = 1; + } + return leadingNulls(val, 2); + }, + '%w': (date) => date.tm_wday, + '%W': (date) => { + var days = date.tm_yday + 7 - ((date.tm_wday + 6) % 7); + return leadingNulls(Math.floor(days / 7), 2); + }, + '%y': (date) => { + // Replaced by the last two digits of the year as a decimal number [00,99]. [ tm_year] + return (date.tm_year+1900).toString().substring(2); + }, + // Replaced by the year as a decimal number (for example, 1997). [ tm_year] + '%Y': (date) => date.tm_year+1900, + '%z': (date) => { + // Replaced by the offset from UTC in the ISO 8601:2000 standard format ( +hhmm or -hhmm ). + // For example, "-0430" means 4 hours 30 minutes behind UTC (west of Greenwich). + var off = date.tm_gmtoff; + var ahead = off >= 0; + off = Math.abs(off) / 60; + // convert from minutes into hhmm format (which means 60 minutes = 100 units) + off = (off / 60)*100 + (off % 60); + return (ahead ? '+' : '-') + String("0000" + off).slice(-4); + }, + '%Z': (date) => date.tm_zone, + '%%': () => '%' + }; + + // Replace %% with a pair of NULLs (which cannot occur in a C string), then + // re-inject them after processing. + pattern = pattern.replace(/%%/g, '\0\0') + for (var rule in EXPANSION_RULES_2) { + if (pattern.includes(rule)) { + pattern = pattern.replace(new RegExp(rule, 'g'), EXPANSION_RULES_2[rule](date)); + } + } + pattern = pattern.replace(/\0\0/g, '%') + + var bytes = intArrayFromString(pattern, false); + if (bytes.length > maxsize) { + return 0; + } + + writeArrayToMemory(bytes, s); + return bytes.length-1; + }; + + + + var getCFunc = (ident) => { + var func = Module['_' + ident]; // closure exported function + return func; + }; + + + + var stringToUTF8OnStack = (str) => { + var size = lengthBytesUTF8(str) + 1; + var ret = stackAlloc(size); + stringToUTF8(str, ret, size); + return ret; + }; + + + + + + /** + * @param {string|null=} returnType + * @param {Array=} argTypes + * @param {Arguments|Array=} args + * @param {Object=} opts + */ + var ccall = (ident, returnType, argTypes, args, opts) => { + // For fast lookup of conversion functions + var toC = { + 'string': (str) => { + var ret = 0; + if (str !== null && str !== undefined && str !== 0) { // null string + // at most 4 bytes per UTF-8 code point, +1 for the trailing '\0' + ret = stringToUTF8OnStack(str); + } + return ret; + }, + 'array': (arr) => { + var ret = stackAlloc(arr.length); + writeArrayToMemory(arr, ret); + return ret; + } + }; + + function convertReturnValue(ret) { + if (returnType === 'string') { + + return UTF8ToString(ret); + } + if (returnType === 'boolean') return Boolean(ret); + return ret; + } + + var func = getCFunc(ident); + var cArgs = []; + var stack = 0; + if (args) { + for (var i = 0; i < args.length; i++) { + var converter = toC[argTypes[i]]; + if (converter) { + if (stack === 0) stack = stackSave(); + cArgs[i] = converter(args[i]); + } else { + cArgs[i] = args[i]; + } + } + } + var ret = func(...cArgs); + function onDone(ret) { + if (stack !== 0) stackRestore(stack); + return convertReturnValue(ret); + } + + ret = onDone(ret); + return ret; + }; + + + + /** + * @param {string=} returnType + * @param {Array=} argTypes + * @param {Object=} opts + */ + var cwrap = (ident, returnType, argTypes, opts) => { + // When the function takes numbers and returns a number, we can just return + // the original function + var numericArgs = !argTypes || argTypes.every((type) => type === 'number' || type === 'boolean'); + var numericRet = returnType !== 'string'; + if (numericRet && numericArgs && !opts) { + return getCFunc(ident); + } + return (...args) => ccall(ident, returnType, argTypes, args, opts); + }; + + + + + + + + + var uleb128Encode = (n, target) => { + if (n < 128) { + target.push(n); + } else { + target.push((n % 128) | 128, n >> 7); + } + }; + + var sigToWasmTypes = (sig) => { + var typeNames = { + 'i': 'i32', + 'j': 'i64', + 'f': 'f32', + 'd': 'f64', + 'e': 'externref', + 'p': 'i32', + }; + var type = { + parameters: [], + results: sig[0] == 'v' ? [] : [typeNames[sig[0]]] + }; + for (var i = 1; i < sig.length; ++i) { + type.parameters.push(typeNames[sig[i]]); + } + return type; + }; + + var generateFuncType = (sig, target) => { + var sigRet = sig.slice(0, 1); + var sigParam = sig.slice(1); + var typeCodes = { + 'i': 0x7f, // i32 + 'p': 0x7f, // i32 + 'j': 0x7e, // i64 + 'f': 0x7d, // f32 + 'd': 0x7c, // f64 + 'e': 0x6f, // externref + }; + + // Parameters, length + signatures + target.push(0x60 /* form: func */); + uleb128Encode(sigParam.length, target); + for (var i = 0; i < sigParam.length; ++i) { + target.push(typeCodes[sigParam[i]]); + } + + // Return values, length + signatures + // With no multi-return in MVP, either 0 (void) or 1 (anything else) + if (sigRet == 'v') { + target.push(0x00); + } else { + target.push(0x01, typeCodes[sigRet]); + } + }; + var convertJsFunctionToWasm = (func, sig) => { + + // If the type reflection proposal is available, use the new + // "WebAssembly.Function" constructor. + // Otherwise, construct a minimal wasm module importing the JS function and + // re-exporting it. + if (typeof WebAssembly.Function == "function") { + return new WebAssembly.Function(sigToWasmTypes(sig), func); + } + + // The module is static, with the exception of the type section, which is + // generated based on the signature passed in. + var typeSectionBody = [ + 0x01, // count: 1 + ]; + generateFuncType(sig, typeSectionBody); + + // Rest of the module is static + var bytes = [ + 0x00, 0x61, 0x73, 0x6d, // magic ("\0asm") + 0x01, 0x00, 0x00, 0x00, // version: 1 + 0x01, // Type section code + ]; + // Write the overall length of the type section followed by the body + uleb128Encode(typeSectionBody.length, bytes); + bytes.push(...typeSectionBody); + + // The rest of the module is static + bytes.push( + 0x02, 0x07, // import section + // (import "e" "f" (func 0 (type 0))) + 0x01, 0x01, 0x65, 0x01, 0x66, 0x00, 0x00, + 0x07, 0x05, // export section + // (export "f" (func 0 (type 0))) + 0x01, 0x01, 0x66, 0x00, 0x00, + ); + + // We can compile this wasm module synchronously because it is very small. + // This accepts an import (at "e.f"), that it reroutes to an export (at "f") + var module = new WebAssembly.Module(new Uint8Array(bytes)); + var instance = new WebAssembly.Instance(module, { 'e': { 'f': func } }); + var wrappedFunc = instance.exports['f']; + return wrappedFunc; + }; + + var wasmTableMirror = []; + + var wasmTable; + var getWasmTableEntry = (funcPtr) => { + var func = wasmTableMirror[funcPtr]; + if (!func) { + if (funcPtr >= wasmTableMirror.length) wasmTableMirror.length = funcPtr + 1; + wasmTableMirror[funcPtr] = func = wasmTable.get(funcPtr); + } + return func; + }; + + var updateTableMap = (offset, count) => { + if (functionsInTableMap) { + for (var i = offset; i < offset + count; i++) { + var item = getWasmTableEntry(i); + // Ignore null values. + if (item) { + functionsInTableMap.set(item, i); + } + } + } + }; + + var functionsInTableMap; + + var getFunctionAddress = (func) => { + // First, create the map if this is the first use. + if (!functionsInTableMap) { + functionsInTableMap = new WeakMap(); + updateTableMap(0, wasmTable.length); + } + return functionsInTableMap.get(func) || 0; + }; + + + var freeTableIndexes = []; + + var getEmptyTableSlot = () => { + // Reuse a free index if there is one, otherwise grow. + if (freeTableIndexes.length) { + return freeTableIndexes.pop(); + } + // Grow the table + try { + wasmTable.grow(1); + } catch (err) { + if (!(err instanceof RangeError)) { + throw err; + } + throw 'Unable to grow wasm table. Set ALLOW_TABLE_GROWTH.'; + } + return wasmTable.length - 1; + }; + + + + var setWasmTableEntry = (idx, func) => { + wasmTable.set(idx, func); + // With ABORT_ON_WASM_EXCEPTIONS wasmTable.get is overridden to return wrapped + // functions so we need to call it here to retrieve the potential wrapper correctly + // instead of just storing 'func' directly into wasmTableMirror + wasmTableMirror[idx] = wasmTable.get(idx); + }; + + /** @param {string=} sig */ + var addFunction = (func, sig) => { + // Check if the function is already in the table, to ensure each function + // gets a unique index. + var rtn = getFunctionAddress(func); + if (rtn) { + return rtn; + } + + // It's not in the table, add it now. + + var ret = getEmptyTableSlot(); + + // Set the new value. + try { + // Attempting to call this with JS function will cause of table.set() to fail + setWasmTableEntry(ret, func); + } catch (err) { + if (!(err instanceof TypeError)) { + throw err; + } + var wrapped = convertJsFunctionToWasm(func, sig); + setWasmTableEntry(ret, wrapped); + } + + functionsInTableMap.set(func, ret); + + return ret; + }; + + var handleException = (e) => { + // Certain exception types we do not treat as errors since they are used for + // internal control flow. + // 1. ExitStatus, which is thrown by exit() + // 2. "unwind", which is thrown by emscripten_unwind_to_js_event_loop() and others + // that wish to return to JS event loop. + if (e instanceof ExitStatus || e == 'unwind') { + return EXITSTATUS; + } + quit_(1, e); + }; + + + + var maybeExit = () => { + if (runtimeExited) { + return; + } + if (!keepRuntimeAlive()) { + try { + _exit(EXITSTATUS); + } catch (e) { + handleException(e); + } + } + }; + var callUserCallback = (func) => { + if (runtimeExited || ABORT) { + return; + } + try { + func(); + maybeExit(); + } catch (e) { + handleException(e); + } + }; + + var runtimeKeepalivePush = () => { + runtimeKeepaliveCounter += 1; + }; + + var runtimeKeepalivePop = () => { + runtimeKeepaliveCounter -= 1; + }; + /** @param {number=} timeout */ + var safeSetTimeout = (func, timeout) => { + runtimeKeepalivePush(); + return setTimeout(() => { + runtimeKeepalivePop(); + callUserCallback(func); + }, timeout); + }; + + + + + + + var FS_unlink = (path) => FS.unlink(path); + + FS.createPreloadedFile = FS_createPreloadedFile; + FS.staticInit();Module["FS_createPath"] = FS.createPath;Module["FS_createDataFile"] = FS.createDataFile;Module["FS_createPath"] = FS.createPath;Module["FS_createDataFile"] = FS.createDataFile;Module["FS_createPreloadedFile"] = FS.createPreloadedFile;Module["FS_unlink"] = FS.unlink;Module["FS_createLazyFile"] = FS.createLazyFile;Module["FS_createDevice"] = FS.createDevice;; +DOTNET.setup({ wasmEnableSIMD: true,wasmEnableEH: true,enableAotProfiler: false, enableDevToolsProfiler: false, enableLogProfiler: false, enableEventPipe: false, runAOTCompilation: false, wasmEnableThreads: false, gitHash: "f7d90799ce4ef09a0bb257852a57248d2a8fb8dd", });; +var wasmImports = { + /** @export */ + __assert_fail: ___assert_fail, + /** @export */ + __syscall_faccessat: ___syscall_faccessat, + /** @export */ + __syscall_fadvise64: ___syscall_fadvise64, + /** @export */ + __syscall_fcntl64: ___syscall_fcntl64, + /** @export */ + __syscall_fstat64: ___syscall_fstat64, + /** @export */ + __syscall_fstatfs64: ___syscall_fstatfs64, + /** @export */ + __syscall_ftruncate64: ___syscall_ftruncate64, + /** @export */ + __syscall_getcwd: ___syscall_getcwd, + /** @export */ + __syscall_getdents64: ___syscall_getdents64, + /** @export */ + __syscall_ioctl: ___syscall_ioctl, + /** @export */ + __syscall_lstat64: ___syscall_lstat64, + /** @export */ + __syscall_newfstatat: ___syscall_newfstatat, + /** @export */ + __syscall_openat: ___syscall_openat, + /** @export */ + __syscall_readlinkat: ___syscall_readlinkat, + /** @export */ + __syscall_stat64: ___syscall_stat64, + /** @export */ + __syscall_unlinkat: ___syscall_unlinkat, + /** @export */ + _emscripten_get_now_is_monotonic: __emscripten_get_now_is_monotonic, + /** @export */ + _localtime_js: __localtime_js, + /** @export */ + _mmap_js: __mmap_js, + /** @export */ + _munmap_js: __munmap_js, + /** @export */ + _tzset_js: __tzset_js, + /** @export */ + abort: _abort, + /** @export */ + emscripten_date_now: _emscripten_date_now, + /** @export */ + emscripten_force_exit: _emscripten_force_exit, + /** @export */ + emscripten_get_heap_max: _emscripten_get_heap_max, + /** @export */ + emscripten_get_now: _emscripten_get_now, + /** @export */ + emscripten_get_now_res: _emscripten_get_now_res, + /** @export */ + emscripten_resize_heap: _emscripten_resize_heap, + /** @export */ + environ_get: _environ_get, + /** @export */ + environ_sizes_get: _environ_sizes_get, + /** @export */ + exit: _exit, + /** @export */ + fd_close: _fd_close, + /** @export */ + fd_pread: _fd_pread, + /** @export */ + fd_read: _fd_read, + /** @export */ + fd_seek: _fd_seek, + /** @export */ + fd_write: _fd_write, + /** @export */ + mono_interp_flush_jitcall_queue: _mono_interp_flush_jitcall_queue, + /** @export */ + mono_interp_invoke_wasm_jit_call_trampoline: _mono_interp_invoke_wasm_jit_call_trampoline, + /** @export */ + mono_interp_jit_wasm_entry_trampoline: _mono_interp_jit_wasm_entry_trampoline, + /** @export */ + mono_interp_jit_wasm_jit_call_trampoline: _mono_interp_jit_wasm_jit_call_trampoline, + /** @export */ + mono_interp_record_interp_entry: _mono_interp_record_interp_entry, + /** @export */ + mono_interp_tier_prepare_jiterpreter: _mono_interp_tier_prepare_jiterpreter, + /** @export */ + mono_wasm_bind_js_import_ST: _mono_wasm_bind_js_import_ST, + /** @export */ + mono_wasm_browser_entropy: _mono_wasm_browser_entropy, + /** @export */ + mono_wasm_cancel_promise: _mono_wasm_cancel_promise, + /** @export */ + mono_wasm_console_clear: _mono_wasm_console_clear, + /** @export */ + mono_wasm_free_method_data: _mono_wasm_free_method_data, + /** @export */ + mono_wasm_get_locale_info: _mono_wasm_get_locale_info, + /** @export */ + mono_wasm_invoke_js_function: _mono_wasm_invoke_js_function, + /** @export */ + mono_wasm_invoke_jsimport_ST: _mono_wasm_invoke_jsimport_ST, + /** @export */ + mono_wasm_process_current_pid: _mono_wasm_process_current_pid, + /** @export */ + mono_wasm_release_cs_owned_object: _mono_wasm_release_cs_owned_object, + /** @export */ + mono_wasm_resolve_or_reject_promise: _mono_wasm_resolve_or_reject_promise, + /** @export */ + mono_wasm_schedule_timer: _mono_wasm_schedule_timer, + /** @export */ + mono_wasm_set_entrypoint_breakpoint: _mono_wasm_set_entrypoint_breakpoint, + /** @export */ + mono_wasm_trace_logger: _mono_wasm_trace_logger, + /** @export */ + schedule_background_exec: _schedule_background_exec, + /** @export */ + strftime: _strftime +}; +var wasmExports = createWasm(); +var ___wasm_call_ctors = () => (___wasm_call_ctors = wasmExports['__wasm_call_ctors'])(); +var _mono_wasm_register_root = Module['_mono_wasm_register_root'] = (a0, a1, a2) => (_mono_wasm_register_root = Module['_mono_wasm_register_root'] = wasmExports['mono_wasm_register_root'])(a0, a1, a2); +var _mono_wasm_deregister_root = Module['_mono_wasm_deregister_root'] = (a0) => (_mono_wasm_deregister_root = Module['_mono_wasm_deregister_root'] = wasmExports['mono_wasm_deregister_root'])(a0); +var _mono_wasm_add_assembly = Module['_mono_wasm_add_assembly'] = (a0, a1, a2) => (_mono_wasm_add_assembly = Module['_mono_wasm_add_assembly'] = wasmExports['mono_wasm_add_assembly'])(a0, a1, a2); +var _mono_wasm_add_satellite_assembly = Module['_mono_wasm_add_satellite_assembly'] = (a0, a1, a2, a3) => (_mono_wasm_add_satellite_assembly = Module['_mono_wasm_add_satellite_assembly'] = wasmExports['mono_wasm_add_satellite_assembly'])(a0, a1, a2, a3); +var _malloc = Module['_malloc'] = (a0) => (_malloc = Module['_malloc'] = wasmExports['malloc'])(a0); +var _mono_wasm_setenv = Module['_mono_wasm_setenv'] = (a0, a1) => (_mono_wasm_setenv = Module['_mono_wasm_setenv'] = wasmExports['mono_wasm_setenv'])(a0, a1); +var _mono_wasm_getenv = Module['_mono_wasm_getenv'] = (a0) => (_mono_wasm_getenv = Module['_mono_wasm_getenv'] = wasmExports['mono_wasm_getenv'])(a0); +var _free = Module['_free'] = (a0) => (_free = Module['_free'] = wasmExports['free'])(a0); +var _mono_wasm_load_runtime = Module['_mono_wasm_load_runtime'] = (a0, a1, a2, a3) => (_mono_wasm_load_runtime = Module['_mono_wasm_load_runtime'] = wasmExports['mono_wasm_load_runtime'])(a0, a1, a2, a3); +var _mono_wasm_invoke_jsexport = Module['_mono_wasm_invoke_jsexport'] = (a0, a1) => (_mono_wasm_invoke_jsexport = Module['_mono_wasm_invoke_jsexport'] = wasmExports['mono_wasm_invoke_jsexport'])(a0, a1); +var _mono_wasm_string_from_utf16_ref = Module['_mono_wasm_string_from_utf16_ref'] = (a0, a1, a2) => (_mono_wasm_string_from_utf16_ref = Module['_mono_wasm_string_from_utf16_ref'] = wasmExports['mono_wasm_string_from_utf16_ref'])(a0, a1, a2); +var _mono_wasm_exec_regression = Module['_mono_wasm_exec_regression'] = (a0, a1) => (_mono_wasm_exec_regression = Module['_mono_wasm_exec_regression'] = wasmExports['mono_wasm_exec_regression'])(a0, a1); +var _mono_wasm_exit = Module['_mono_wasm_exit'] = (a0) => (_mono_wasm_exit = Module['_mono_wasm_exit'] = wasmExports['mono_wasm_exit'])(a0); +var _fflush = (a0) => (_fflush = wasmExports['fflush'])(a0); +var _mono_wasm_set_main_args = Module['_mono_wasm_set_main_args'] = (a0, a1) => (_mono_wasm_set_main_args = Module['_mono_wasm_set_main_args'] = wasmExports['mono_wasm_set_main_args'])(a0, a1); +var _mono_wasm_strdup = Module['_mono_wasm_strdup'] = (a0) => (_mono_wasm_strdup = Module['_mono_wasm_strdup'] = wasmExports['mono_wasm_strdup'])(a0); +var _mono_wasm_parse_runtime_options = Module['_mono_wasm_parse_runtime_options'] = (a0, a1) => (_mono_wasm_parse_runtime_options = Module['_mono_wasm_parse_runtime_options'] = wasmExports['mono_wasm_parse_runtime_options'])(a0, a1); +var _mono_wasm_intern_string_ref = Module['_mono_wasm_intern_string_ref'] = (a0) => (_mono_wasm_intern_string_ref = Module['_mono_wasm_intern_string_ref'] = wasmExports['mono_wasm_intern_string_ref'])(a0); +var _mono_wasm_string_get_data_ref = Module['_mono_wasm_string_get_data_ref'] = (a0, a1, a2, a3) => (_mono_wasm_string_get_data_ref = Module['_mono_wasm_string_get_data_ref'] = wasmExports['mono_wasm_string_get_data_ref'])(a0, a1, a2, a3); +var _mono_wasm_write_managed_pointer_unsafe = Module['_mono_wasm_write_managed_pointer_unsafe'] = (a0, a1) => (_mono_wasm_write_managed_pointer_unsafe = Module['_mono_wasm_write_managed_pointer_unsafe'] = wasmExports['mono_wasm_write_managed_pointer_unsafe'])(a0, a1); +var _mono_wasm_copy_managed_pointer = Module['_mono_wasm_copy_managed_pointer'] = (a0, a1) => (_mono_wasm_copy_managed_pointer = Module['_mono_wasm_copy_managed_pointer'] = wasmExports['mono_wasm_copy_managed_pointer'])(a0, a1); +var _mono_wasm_init_finalizer_thread = Module['_mono_wasm_init_finalizer_thread'] = () => (_mono_wasm_init_finalizer_thread = Module['_mono_wasm_init_finalizer_thread'] = wasmExports['mono_wasm_init_finalizer_thread'])(); +var _mono_wasm_i52_to_f64 = Module['_mono_wasm_i52_to_f64'] = (a0, a1) => (_mono_wasm_i52_to_f64 = Module['_mono_wasm_i52_to_f64'] = wasmExports['mono_wasm_i52_to_f64'])(a0, a1); +var _mono_wasm_u52_to_f64 = Module['_mono_wasm_u52_to_f64'] = (a0, a1) => (_mono_wasm_u52_to_f64 = Module['_mono_wasm_u52_to_f64'] = wasmExports['mono_wasm_u52_to_f64'])(a0, a1); +var _mono_wasm_f64_to_u52 = Module['_mono_wasm_f64_to_u52'] = (a0, a1) => (_mono_wasm_f64_to_u52 = Module['_mono_wasm_f64_to_u52'] = wasmExports['mono_wasm_f64_to_u52'])(a0, a1); +var _mono_wasm_f64_to_i52 = Module['_mono_wasm_f64_to_i52'] = (a0, a1) => (_mono_wasm_f64_to_i52 = Module['_mono_wasm_f64_to_i52'] = wasmExports['mono_wasm_f64_to_i52'])(a0, a1); +var _mono_wasm_method_get_full_name = Module['_mono_wasm_method_get_full_name'] = (a0) => (_mono_wasm_method_get_full_name = Module['_mono_wasm_method_get_full_name'] = wasmExports['mono_wasm_method_get_full_name'])(a0); +var _mono_wasm_method_get_name = Module['_mono_wasm_method_get_name'] = (a0) => (_mono_wasm_method_get_name = Module['_mono_wasm_method_get_name'] = wasmExports['mono_wasm_method_get_name'])(a0); +var _mono_wasm_method_get_name_ex = Module['_mono_wasm_method_get_name_ex'] = (a0) => (_mono_wasm_method_get_name_ex = Module['_mono_wasm_method_get_name_ex'] = wasmExports['mono_wasm_method_get_name_ex'])(a0); +var _mono_wasm_get_f32_unaligned = Module['_mono_wasm_get_f32_unaligned'] = (a0) => (_mono_wasm_get_f32_unaligned = Module['_mono_wasm_get_f32_unaligned'] = wasmExports['mono_wasm_get_f32_unaligned'])(a0); +var _mono_wasm_get_f64_unaligned = Module['_mono_wasm_get_f64_unaligned'] = (a0) => (_mono_wasm_get_f64_unaligned = Module['_mono_wasm_get_f64_unaligned'] = wasmExports['mono_wasm_get_f64_unaligned'])(a0); +var _mono_wasm_get_i32_unaligned = Module['_mono_wasm_get_i32_unaligned'] = (a0) => (_mono_wasm_get_i32_unaligned = Module['_mono_wasm_get_i32_unaligned'] = wasmExports['mono_wasm_get_i32_unaligned'])(a0); +var _mono_wasm_is_zero_page_reserved = Module['_mono_wasm_is_zero_page_reserved'] = () => (_mono_wasm_is_zero_page_reserved = Module['_mono_wasm_is_zero_page_reserved'] = wasmExports['mono_wasm_is_zero_page_reserved'])(); +var _mono_wasm_read_as_bool_or_null_unsafe = Module['_mono_wasm_read_as_bool_or_null_unsafe'] = (a0) => (_mono_wasm_read_as_bool_or_null_unsafe = Module['_mono_wasm_read_as_bool_or_null_unsafe'] = wasmExports['mono_wasm_read_as_bool_or_null_unsafe'])(a0); +var _mono_wasm_assembly_load = Module['_mono_wasm_assembly_load'] = (a0) => (_mono_wasm_assembly_load = Module['_mono_wasm_assembly_load'] = wasmExports['mono_wasm_assembly_load'])(a0); +var _mono_wasm_assembly_find_class = Module['_mono_wasm_assembly_find_class'] = (a0, a1, a2) => (_mono_wasm_assembly_find_class = Module['_mono_wasm_assembly_find_class'] = wasmExports['mono_wasm_assembly_find_class'])(a0, a1, a2); +var _mono_wasm_assembly_find_method = Module['_mono_wasm_assembly_find_method'] = (a0, a1, a2) => (_mono_wasm_assembly_find_method = Module['_mono_wasm_assembly_find_method'] = wasmExports['mono_wasm_assembly_find_method'])(a0, a1, a2); +var _mono_wasm_send_dbg_command_with_parms = Module['_mono_wasm_send_dbg_command_with_parms'] = (a0, a1, a2, a3, a4, a5, a6) => (_mono_wasm_send_dbg_command_with_parms = Module['_mono_wasm_send_dbg_command_with_parms'] = wasmExports['mono_wasm_send_dbg_command_with_parms'])(a0, a1, a2, a3, a4, a5, a6); +var _mono_wasm_send_dbg_command = Module['_mono_wasm_send_dbg_command'] = (a0, a1, a2, a3, a4) => (_mono_wasm_send_dbg_command = Module['_mono_wasm_send_dbg_command'] = wasmExports['mono_wasm_send_dbg_command'])(a0, a1, a2, a3, a4); +var _mono_jiterp_register_jit_call_thunk = Module['_mono_jiterp_register_jit_call_thunk'] = (a0, a1) => (_mono_jiterp_register_jit_call_thunk = Module['_mono_jiterp_register_jit_call_thunk'] = wasmExports['mono_jiterp_register_jit_call_thunk'])(a0, a1); +var _mono_jiterp_stackval_to_data = Module['_mono_jiterp_stackval_to_data'] = (a0, a1, a2) => (_mono_jiterp_stackval_to_data = Module['_mono_jiterp_stackval_to_data'] = wasmExports['mono_jiterp_stackval_to_data'])(a0, a1, a2); +var _mono_jiterp_stackval_from_data = Module['_mono_jiterp_stackval_from_data'] = (a0, a1, a2) => (_mono_jiterp_stackval_from_data = Module['_mono_jiterp_stackval_from_data'] = wasmExports['mono_jiterp_stackval_from_data'])(a0, a1, a2); +var _mono_jiterp_get_arg_offset = Module['_mono_jiterp_get_arg_offset'] = (a0, a1, a2) => (_mono_jiterp_get_arg_offset = Module['_mono_jiterp_get_arg_offset'] = wasmExports['mono_jiterp_get_arg_offset'])(a0, a1, a2); +var _mono_jiterp_overflow_check_i4 = Module['_mono_jiterp_overflow_check_i4'] = (a0, a1, a2) => (_mono_jiterp_overflow_check_i4 = Module['_mono_jiterp_overflow_check_i4'] = wasmExports['mono_jiterp_overflow_check_i4'])(a0, a1, a2); +var _mono_jiterp_overflow_check_u4 = Module['_mono_jiterp_overflow_check_u4'] = (a0, a1, a2) => (_mono_jiterp_overflow_check_u4 = Module['_mono_jiterp_overflow_check_u4'] = wasmExports['mono_jiterp_overflow_check_u4'])(a0, a1, a2); +var _mono_jiterp_ld_delegate_method_ptr = Module['_mono_jiterp_ld_delegate_method_ptr'] = (a0, a1) => (_mono_jiterp_ld_delegate_method_ptr = Module['_mono_jiterp_ld_delegate_method_ptr'] = wasmExports['mono_jiterp_ld_delegate_method_ptr'])(a0, a1); +var _mono_jiterp_interp_entry = Module['_mono_jiterp_interp_entry'] = (a0, a1) => (_mono_jiterp_interp_entry = Module['_mono_jiterp_interp_entry'] = wasmExports['mono_jiterp_interp_entry'])(a0, a1); +var _memset = Module['_memset'] = (a0, a1, a2) => (_memset = Module['_memset'] = wasmExports['memset'])(a0, a1, a2); +var _fmodf = Module['_fmodf'] = (a0, a1) => (_fmodf = Module['_fmodf'] = wasmExports['fmodf'])(a0, a1); +var _fmod = Module['_fmod'] = (a0, a1) => (_fmod = Module['_fmod'] = wasmExports['fmod'])(a0, a1); +var _asin = Module['_asin'] = (a0) => (_asin = Module['_asin'] = wasmExports['asin'])(a0); +var _asinh = Module['_asinh'] = (a0) => (_asinh = Module['_asinh'] = wasmExports['asinh'])(a0); +var _acos = Module['_acos'] = (a0) => (_acos = Module['_acos'] = wasmExports['acos'])(a0); +var _acosh = Module['_acosh'] = (a0) => (_acosh = Module['_acosh'] = wasmExports['acosh'])(a0); +var _atan = Module['_atan'] = (a0) => (_atan = Module['_atan'] = wasmExports['atan'])(a0); +var _atanh = Module['_atanh'] = (a0) => (_atanh = Module['_atanh'] = wasmExports['atanh'])(a0); +var _cos = Module['_cos'] = (a0) => (_cos = Module['_cos'] = wasmExports['cos'])(a0); +var _cbrt = Module['_cbrt'] = (a0) => (_cbrt = Module['_cbrt'] = wasmExports['cbrt'])(a0); +var _cosh = Module['_cosh'] = (a0) => (_cosh = Module['_cosh'] = wasmExports['cosh'])(a0); +var _exp = Module['_exp'] = (a0) => (_exp = Module['_exp'] = wasmExports['exp'])(a0); +var _log = Module['_log'] = (a0) => (_log = Module['_log'] = wasmExports['log'])(a0); +var _log2 = Module['_log2'] = (a0) => (_log2 = Module['_log2'] = wasmExports['log2'])(a0); +var _log10 = Module['_log10'] = (a0) => (_log10 = Module['_log10'] = wasmExports['log10'])(a0); +var _sin = Module['_sin'] = (a0) => (_sin = Module['_sin'] = wasmExports['sin'])(a0); +var _sinh = Module['_sinh'] = (a0) => (_sinh = Module['_sinh'] = wasmExports['sinh'])(a0); +var _tan = Module['_tan'] = (a0) => (_tan = Module['_tan'] = wasmExports['tan'])(a0); +var _tanh = Module['_tanh'] = (a0) => (_tanh = Module['_tanh'] = wasmExports['tanh'])(a0); +var _atan2 = Module['_atan2'] = (a0, a1) => (_atan2 = Module['_atan2'] = wasmExports['atan2'])(a0, a1); +var _pow = Module['_pow'] = (a0, a1) => (_pow = Module['_pow'] = wasmExports['pow'])(a0, a1); +var _fma = Module['_fma'] = (a0, a1, a2) => (_fma = Module['_fma'] = wasmExports['fma'])(a0, a1, a2); +var _asinf = Module['_asinf'] = (a0) => (_asinf = Module['_asinf'] = wasmExports['asinf'])(a0); +var _asinhf = Module['_asinhf'] = (a0) => (_asinhf = Module['_asinhf'] = wasmExports['asinhf'])(a0); +var _acosf = Module['_acosf'] = (a0) => (_acosf = Module['_acosf'] = wasmExports['acosf'])(a0); +var _acoshf = Module['_acoshf'] = (a0) => (_acoshf = Module['_acoshf'] = wasmExports['acoshf'])(a0); +var _atanf = Module['_atanf'] = (a0) => (_atanf = Module['_atanf'] = wasmExports['atanf'])(a0); +var _atanhf = Module['_atanhf'] = (a0) => (_atanhf = Module['_atanhf'] = wasmExports['atanhf'])(a0); +var _cosf = Module['_cosf'] = (a0) => (_cosf = Module['_cosf'] = wasmExports['cosf'])(a0); +var _cbrtf = Module['_cbrtf'] = (a0) => (_cbrtf = Module['_cbrtf'] = wasmExports['cbrtf'])(a0); +var _coshf = Module['_coshf'] = (a0) => (_coshf = Module['_coshf'] = wasmExports['coshf'])(a0); +var _expf = Module['_expf'] = (a0) => (_expf = Module['_expf'] = wasmExports['expf'])(a0); +var _logf = Module['_logf'] = (a0) => (_logf = Module['_logf'] = wasmExports['logf'])(a0); +var _log2f = Module['_log2f'] = (a0) => (_log2f = Module['_log2f'] = wasmExports['log2f'])(a0); +var _log10f = Module['_log10f'] = (a0) => (_log10f = Module['_log10f'] = wasmExports['log10f'])(a0); +var _sinf = Module['_sinf'] = (a0) => (_sinf = Module['_sinf'] = wasmExports['sinf'])(a0); +var _sinhf = Module['_sinhf'] = (a0) => (_sinhf = Module['_sinhf'] = wasmExports['sinhf'])(a0); +var _tanf = Module['_tanf'] = (a0) => (_tanf = Module['_tanf'] = wasmExports['tanf'])(a0); +var _tanhf = Module['_tanhf'] = (a0) => (_tanhf = Module['_tanhf'] = wasmExports['tanhf'])(a0); +var _atan2f = Module['_atan2f'] = (a0, a1) => (_atan2f = Module['_atan2f'] = wasmExports['atan2f'])(a0, a1); +var _powf = Module['_powf'] = (a0, a1) => (_powf = Module['_powf'] = wasmExports['powf'])(a0, a1); +var _fmaf = Module['_fmaf'] = (a0, a1, a2) => (_fmaf = Module['_fmaf'] = wasmExports['fmaf'])(a0, a1, a2); +var _mono_jiterp_get_polling_required_address = Module['_mono_jiterp_get_polling_required_address'] = () => (_mono_jiterp_get_polling_required_address = Module['_mono_jiterp_get_polling_required_address'] = wasmExports['mono_jiterp_get_polling_required_address'])(); +var _mono_jiterp_prof_enter = Module['_mono_jiterp_prof_enter'] = (a0, a1) => (_mono_jiterp_prof_enter = Module['_mono_jiterp_prof_enter'] = wasmExports['mono_jiterp_prof_enter'])(a0, a1); +var _mono_jiterp_prof_samplepoint = Module['_mono_jiterp_prof_samplepoint'] = (a0, a1) => (_mono_jiterp_prof_samplepoint = Module['_mono_jiterp_prof_samplepoint'] = wasmExports['mono_jiterp_prof_samplepoint'])(a0, a1); +var _mono_jiterp_prof_leave = Module['_mono_jiterp_prof_leave'] = (a0, a1) => (_mono_jiterp_prof_leave = Module['_mono_jiterp_prof_leave'] = wasmExports['mono_jiterp_prof_leave'])(a0, a1); +var _mono_jiterp_do_safepoint = Module['_mono_jiterp_do_safepoint'] = (a0, a1) => (_mono_jiterp_do_safepoint = Module['_mono_jiterp_do_safepoint'] = wasmExports['mono_jiterp_do_safepoint'])(a0, a1); +var _mono_jiterp_imethod_to_ftnptr = Module['_mono_jiterp_imethod_to_ftnptr'] = (a0) => (_mono_jiterp_imethod_to_ftnptr = Module['_mono_jiterp_imethod_to_ftnptr'] = wasmExports['mono_jiterp_imethod_to_ftnptr'])(a0); +var _mono_jiterp_enum_hasflag = Module['_mono_jiterp_enum_hasflag'] = (a0, a1, a2, a3) => (_mono_jiterp_enum_hasflag = Module['_mono_jiterp_enum_hasflag'] = wasmExports['mono_jiterp_enum_hasflag'])(a0, a1, a2, a3); +var _mono_jiterp_get_simd_intrinsic = Module['_mono_jiterp_get_simd_intrinsic'] = (a0, a1) => (_mono_jiterp_get_simd_intrinsic = Module['_mono_jiterp_get_simd_intrinsic'] = wasmExports['mono_jiterp_get_simd_intrinsic'])(a0, a1); +var _mono_jiterp_get_simd_opcode = Module['_mono_jiterp_get_simd_opcode'] = (a0, a1) => (_mono_jiterp_get_simd_opcode = Module['_mono_jiterp_get_simd_opcode'] = wasmExports['mono_jiterp_get_simd_opcode'])(a0, a1); +var _mono_jiterp_get_opcode_info = Module['_mono_jiterp_get_opcode_info'] = (a0, a1) => (_mono_jiterp_get_opcode_info = Module['_mono_jiterp_get_opcode_info'] = wasmExports['mono_jiterp_get_opcode_info'])(a0, a1); +var _mono_jiterp_placeholder_trace = Module['_mono_jiterp_placeholder_trace'] = (a0, a1, a2, a3) => (_mono_jiterp_placeholder_trace = Module['_mono_jiterp_placeholder_trace'] = wasmExports['mono_jiterp_placeholder_trace'])(a0, a1, a2, a3); +var _mono_jiterp_placeholder_jit_call = Module['_mono_jiterp_placeholder_jit_call'] = (a0, a1, a2, a3) => (_mono_jiterp_placeholder_jit_call = Module['_mono_jiterp_placeholder_jit_call'] = wasmExports['mono_jiterp_placeholder_jit_call'])(a0, a1, a2, a3); +var _mono_jiterp_get_interp_entry_func = Module['_mono_jiterp_get_interp_entry_func'] = (a0) => (_mono_jiterp_get_interp_entry_func = Module['_mono_jiterp_get_interp_entry_func'] = wasmExports['mono_jiterp_get_interp_entry_func'])(a0); +var _mono_jiterp_is_enabled = Module['_mono_jiterp_is_enabled'] = () => (_mono_jiterp_is_enabled = Module['_mono_jiterp_is_enabled'] = wasmExports['mono_jiterp_is_enabled'])(); +var _mono_jiterp_encode_leb64_ref = Module['_mono_jiterp_encode_leb64_ref'] = (a0, a1, a2) => (_mono_jiterp_encode_leb64_ref = Module['_mono_jiterp_encode_leb64_ref'] = wasmExports['mono_jiterp_encode_leb64_ref'])(a0, a1, a2); +var _mono_jiterp_encode_leb52 = Module['_mono_jiterp_encode_leb52'] = (a0, a1, a2) => (_mono_jiterp_encode_leb52 = Module['_mono_jiterp_encode_leb52'] = wasmExports['mono_jiterp_encode_leb52'])(a0, a1, a2); +var _mono_jiterp_encode_leb_signed_boundary = Module['_mono_jiterp_encode_leb_signed_boundary'] = (a0, a1, a2) => (_mono_jiterp_encode_leb_signed_boundary = Module['_mono_jiterp_encode_leb_signed_boundary'] = wasmExports['mono_jiterp_encode_leb_signed_boundary'])(a0, a1, a2); +var _mono_jiterp_increase_entry_count = Module['_mono_jiterp_increase_entry_count'] = (a0) => (_mono_jiterp_increase_entry_count = Module['_mono_jiterp_increase_entry_count'] = wasmExports['mono_jiterp_increase_entry_count'])(a0); +var _mono_jiterp_object_unbox = Module['_mono_jiterp_object_unbox'] = (a0) => (_mono_jiterp_object_unbox = Module['_mono_jiterp_object_unbox'] = wasmExports['mono_jiterp_object_unbox'])(a0); +var _mono_jiterp_type_is_byref = Module['_mono_jiterp_type_is_byref'] = (a0) => (_mono_jiterp_type_is_byref = Module['_mono_jiterp_type_is_byref'] = wasmExports['mono_jiterp_type_is_byref'])(a0); +var _mono_jiterp_value_copy = Module['_mono_jiterp_value_copy'] = (a0, a1, a2) => (_mono_jiterp_value_copy = Module['_mono_jiterp_value_copy'] = wasmExports['mono_jiterp_value_copy'])(a0, a1, a2); +var _mono_jiterp_try_newobj_inlined = Module['_mono_jiterp_try_newobj_inlined'] = (a0, a1) => (_mono_jiterp_try_newobj_inlined = Module['_mono_jiterp_try_newobj_inlined'] = wasmExports['mono_jiterp_try_newobj_inlined'])(a0, a1); +var _mono_jiterp_try_newstr = Module['_mono_jiterp_try_newstr'] = (a0, a1) => (_mono_jiterp_try_newstr = Module['_mono_jiterp_try_newstr'] = wasmExports['mono_jiterp_try_newstr'])(a0, a1); +var _mono_jiterp_try_newarr = Module['_mono_jiterp_try_newarr'] = (a0, a1, a2) => (_mono_jiterp_try_newarr = Module['_mono_jiterp_try_newarr'] = wasmExports['mono_jiterp_try_newarr'])(a0, a1, a2); +var _mono_jiterp_gettype_ref = Module['_mono_jiterp_gettype_ref'] = (a0, a1) => (_mono_jiterp_gettype_ref = Module['_mono_jiterp_gettype_ref'] = wasmExports['mono_jiterp_gettype_ref'])(a0, a1); +var _mono_jiterp_has_parent_fast = Module['_mono_jiterp_has_parent_fast'] = (a0, a1) => (_mono_jiterp_has_parent_fast = Module['_mono_jiterp_has_parent_fast'] = wasmExports['mono_jiterp_has_parent_fast'])(a0, a1); +var _mono_jiterp_implements_interface = Module['_mono_jiterp_implements_interface'] = (a0, a1) => (_mono_jiterp_implements_interface = Module['_mono_jiterp_implements_interface'] = wasmExports['mono_jiterp_implements_interface'])(a0, a1); +var _mono_jiterp_is_special_interface = Module['_mono_jiterp_is_special_interface'] = (a0) => (_mono_jiterp_is_special_interface = Module['_mono_jiterp_is_special_interface'] = wasmExports['mono_jiterp_is_special_interface'])(a0); +var _mono_jiterp_implements_special_interface = Module['_mono_jiterp_implements_special_interface'] = (a0, a1, a2) => (_mono_jiterp_implements_special_interface = Module['_mono_jiterp_implements_special_interface'] = wasmExports['mono_jiterp_implements_special_interface'])(a0, a1, a2); +var _mono_jiterp_cast_v2 = Module['_mono_jiterp_cast_v2'] = (a0, a1, a2, a3) => (_mono_jiterp_cast_v2 = Module['_mono_jiterp_cast_v2'] = wasmExports['mono_jiterp_cast_v2'])(a0, a1, a2, a3); +var _mono_jiterp_localloc = Module['_mono_jiterp_localloc'] = (a0, a1, a2) => (_mono_jiterp_localloc = Module['_mono_jiterp_localloc'] = wasmExports['mono_jiterp_localloc'])(a0, a1, a2); +var _mono_jiterp_ldtsflda = Module['_mono_jiterp_ldtsflda'] = (a0, a1) => (_mono_jiterp_ldtsflda = Module['_mono_jiterp_ldtsflda'] = wasmExports['mono_jiterp_ldtsflda'])(a0, a1); +var _mono_jiterp_box_ref = Module['_mono_jiterp_box_ref'] = (a0, a1, a2, a3) => (_mono_jiterp_box_ref = Module['_mono_jiterp_box_ref'] = wasmExports['mono_jiterp_box_ref'])(a0, a1, a2, a3); +var _mono_jiterp_conv = Module['_mono_jiterp_conv'] = (a0, a1, a2) => (_mono_jiterp_conv = Module['_mono_jiterp_conv'] = wasmExports['mono_jiterp_conv'])(a0, a1, a2); +var _mono_jiterp_relop_fp = Module['_mono_jiterp_relop_fp'] = (a0, a1, a2) => (_mono_jiterp_relop_fp = Module['_mono_jiterp_relop_fp'] = wasmExports['mono_jiterp_relop_fp'])(a0, a1, a2); +var _mono_jiterp_get_size_of_stackval = Module['_mono_jiterp_get_size_of_stackval'] = () => (_mono_jiterp_get_size_of_stackval = Module['_mono_jiterp_get_size_of_stackval'] = wasmExports['mono_jiterp_get_size_of_stackval'])(); +var _mono_jiterp_type_get_raw_value_size = Module['_mono_jiterp_type_get_raw_value_size'] = (a0) => (_mono_jiterp_type_get_raw_value_size = Module['_mono_jiterp_type_get_raw_value_size'] = wasmExports['mono_jiterp_type_get_raw_value_size'])(a0); +var _mono_jiterp_trace_bailout = Module['_mono_jiterp_trace_bailout'] = (a0) => (_mono_jiterp_trace_bailout = Module['_mono_jiterp_trace_bailout'] = wasmExports['mono_jiterp_trace_bailout'])(a0); +var _mono_jiterp_get_trace_bailout_count = Module['_mono_jiterp_get_trace_bailout_count'] = (a0) => (_mono_jiterp_get_trace_bailout_count = Module['_mono_jiterp_get_trace_bailout_count'] = wasmExports['mono_jiterp_get_trace_bailout_count'])(a0); +var _mono_jiterp_adjust_abort_count = Module['_mono_jiterp_adjust_abort_count'] = (a0, a1) => (_mono_jiterp_adjust_abort_count = Module['_mono_jiterp_adjust_abort_count'] = wasmExports['mono_jiterp_adjust_abort_count'])(a0, a1); +var _mono_jiterp_interp_entry_prologue = Module['_mono_jiterp_interp_entry_prologue'] = (a0, a1) => (_mono_jiterp_interp_entry_prologue = Module['_mono_jiterp_interp_entry_prologue'] = wasmExports['mono_jiterp_interp_entry_prologue'])(a0, a1); +var _mono_jiterp_get_opcode_value_table_entry = Module['_mono_jiterp_get_opcode_value_table_entry'] = (a0) => (_mono_jiterp_get_opcode_value_table_entry = Module['_mono_jiterp_get_opcode_value_table_entry'] = wasmExports['mono_jiterp_get_opcode_value_table_entry'])(a0); +var _mono_jiterp_get_trace_hit_count = Module['_mono_jiterp_get_trace_hit_count'] = (a0) => (_mono_jiterp_get_trace_hit_count = Module['_mono_jiterp_get_trace_hit_count'] = wasmExports['mono_jiterp_get_trace_hit_count'])(a0); +var _mono_jiterp_parse_option = Module['_mono_jiterp_parse_option'] = (a0) => (_mono_jiterp_parse_option = Module['_mono_jiterp_parse_option'] = wasmExports['mono_jiterp_parse_option'])(a0); +var _mono_jiterp_get_options_version = Module['_mono_jiterp_get_options_version'] = () => (_mono_jiterp_get_options_version = Module['_mono_jiterp_get_options_version'] = wasmExports['mono_jiterp_get_options_version'])(); +var _mono_jiterp_get_options_as_json = Module['_mono_jiterp_get_options_as_json'] = () => (_mono_jiterp_get_options_as_json = Module['_mono_jiterp_get_options_as_json'] = wasmExports['mono_jiterp_get_options_as_json'])(); +var _mono_jiterp_get_option_as_int = Module['_mono_jiterp_get_option_as_int'] = (a0) => (_mono_jiterp_get_option_as_int = Module['_mono_jiterp_get_option_as_int'] = wasmExports['mono_jiterp_get_option_as_int'])(a0); +var _mono_jiterp_object_has_component_size = Module['_mono_jiterp_object_has_component_size'] = (a0) => (_mono_jiterp_object_has_component_size = Module['_mono_jiterp_object_has_component_size'] = wasmExports['mono_jiterp_object_has_component_size'])(a0); +var _mono_jiterp_get_hashcode = Module['_mono_jiterp_get_hashcode'] = (a0) => (_mono_jiterp_get_hashcode = Module['_mono_jiterp_get_hashcode'] = wasmExports['mono_jiterp_get_hashcode'])(a0); +var _mono_jiterp_try_get_hashcode = Module['_mono_jiterp_try_get_hashcode'] = (a0) => (_mono_jiterp_try_get_hashcode = Module['_mono_jiterp_try_get_hashcode'] = wasmExports['mono_jiterp_try_get_hashcode'])(a0); +var _mono_jiterp_get_signature_has_this = Module['_mono_jiterp_get_signature_has_this'] = (a0) => (_mono_jiterp_get_signature_has_this = Module['_mono_jiterp_get_signature_has_this'] = wasmExports['mono_jiterp_get_signature_has_this'])(a0); +var _mono_jiterp_get_signature_return_type = Module['_mono_jiterp_get_signature_return_type'] = (a0) => (_mono_jiterp_get_signature_return_type = Module['_mono_jiterp_get_signature_return_type'] = wasmExports['mono_jiterp_get_signature_return_type'])(a0); +var _mono_jiterp_get_signature_param_count = Module['_mono_jiterp_get_signature_param_count'] = (a0) => (_mono_jiterp_get_signature_param_count = Module['_mono_jiterp_get_signature_param_count'] = wasmExports['mono_jiterp_get_signature_param_count'])(a0); +var _mono_jiterp_get_signature_params = Module['_mono_jiterp_get_signature_params'] = (a0) => (_mono_jiterp_get_signature_params = Module['_mono_jiterp_get_signature_params'] = wasmExports['mono_jiterp_get_signature_params'])(a0); +var _mono_jiterp_type_to_ldind = Module['_mono_jiterp_type_to_ldind'] = (a0) => (_mono_jiterp_type_to_ldind = Module['_mono_jiterp_type_to_ldind'] = wasmExports['mono_jiterp_type_to_ldind'])(a0); +var _mono_jiterp_type_to_stind = Module['_mono_jiterp_type_to_stind'] = (a0) => (_mono_jiterp_type_to_stind = Module['_mono_jiterp_type_to_stind'] = wasmExports['mono_jiterp_type_to_stind'])(a0); +var _mono_jiterp_get_array_rank = Module['_mono_jiterp_get_array_rank'] = (a0, a1) => (_mono_jiterp_get_array_rank = Module['_mono_jiterp_get_array_rank'] = wasmExports['mono_jiterp_get_array_rank'])(a0, a1); +var _mono_jiterp_get_array_element_size = Module['_mono_jiterp_get_array_element_size'] = (a0, a1) => (_mono_jiterp_get_array_element_size = Module['_mono_jiterp_get_array_element_size'] = wasmExports['mono_jiterp_get_array_element_size'])(a0, a1); +var _mono_jiterp_set_object_field = Module['_mono_jiterp_set_object_field'] = (a0, a1, a2, a3) => (_mono_jiterp_set_object_field = Module['_mono_jiterp_set_object_field'] = wasmExports['mono_jiterp_set_object_field'])(a0, a1, a2, a3); +var _mono_jiterp_debug_count = Module['_mono_jiterp_debug_count'] = () => (_mono_jiterp_debug_count = Module['_mono_jiterp_debug_count'] = wasmExports['mono_jiterp_debug_count'])(); +var _mono_jiterp_stelem_ref = Module['_mono_jiterp_stelem_ref'] = (a0, a1, a2) => (_mono_jiterp_stelem_ref = Module['_mono_jiterp_stelem_ref'] = wasmExports['mono_jiterp_stelem_ref'])(a0, a1, a2); +var _mono_jiterp_get_member_offset = Module['_mono_jiterp_get_member_offset'] = (a0) => (_mono_jiterp_get_member_offset = Module['_mono_jiterp_get_member_offset'] = wasmExports['mono_jiterp_get_member_offset'])(a0); +var _mono_jiterp_get_counter = Module['_mono_jiterp_get_counter'] = (a0) => (_mono_jiterp_get_counter = Module['_mono_jiterp_get_counter'] = wasmExports['mono_jiterp_get_counter'])(a0); +var _mono_jiterp_modify_counter = Module['_mono_jiterp_modify_counter'] = (a0, a1) => (_mono_jiterp_modify_counter = Module['_mono_jiterp_modify_counter'] = wasmExports['mono_jiterp_modify_counter'])(a0, a1); +var _mono_jiterp_write_number_unaligned = Module['_mono_jiterp_write_number_unaligned'] = (a0, a1, a2) => (_mono_jiterp_write_number_unaligned = Module['_mono_jiterp_write_number_unaligned'] = wasmExports['mono_jiterp_write_number_unaligned'])(a0, a1, a2); +var _mono_jiterp_get_rejected_trace_count = Module['_mono_jiterp_get_rejected_trace_count'] = () => (_mono_jiterp_get_rejected_trace_count = Module['_mono_jiterp_get_rejected_trace_count'] = wasmExports['mono_jiterp_get_rejected_trace_count'])(); +var _mono_jiterp_boost_back_branch_target = Module['_mono_jiterp_boost_back_branch_target'] = (a0) => (_mono_jiterp_boost_back_branch_target = Module['_mono_jiterp_boost_back_branch_target'] = wasmExports['mono_jiterp_boost_back_branch_target'])(a0); +var _mono_jiterp_is_imethod_var_address_taken = Module['_mono_jiterp_is_imethod_var_address_taken'] = (a0, a1) => (_mono_jiterp_is_imethod_var_address_taken = Module['_mono_jiterp_is_imethod_var_address_taken'] = wasmExports['mono_jiterp_is_imethod_var_address_taken'])(a0, a1); +var _mono_jiterp_initialize_table = Module['_mono_jiterp_initialize_table'] = (a0, a1, a2) => (_mono_jiterp_initialize_table = Module['_mono_jiterp_initialize_table'] = wasmExports['mono_jiterp_initialize_table'])(a0, a1, a2); +var _mono_jiterp_allocate_table_entry = Module['_mono_jiterp_allocate_table_entry'] = (a0) => (_mono_jiterp_allocate_table_entry = Module['_mono_jiterp_allocate_table_entry'] = wasmExports['mono_jiterp_allocate_table_entry'])(a0); +var _mono_jiterp_tlqueue_next = Module['_mono_jiterp_tlqueue_next'] = (a0) => (_mono_jiterp_tlqueue_next = Module['_mono_jiterp_tlqueue_next'] = wasmExports['mono_jiterp_tlqueue_next'])(a0); +var _mono_jiterp_tlqueue_add = Module['_mono_jiterp_tlqueue_add'] = (a0, a1) => (_mono_jiterp_tlqueue_add = Module['_mono_jiterp_tlqueue_add'] = wasmExports['mono_jiterp_tlqueue_add'])(a0, a1); +var _mono_jiterp_tlqueue_clear = Module['_mono_jiterp_tlqueue_clear'] = (a0) => (_mono_jiterp_tlqueue_clear = Module['_mono_jiterp_tlqueue_clear'] = wasmExports['mono_jiterp_tlqueue_clear'])(a0); +var _mono_interp_pgo_load_table = Module['_mono_interp_pgo_load_table'] = (a0, a1) => (_mono_interp_pgo_load_table = Module['_mono_interp_pgo_load_table'] = wasmExports['mono_interp_pgo_load_table'])(a0, a1); +var _mono_interp_pgo_save_table = Module['_mono_interp_pgo_save_table'] = (a0, a1) => (_mono_interp_pgo_save_table = Module['_mono_interp_pgo_save_table'] = wasmExports['mono_interp_pgo_save_table'])(a0, a1); +var _mono_llvm_cpp_catch_exception = Module['_mono_llvm_cpp_catch_exception'] = (a0, a1, a2) => (_mono_llvm_cpp_catch_exception = Module['_mono_llvm_cpp_catch_exception'] = wasmExports['mono_llvm_cpp_catch_exception'])(a0, a1, a2); +var _mono_jiterp_begin_catch = Module['_mono_jiterp_begin_catch'] = (a0) => (_mono_jiterp_begin_catch = Module['_mono_jiterp_begin_catch'] = wasmExports['mono_jiterp_begin_catch'])(a0); +var _mono_jiterp_end_catch = Module['_mono_jiterp_end_catch'] = () => (_mono_jiterp_end_catch = Module['_mono_jiterp_end_catch'] = wasmExports['mono_jiterp_end_catch'])(); +var _sbrk = Module['_sbrk'] = (a0) => (_sbrk = Module['_sbrk'] = wasmExports['sbrk'])(a0); +var _posix_memalign = Module['_posix_memalign'] = (a0, a1, a2) => (_posix_memalign = Module['_posix_memalign'] = wasmExports['posix_memalign'])(a0, a1, a2); +var _mono_background_exec = Module['_mono_background_exec'] = () => (_mono_background_exec = Module['_mono_background_exec'] = wasmExports['mono_background_exec'])(); +var _mono_wasm_ds_exec = Module['_mono_wasm_ds_exec'] = () => (_mono_wasm_ds_exec = Module['_mono_wasm_ds_exec'] = wasmExports['mono_wasm_ds_exec'])(); +var _mono_wasm_gc_lock = Module['_mono_wasm_gc_lock'] = () => (_mono_wasm_gc_lock = Module['_mono_wasm_gc_lock'] = wasmExports['mono_wasm_gc_lock'])(); +var _mono_wasm_gc_unlock = Module['_mono_wasm_gc_unlock'] = () => (_mono_wasm_gc_unlock = Module['_mono_wasm_gc_unlock'] = wasmExports['mono_wasm_gc_unlock'])(); +var _mono_print_method_from_ip = Module['_mono_print_method_from_ip'] = (a0) => (_mono_print_method_from_ip = Module['_mono_print_method_from_ip'] = wasmExports['mono_print_method_from_ip'])(a0); +var _mono_wasm_execute_timer = Module['_mono_wasm_execute_timer'] = () => (_mono_wasm_execute_timer = Module['_mono_wasm_execute_timer'] = wasmExports['mono_wasm_execute_timer'])(); +var ___funcs_on_exit = () => (___funcs_on_exit = wasmExports['__funcs_on_exit'])(); +var _htons = Module['_htons'] = (a0) => (_htons = Module['_htons'] = wasmExports['htons'])(a0); +var _emscripten_builtin_memalign = (a0, a1) => (_emscripten_builtin_memalign = wasmExports['emscripten_builtin_memalign'])(a0, a1); +var _ntohs = Module['_ntohs'] = (a0) => (_ntohs = Module['_ntohs'] = wasmExports['ntohs'])(a0); +var _memalign = Module['_memalign'] = (a0, a1) => (_memalign = Module['_memalign'] = wasmExports['memalign'])(a0, a1); +var ___trap = () => (___trap = wasmExports['__trap'])(); +var stackSave = Module['stackSave'] = () => (stackSave = Module['stackSave'] = wasmExports['stackSave'])(); +var stackRestore = Module['stackRestore'] = (a0) => (stackRestore = Module['stackRestore'] = wasmExports['stackRestore'])(a0); +var stackAlloc = Module['stackAlloc'] = (a0) => (stackAlloc = Module['stackAlloc'] = wasmExports['stackAlloc'])(a0); + + +// include: postamble.js +// === Auto-generated postamble setup entry stuff === + +Module['addRunDependency'] = addRunDependency; +Module['removeRunDependency'] = removeRunDependency; +Module['FS_createPath'] = FS.createPath; +Module['FS_createLazyFile'] = FS.createLazyFile; +Module['FS_createDevice'] = FS.createDevice; +Module['out'] = out; +Module['err'] = err; +Module['abort'] = abort; +Module['wasmExports'] = wasmExports; +Module['runtimeKeepalivePush'] = runtimeKeepalivePush; +Module['runtimeKeepalivePop'] = runtimeKeepalivePop; +Module['maybeExit'] = maybeExit; +Module['ccall'] = ccall; +Module['cwrap'] = cwrap; +Module['addFunction'] = addFunction; +Module['setValue'] = setValue; +Module['getValue'] = getValue; +Module['UTF8ArrayToString'] = UTF8ArrayToString; +Module['UTF8ToString'] = UTF8ToString; +Module['stringToUTF8Array'] = stringToUTF8Array; +Module['lengthBytesUTF8'] = lengthBytesUTF8; +Module['safeSetTimeout'] = safeSetTimeout; +Module['FS_createPreloadedFile'] = FS.createPreloadedFile; +Module['FS'] = FS; +Module['FS_createDataFile'] = FS.createDataFile; +Module['FS_unlink'] = FS.unlink; + + +var calledRun; + +dependenciesFulfilled = function runCaller() { + // If run has never been called, and we should call run (INVOKE_RUN is true, and Module.noInitialRun is not false) + if (!calledRun) run(); + if (!calledRun) dependenciesFulfilled = runCaller; // try this again later, after new deps are fulfilled +}; + +function run() { + + if (runDependencies > 0) { + return; + } + + preRun(); + + // a preRun added a dependency, run will be called later + if (runDependencies > 0) { + return; + } + + function doRun() { + // run may have just been called through dependencies being fulfilled just in this very frame, + // or while the async setStatus time below was happening + if (calledRun) return; + calledRun = true; + Module['calledRun'] = true; + + if (ABORT) return; + + initRuntime(); + + readyPromiseResolve(Module); + if (Module['onRuntimeInitialized']) Module['onRuntimeInitialized'](); + + postRun(); + } + + if (Module['setStatus']) { + Module['setStatus']('Running...'); + setTimeout(function() { + setTimeout(function() { + Module['setStatus'](''); + }, 1); + doRun(); + }, 1); + } else + { + doRun(); + } +} + +if (Module['preInit']) { + if (typeof Module['preInit'] == 'function') Module['preInit'] = [Module['preInit']]; + while (Module['preInit'].length > 0) { + Module['preInit'].pop()(); + } +} + +run(); + +// end include: postamble.js + + + + return moduleArg.ready +} +); +})(); +export default createDotnetRuntime; +var fetch = fetch || undefined; var require = require || undefined; var __dirname = __dirname || ''; var _nativeModuleLoaded = false; diff --git a/public/engines/dotnet/_framework/dotnet.native.6k8j5v15h5.wasm b/public/engines/dotnet/_framework/dotnet.native.6k8j5v15h5.wasm new file mode 100644 index 0000000..e605123 Binary files /dev/null and b/public/engines/dotnet/_framework/dotnet.native.6k8j5v15h5.wasm differ diff --git a/public/engines/dotnet/_framework/dotnet.runtime.web2r9gqbh.js b/public/engines/dotnet/_framework/dotnet.runtime.web2r9gqbh.js new file mode 100644 index 0000000..abdb688 --- /dev/null +++ b/public/engines/dotnet/_framework/dotnet.runtime.web2r9gqbh.js @@ -0,0 +1,4 @@ +//! Licensed to the .NET Foundation under one or more agreements. +//! The .NET Foundation licenses this file to you under the MIT license. +var e="10.0.10",t="Release",n=!1;const r=[[!0,"mono_wasm_register_root","number",["number","number","string"]],[!0,"mono_wasm_deregister_root",null,["number"]],[!0,"mono_wasm_string_get_data_ref",null,["number","number","number","number"]],[!0,"mono_wasm_set_is_debugger_attached","void",["bool"]],[!0,"mono_wasm_send_dbg_command","bool",["number","number","number","number","number"]],[!0,"mono_wasm_send_dbg_command_with_parms","bool",["number","number","number","number","number","number","string"]],[!0,"mono_wasm_setenv",null,["string","string"]],[!0,"mono_wasm_parse_runtime_options",null,["number","number"]],[!0,"mono_wasm_strdup","number",["string"]],[!0,"mono_background_exec",null,[]],[!0,"mono_wasm_ds_exec",null,[]],[!0,"mono_wasm_execute_timer",null,[]],[!0,"mono_wasm_load_icu_data","number",["number"]],[!1,"mono_wasm_add_assembly","number",["string","number","number"]],[!0,"mono_wasm_add_satellite_assembly","void",["string","string","number","number"]],[!1,"mono_wasm_load_runtime",null,["number","number","number","number"]],[!0,"mono_wasm_change_debugger_log_level","void",["number"]],[!0,"mono_wasm_assembly_load","number",["string"]],[!0,"mono_wasm_assembly_find_class","number",["number","string","string"]],[!0,"mono_wasm_assembly_find_method","number",["number","string","number"]],[!0,"mono_wasm_string_from_utf16_ref","void",["number","number","number"]],[!0,"mono_wasm_intern_string_ref","void",["number"]],[!1,"mono_wasm_exit","void",["number"]],[!0,"mono_wasm_getenv","number",["string"]],[!0,"mono_wasm_set_main_args","void",["number","number"]],[()=>!ct.emscriptenBuildOptions.enableAotProfiler,"mono_wasm_profiler_init_aot","void",["string"]],[()=>!ct.emscriptenBuildOptions.enableDevToolsProfiler,"mono_wasm_profiler_init_browser_devtools","void",["string"]],[()=>!ct.emscriptenBuildOptions.enableLogProfiler,"mono_wasm_profiler_init_log","void",["string"]],[!1,"mono_wasm_exec_regression","number",["number","string"]],[!1,"mono_wasm_invoke_jsexport","void",["number","number"]],[!0,"mono_wasm_write_managed_pointer_unsafe","void",["number","number"]],[!0,"mono_wasm_copy_managed_pointer","void",["number","number"]],[!0,"mono_wasm_i52_to_f64","number",["number","number"]],[!0,"mono_wasm_u52_to_f64","number",["number","number"]],[!0,"mono_wasm_f64_to_i52","number",["number","number"]],[!0,"mono_wasm_f64_to_u52","number",["number","number"]],[!0,"mono_wasm_method_get_name","number",["number"]],[!0,"mono_wasm_method_get_name_ex","number",["number"]],[!0,"mono_wasm_method_get_full_name","number",["number"]],[!0,"mono_wasm_gc_lock","void",[]],[!0,"mono_wasm_gc_unlock","void",[]],[!0,"mono_wasm_get_i32_unaligned","number",["number"]],[!0,"mono_wasm_get_f32_unaligned","number",["number"]],[!0,"mono_wasm_get_f64_unaligned","number",["number"]],[!0,"mono_wasm_read_as_bool_or_null_unsafe","number",["number"]],[!0,"mono_jiterp_trace_bailout","void",["number"]],[!0,"mono_jiterp_get_trace_bailout_count","number",["number"]],[!0,"mono_jiterp_value_copy","void",["number","number","number"]],[!0,"mono_jiterp_get_member_offset","number",["number"]],[!0,"mono_jiterp_encode_leb52","number",["number","number","number"]],[!0,"mono_jiterp_encode_leb64_ref","number",["number","number","number"]],[!0,"mono_jiterp_encode_leb_signed_boundary","number",["number","number","number"]],[!0,"mono_jiterp_write_number_unaligned","void",["number","number","number"]],[!0,"mono_jiterp_type_is_byref","number",["number"]],[!0,"mono_jiterp_get_size_of_stackval","number",[]],[!0,"mono_jiterp_parse_option","number",["string"]],[!0,"mono_jiterp_get_options_as_json","number",[]],[!0,"mono_jiterp_get_option_as_int","number",["string"]],[!0,"mono_jiterp_get_options_version","number",[]],[!0,"mono_jiterp_adjust_abort_count","number",["number","number"]],[!0,"mono_jiterp_register_jit_call_thunk","void",["number","number"]],[!0,"mono_jiterp_type_get_raw_value_size","number",["number"]],[!0,"mono_jiterp_get_signature_has_this","number",["number"]],[!0,"mono_jiterp_get_signature_return_type","number",["number"]],[!0,"mono_jiterp_get_signature_param_count","number",["number"]],[!0,"mono_jiterp_get_signature_params","number",["number"]],[!0,"mono_jiterp_type_to_ldind","number",["number"]],[!0,"mono_jiterp_type_to_stind","number",["number"]],[!0,"mono_jiterp_imethod_to_ftnptr","number",["number"]],[!0,"mono_jiterp_debug_count","number",[]],[!0,"mono_jiterp_get_trace_hit_count","number",["number"]],[!0,"mono_jiterp_get_polling_required_address","number",[]],[!0,"mono_jiterp_get_rejected_trace_count","number",[]],[!0,"mono_jiterp_boost_back_branch_target","void",["number"]],[!0,"mono_jiterp_is_imethod_var_address_taken","number",["number","number"]],[!0,"mono_jiterp_get_opcode_value_table_entry","number",["number"]],[!0,"mono_jiterp_get_simd_intrinsic","number",["number","number"]],[!0,"mono_jiterp_get_simd_opcode","number",["number","number"]],[!0,"mono_jiterp_get_arg_offset","number",["number","number","number"]],[!0,"mono_jiterp_get_opcode_info","number",["number","number"]],[!0,"mono_wasm_is_zero_page_reserved","number",[]],[!0,"mono_jiterp_is_special_interface","number",["number"]],[!0,"mono_jiterp_initialize_table","void",["number","number","number"]],[!0,"mono_jiterp_allocate_table_entry","number",["number"]],[!0,"mono_jiterp_get_interp_entry_func","number",["number"]],[!0,"mono_jiterp_get_counter","number",["number"]],[!0,"mono_jiterp_modify_counter","number",["number","number"]],[!0,"mono_jiterp_tlqueue_next","number",["number"]],[!0,"mono_jiterp_tlqueue_add","number",["number","number"]],[!0,"mono_jiterp_tlqueue_clear","void",["number"]],[!0,"mono_jiterp_begin_catch","void",["number"]],[!0,"mono_jiterp_end_catch","void",[]],[!0,"mono_interp_pgo_load_table","number",["number","number"]],[!0,"mono_interp_pgo_save_table","number",["number","number"]],[()=>!ct.emscriptenBuildOptions.enableEventPipe&&!ct.emscriptenBuildOptions.enableDevToolsProfiler,"mono_jiterp_prof_enter","void",["number","number"]],[()=>!ct.emscriptenBuildOptions.enableEventPipe&&!ct.emscriptenBuildOptions.enableDevToolsProfiler,"mono_jiterp_prof_samplepoint","void",["number","number"]],[()=>!ct.emscriptenBuildOptions.enableEventPipe&&!ct.emscriptenBuildOptions.enableDevToolsProfiler,"mono_jiterp_prof_leave","void",["number","number"]]],o={},s=o,a=o,i=["void","number",null];function c(e,t,n,r){let o=void 0===r&&i.indexOf(t)>=0&&(!n||n.every((e=>i.indexOf(e)>=0)))&&Ke.wasmExports?Ke.wasmExports[e]:void 0;if(o&&n&&o.length!==n.length&&(He(`argument count mismatch for cwrap ${e}`),o=void 0),"function"!=typeof o&&(o=Ke.cwrap(e,t,n,r)),"function"!=typeof o)throw new Error(`cwrap ${e} not found or not a function`);return o}const l=0,p=0,u=0,d=BigInt("9223372036854775807"),f=BigInt("-9223372036854775808");function _(e){return Ke._malloc(e)>>>0}function m(e){Ke._free(e)}function h(e,t,n){if(!Number.isSafeInteger(e))throw new Error(`Assert failed: Value is not an integer: ${e} (${typeof e})`);if(!(e>=t&&e<=n))throw new Error(`Assert failed: Overflow: value ${e} is out of ${t} ${n} range`)}function g(e,t){K().fill(0,e,e+t)}function b(e,t){const n=!!t;"number"==typeof t&&h(t,0,1),Ke.HEAP32[e>>>2]=n?1:0}function y(e,t){const n=!!t;"number"==typeof t&&h(t,0,1),Ke.HEAPU8[e]=n?1:0}function w(e,t){h(t,0,255),Ke.HEAPU8[e]=t}function k(e,t){h(t,0,65535),Ke.HEAPU16[e>>>1]=t}function S(e,t){h(t,0,4294967295),Ke.HEAPU32[e>>>2]=t}function v(e,t){h(t,-128,127),Ke.HEAP8[e]=t}function U(e,t){h(t,-32768,32767),Ke.HEAP16[e>>>1]=t}function T(e,t){h(t,-2147483648,2147483647),Ke.HEAP32[e>>>2]=t}function E(e){if(0!==e)switch(e){case 1:throw new Error("value was not an integer");case 2:throw new Error("value out of range");default:throw new Error("unknown internal error")}}function x(e,t){if(!Number.isSafeInteger(t))throw new Error(`Assert failed: Value is not a safe integer: ${t} (${typeof t})`);E(o.mono_wasm_f64_to_i52(e,t))}function I(e,t){if(!Number.isSafeInteger(t))throw new Error(`Assert failed: Value is not a safe integer: ${t} (${typeof t})`);if(!(t>=0))throw new Error("Assert failed: Can't convert negative Number into UInt64");E(o.mono_wasm_f64_to_u52(e,t))}function A(e,t){if("bigint"!=typeof t)throw new Error(`Assert failed: Value is not an bigint: ${t} (${typeof t})`);if(!(t>=f&&t<=d))throw new Error(`Assert failed: Overflow: value ${t} is out of ${f} ${d} range`);Ke.HEAP64[e>>>3]=t}function j(e,t){if("number"!=typeof t)throw new Error(`Assert failed: Value is not a Number: ${t} (${typeof t})`);Ke.HEAPF32[e>>>2]=t}function $(e,t){if("number"!=typeof t)throw new Error(`Assert failed: Value is not a Number: ${t} (${typeof t})`);Ke.HEAPF64[e>>>3]=t}let L=!0;function R(e){const t=Ke.HEAPU32[e>>>2];return t>1&&L&&(L=!1,We(`getB32: value at ${e} is not a boolean, but a number: ${t}`)),!!t}function B(e){return!!Ke.HEAPU8[e]}function N(e){return Ke.HEAPU8[e]}function O(e){return Ke.HEAPU16[e>>>1]}function C(e){return Ke.HEAPU32[e>>>2]}function D(e,t){return e[t>>>2]}function F(e){return o.mono_wasm_get_i32_unaligned(e)}function P(e){return o.mono_wasm_get_i32_unaligned(e)>>>0}function M(e){return Ke.HEAP8[e]}function z(e){return Ke.HEAP16[e>>>1]}function V(e){return Ke.HEAP32[e>>>2]}function W(e){const t=o.mono_wasm_i52_to_f64(e,ct._i52_error_scratch_buffer);return E(V(ct._i52_error_scratch_buffer)),t}function H(e){const t=o.mono_wasm_u52_to_f64(e,ct._i52_error_scratch_buffer);return E(V(ct._i52_error_scratch_buffer)),t}function q(e){return Ke.HEAP64[e>>>3]}function G(e){return Ke.HEAPF32[e>>>2]}function J(e){return Ke.HEAPF64[e>>>3]}function X(){return Ke.HEAP8}function Q(){return Ke.HEAP16}function Y(){return Ke.HEAP32}function Z(){return Ke.HEAP64}function K(){return Ke.HEAPU8}function ee(){return Ke.HEAPU16}function te(){return Ke.HEAPU32}function ne(){return Ke.HEAPF32}function re(){return Ke.HEAPF64}function oe(e,t){return e>>>t}let se=!1;function ae(){if(se)throw new Error("GC is already locked");se=!0}function ie(){if(!se)throw new Error("GC is not locked");se=!1}const ce=8192;let le=null,pe=null,ue=0;const de=[],fe=[];function _e(e,t){if(e<=0)throw new Error("capacity >= 1");const n=4*(e|=0),r=_(n);if(r%4!=0)throw new Error("Malloc returned an unaligned offset");return g(r,n),new me(r,e,!0,t)}class me{constructor(e,t,n,r){const s=4*t;this.__offset=e,this.__offset32=e>>>2,this.__count=t,this.length=t,this.__handle=o.mono_wasm_register_root(e,s,r||"noname"),this.__ownsAllocation=n}_throw_index_out_of_range(){throw new Error("index out of range")}_check_in_range(e){(e>=this.__count||e<0)&&this._throw_index_out_of_range()}get_address(e){return this._check_in_range(e),this.__offset+4*e}get_address_32(e){return this._check_in_range(e),this.__offset32+e}get(e){this._check_in_range(e);const t=this.get_address_32(e);return te()[t]}set(e,t){const n=this.get_address(e);return o.mono_wasm_write_managed_pointer_unsafe(n,t),t}copy_value_from_address(e,t){const n=this.get_address(e);o.mono_wasm_copy_managed_pointer(n,t)}_unsafe_get(e){return te()[this.__offset32+e]}_unsafe_set(e,t){const n=this.__offset+e;o.mono_wasm_write_managed_pointer_unsafe(n,t)}clear(){this.__offset&&g(this.__offset,4*this.__count)}release(){this.__offset&&this.__ownsAllocation&&(o.mono_wasm_deregister_root(this.__offset),g(this.__offset,4*this.__count),m(this.__offset)),this.__handle=this.__offset=this.__count=this.__offset32=0}toString(){return`[root buffer @${this.get_address(0)}, size ${this.__count} ]`}}class he{constructor(e,t){this.__buffer=e,this.__index=t}get_address(){return this.__buffer.get_address(this.__index)}get_address_32(){return this.__buffer.get_address_32(this.__index)}get address(){return this.__buffer.get_address(this.__index)}get(){return this.__buffer._unsafe_get(this.__index)}set(e){const t=this.__buffer.get_address(this.__index);return o.mono_wasm_write_managed_pointer_unsafe(t,e),e}copy_from(e){const t=e.address,n=this.address;o.mono_wasm_copy_managed_pointer(n,t)}copy_to(e){const t=this.address,n=e.address;o.mono_wasm_copy_managed_pointer(n,t)}copy_from_address(e){const t=this.address;o.mono_wasm_copy_managed_pointer(t,e)}copy_to_address(e){const t=this.address;o.mono_wasm_copy_managed_pointer(e,t)}get value(){return this.get()}set value(e){this.set(e)}valueOf(){throw new Error("Implicit conversion of roots to pointers is no longer supported. Use .value or .address as appropriate")}clear(){const e=this.__buffer.get_address_32(this.__index);te()[e]=0}release(){if(!this.__buffer)throw new Error("No buffer");var e;de.length>128?(void 0!==(e=this.__index)&&(le.set(e,0),pe[ue]=e,ue++),this.__buffer=null,this.__index=0):(this.set(0),de.push(this))}toString(){return`[root @${this.address}]`}}class ge{constructor(e){this.__external_address=0,this.__external_address_32=0,this._set_address(e)}_set_address(e){this.__external_address=e,this.__external_address_32=e>>>2}get address(){return this.__external_address}get_address(){return this.__external_address}get_address_32(){return this.__external_address_32}get(){return te()[this.__external_address_32]}set(e){return o.mono_wasm_write_managed_pointer_unsafe(this.__external_address,e),e}copy_from(e){const t=e.address,n=this.__external_address;o.mono_wasm_copy_managed_pointer(n,t)}copy_to(e){const t=this.__external_address,n=e.address;o.mono_wasm_copy_managed_pointer(n,t)}copy_from_address(e){const t=this.__external_address;o.mono_wasm_copy_managed_pointer(t,e)}copy_to_address(e){const t=this.__external_address;o.mono_wasm_copy_managed_pointer(e,t)}get value(){return this.get()}set value(e){this.set(e)}valueOf(){throw new Error("Implicit conversion of roots to pointers is no longer supported. Use .value or .address as appropriate")}clear(){te()[this.__external_address>>>2]=0}release(){fe.length<128&&fe.push(this)}toString(){return`[external root @${this.address}]`}}const be=new Map,ye="";let we;const ke=new Map;let Se,ve,Ue,Te,Ee,xe=0,Ie=null,Ae=0;function je(e){if(void 0===Te){const t=Ke.lengthBytesUTF8(e),n=new Uint8Array(t);return Ke.stringToUTF8Array(e,n,0,t),n}return Te.encode(e)}function $e(e){const t=Ke.lengthBytesUTF8(e)+1,n=_(t),r=K().subarray(n,n+t);return Ke.stringToUTF8Array(e,r,0,t),r[t-1]=0,n}function Le(e){const t=K();return function(e,t,n){const r=t+n;let o=t;for(;e[o]&&!(o>=r);)++o;if(o-t<=16)return Ke.UTF8ArrayToString(e,t,n);if(void 0===Ue)return Ke.UTF8ArrayToString(e,t,n);const s=Fe(e,t,o);return Ue.decode(s)}(t,e,t.length-e)}function Re(e,t){if(Se){const n=Fe(K(),e,t);return Se.decode(n)}return function(e,t){let n="";const r=ee();for(let o=e;o>>1];n+=String.fromCharCode(e)}return n}(e,t)}function Be(e,t,n){const r=ee(),o=n.length;for(let c=0;c>>1]=i,!((e+=2)>=t));c++);var s,a,i}function Ne(e){const t=2*(e.length+1),n=_(t);return g(n,2*e.length),Be(n,n+t,e),n}function Oe(e){if(e.value===p)return null;const t=we+0,n=we+4,r=we+8;let s;o.mono_wasm_string_get_data_ref(e.address,t,n,r);const a=te(),i=D(a,n),c=D(a,t),l=D(a,r);if(l&&(s=ke.get(e.value)),void 0===s&&(i&&c?(s=Re(c,c+i),l&&ke.set(e.value,s)):s=ye),void 0===s)throw new Error(`internal error when decoding string at location ${e.value}`);return s}function Ce(e,t){let n;if("symbol"==typeof e?(n=e.description,"string"!=typeof n&&(n=Symbol.keyFor(e)),"string"!=typeof n&&(n="")):"string"==typeof e&&(n=e),"string"!=typeof n)throw new Error(`Argument to stringToInternedMonoStringRoot must be a string but was ${e}`);if(0===n.length&&xe)return void t.set(xe);const r=be.get(n);r?t.set(r):(De(n,t),function(e,t,n){if(!t.value)throw new Error("null pointer passed to _store_string_in_intern_table");Ae>=8192&&(Ie=null),Ie||(Ie=_e(8192,"interned strings"),Ae=0);const r=Ie,s=Ae++;if(o.mono_wasm_intern_string_ref(t.address),!t.value)throw new Error("mono_wasm_intern_string_ref produced a null pointer");be.set(e,t.value),ke.set(t.value,e),0!==e.length||xe||(xe=t.value),r.copy_value_from_address(s,t.address)}(n,t))}function De(e,t){const n=2*(e.length+1),r=_(n);Be(r,r+n,e),o.mono_wasm_string_from_utf16_ref(r,e.length,t.address),m(r)}function Fe(e,t,n){return e.buffer,e.subarray(t,n)}function Pe(e){if(e===p)return null;Ee.value=e;const t=Oe(Ee);return Ee.value=p,t}let Me="MONO_WASM: ";function ze(e){if(ct.diagnosticTracing){const t="function"==typeof e?e():e;console.debug(Me+t)}}function Ve(e,...t){console.info(Me+e,...t)}function We(e,...t){console.warn(Me+e,...t)}function He(e,...t){if(t&&t.length>0&&t[0]&&"object"==typeof t[0]){if(t[0].silent)return;if(t[0].toString)return void console.error(Me+e,t[0].toString())}console.error(Me+e,...t)}const qe=new Map;let Ge;const Je=[];function Xe(e){try{if(Ye(),0==qe.size)return e;const t=e;for(let n=0;n{const n=t.find((e=>"object"==typeof e&&void 0!==e.replaceSection));if(void 0===n)return e;const r=n.funcNum,o=n.replaceSection,s=qe.get(Number(r));return void 0===s?e:e.replace(o,`${s} (${o})`)}));if(r!==t)return r}return t}catch(t){return console.debug(`failed to symbolicate: ${t}`),e}}function Qe(e){let t;return t="string"==typeof e?e:null==e||void 0===e.stack?(new Error).stack+"":e.stack+"",Xe(t)}function Ye(){if(!Ge)return;Je.push(/at (?[^:()]+:wasm-function\[(?\d+)\]:0x[a-fA-F\d]+)((?![^)a-fA-F\d])|$)/),Je.push(/(?:WASM \[[\da-zA-Z]+\], (?function #(?[\d]+) \(''\)))/),Je.push(/(?[a-z]+:\/\/[^ )]*:wasm-function\[(?\d+)\]:0x[a-fA-F\d]+)/),Je.push(/(?<[^ >]+>[.:]wasm-function\[(?[0-9]+)\])/);const e=Ge;Ge=void 0;try{e.split(/[\r\n]/).forEach((e=>{const t=e.split(/:/);t.length<2||(t[1]=t.splice(1).join(":"),qe.set(Number(t[0]),t[1]))})),lt.diagnosticTracing&&ze(`Loaded ${qe.size} symbols`)}catch(e){We(`Failed to load symbol map: ${e}`)}}function Ze(){return Ye(),[...qe.values()]}let Ke,et;const tt="object"==typeof process&&"object"==typeof process.versions&&"string"==typeof process.versions.node,nt="function"==typeof importScripts,rt=nt&&"undefined"!=typeof dotnetSidecar,ot=nt&&!rt,st="object"==typeof window||nt&&!tt,at=!st&&!tt;let it=null,ct=null,lt=null,pt=null,ut=!1;function dt(e,t){ct.emscriptenBuildOptions=t,e.isPThread,ct.quit=e.quit_,ct.ExitStatus=e.ExitStatus,ct.getMemory=e.getMemory,ct.getWasmIndirectFunctionTable=e.getWasmIndirectFunctionTable,ct.updateMemoryViews=e.updateMemoryViews}function ft(e){if(ut)throw new Error("Runtime module already loaded");ut=!0,Ke=e.module,et=e.internal,ct=e.runtimeHelpers,lt=e.loaderHelpers,pt=e.diagnosticHelpers,it=e.api;const t={gitHash:"f7d90799ce4ef09a0bb257852a57248d2a8fb8dd",coreAssetsInMemory:_t(),allAssetsInMemory:_t(),dotnetReady:_t(),afterInstantiateWasm:_t(),beforePreInit:_t(),afterPreInit:_t(),afterPreRun:_t(),beforeOnRuntimeInitialized:_t(),afterMonoStarted:_t(),afterDeputyReady:_t(),afterIOStarted:_t(),afterOnRuntimeInitialized:_t(),afterPostRun:_t(),nativeAbort:e=>{throw e||new Error("abort")},nativeExit:e=>{throw new Error("exit:"+e)}};Object.assign(ct,t),Object.assign(e.module.config,{}),Object.assign(e.api,{Module:e.module,...e.module}),Object.assign(e.api,{INTERNAL:e.internal})}function _t(e,t){return lt.createPromiseController(e,t)}function mt(e,t){if(e)return;const n="Assert failed: "+("function"==typeof t?t():t),r=new Error(n);He(n,r),ct.nativeAbort(r)}function ht(e,t,n){const r=function(e,t,n){let r,o=0;r=e.length-o;const s={read:function(){if(o>=r)return null;const t=e[o];return o+=1,t}};return Object.defineProperty(s,"eof",{get:function(){return o>=r},configurable:!0,enumerable:!0}),s}(e);let o="",s=0,a=0,i=0,c=0,l=0,p=0;for(;s=r.read(),a=r.read(),i=r.read(),null!==s;)null===a&&(a=0,l+=1),null===i&&(i=0,l+=1),p=s<<16|a<<8|i,c=(16777215&p)>>18,o+=gt[c],c=(262143&p)>>12,o+=gt[c],l<2&&(c=(4095&p)>>6,o+=gt[c]),2===l?o+="==":1===l?o+="=":(c=63&p,o+=gt[c]);return o}const gt=["A","B","C","D","E","F","G","H","I","J","K","L","M","N","O","P","Q","R","S","T","U","V","W","X","Y","Z","a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q","r","s","t","u","v","w","x","y","z","0","1","2","3","4","5","6","7","8","9","+","/"],bt=new Map;bt.remove=function(e){const t=this.get(e);return this.delete(e),t};let yt,wt,kt,St={},vt=0,Ut=-1;function mono_wasm_fire_debugger_agent_message_with_data_to_pause(e){console.assert(!0,`mono_wasm_fire_debugger_agent_message_with_data ${e}`);debugger}function Tt(e){e.length>Ut&&(yt&&m(yt),Ut=Math.max(e.length,Ut,256),yt=_(Ut));const t=atob(e),n=K();for(let e=0;ee.value)),e;if(void 0===t.dimensionsDetails||1===t.dimensionsDetails.length)return e=t.items.map((e=>e.value)),e}const n={};return Object.keys(t).forEach((e=>{const r=t[e];void 0!==r.get?Object.defineProperty(n,r.name,{get:()=>xt(r.get.id,r.get.commandSet,r.get.command,r.get.buffer),set:function(e){return Et(r.set.id,r.set.commandSet,r.set.command,r.set.buffer,r.set.length,r.set.valtype,e),!0}}):void 0!==r.set?Object.defineProperty(n,r.name,{get:()=>r.value,set:function(e){return Et(r.set.id,r.set.commandSet,r.set.command,r.set.buffer,r.set.length,r.set.valtype,e),!0}}):n[r.name]=r.value})),n}(t,n);const o=null!=e.arguments?e.arguments.map((e=>JSON.stringify(e.value))):[],s=`const fn = ${e.functionDeclaration}; return fn.apply(proxy, [${o}]);`,a=new Function("proxy",s)(r);if(void 0===a)return{type:"undefined"};if(Object(a)!==a)return"object"==typeof a&&null==a?{type:typeof a,subtype:`${a}`,value:null}:{type:typeof a,description:`${a}`,value:`${a}`};if(e.returnByValue&&null==a.subtype)return{type:"object",value:a};if(Object.getPrototypeOf(a)==Array.prototype){const e=Ot(a);return{type:"object",subtype:"array",className:"Array",description:`Array(${a.length})`,objectId:e}}return void 0!==a.value||void 0!==a.subtype?a:a==r?{type:"object",className:"Object",description:"Object",objectId:t}:{type:"object",className:"Object",description:"Object",objectId:Ot(a)}}function Nt(e,t={}){return function(e,t){if(!(e in St))throw new Error(`Could not find any object with id ${e}`);const n=St[e],r=Object.getOwnPropertyDescriptors(n);t.accessorPropertiesOnly&&Object.keys(r).forEach((e=>{void 0===r[e].get&&Reflect.deleteProperty(r,e)}));const o=[];return Object.keys(r).forEach((e=>{let t;const n=r[e];t="object"==typeof n.value?Object.assign({name:e},n):void 0!==n.value?{name:e,value:Object.assign({type:typeof n.value,description:""+n.value},n)}:void 0!==n.get?{name:e,get:{className:"Function",description:`get ${e} () {}`,type:"function"}}:{name:e,value:{type:"symbol",value:"",description:""}},o.push(t)})),{__value_as_json_string__:JSON.stringify(o)}}(`dotnet:cfo_res:${e}`,t)}function Ot(e){const t="dotnet:cfo_res:"+vt++;return St[t]=e,t}function Ct(e){e in St&&delete St[e]}let Dt=!1;function Ft(){if(Dt)return globalThis.performance.now()}function Pt(e,t,n){if(Dt&&e){const r=st?{start:e}:{startTime:e},o=n?`${t}${n} `:t;globalThis.performance.measure(o,r)}}const Mt=new Map;function zt(e,t,n){if(0===t||1===t||2===t||26===t)return;let r,o,s,a;o=to(Cn(e)),s=to(Dn(e)),a=to(Fn(e));const i=On(e);r=Vt(i),19===t&&(t=i);const c=Vt(t),l=Cn(e),p=n*In;return e=>c(e+p,l,r,o,s,a)}function Vt(e){if(0===e||1===e)return;const t=vn.get(e);return t&&"function"==typeof t||mt(!1,`ERR41: Unknown converter for type ${e}. ${Kr}`),t}function Wt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),B(e)}(e)}function Ht(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),N(e)}(e)}function qt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),O(e)}(e)}function Gt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),z(e)}(e)}function Jt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),V(e)}(e)}function Xt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),J(e)}(e)}function Qt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),q(e)}(e)}function Yt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),G(e)}(e)}function Zt(e){return 0==zn(e)?null:function(e){return e||mt(!1,"Null arg"),J(e)}(e)}function Kt(e){return 0==zn(e)?null:Hn(e)}function en(){return null}function tn(e){return 0===zn(e)?null:function(e){e||mt(!1,"Null arg");const t=J(e);return new Date(t)}(e)}function nn(e,t,n,r,o,s){if(0===zn(e))return null;const a=Zn(e);let i=qr(a);return null==i&&(i=(e,t,i)=>function(e,t,n,r,o,s,a,i){lt.assert_runtime_running();const c=Ke.stackSave();try{const c=$n(6),l=Ln(c,2);if(Wn(l,14),Kn(l,e),s&&s(Ln(c,3),t),a&&a(Ln(c,4),n),i&&i(Ln(c,5),r),kn(yn.CallDelegate,c),o)return o(Ln(c,1))}finally{lt.is_runtime_running()&&Ke.stackRestore(c)}}(a,e,t,i,n,r,o,s),i.dispose=()=>{i.isDisposed||(i.isDisposed=!0,Vr(i,a))},i.isDisposed=!1,zr(i,a)),i}class rn{constructor(e,t){this.promise=e,this.resolve_or_reject=t}}function on(e,t,n){const r=zn(e);30==r&&mt(!1,"Unexpected Task type: TaskPreCreated");const o=cn(e,r,n);if(!1!==o)return o;const s=Qn(e),a=ln(n);return function(e,t){hr(),xr[0-t]=e,Object.isExtensible(e)&&(e[Cr]=t)}(a,s),a.promise}function sn(e,t,n){const r=ln(n);return Yn(e,Pr(r)),Wn(e,30),r.promise}function an(e,t,n){const r=Ln(e,1),o=zn(r);if(30===o)return n;Mr(Pr(n));const s=cn(r,o,t);return!1===s&&mt(!1,`Expected synchronous result, got: ${o}`),s}function cn(e,t,n){if(0===t)return null;if(29===t)return Promise.reject(un(e));if(28===t){const t=Vn(e);if(1===t)return Promise.resolve();Wn(e,t),n||(n=vn.get(t)),n||mt(!1,`Unknown sub_converter for type ${t}. ${Kr}`);const r=n(e);return Promise.resolve(r)}return!1}function ln(e){const{promise:t,promise_control:n}=lt.createPromiseController();return new rn(t,((t,r,o)=>{if(29===t){const e=un(o);n.reject(e)}else if(28===t){const t=zn(o);if(1===t)n.resolve(void 0);else{e||(e=vn.get(t)),e||mt(!1,`Unknown sub_converter for type ${t}. ${Kr}`);const r=e(o);n.resolve(r)}}else mt(!1,`Unexpected type ${t}`);Mr(r)}))}function pn(e){if(0==zn(e))return null;{const t=er(e);try{return Oe(t)}finally{t.release()}}}function un(e){const t=zn(e);if(0==t)return null;if(27==t)return Fr(Qn(e));const n=Zn(e);let r=qr(n);if(null==r){const t=pn(e);r=new ManagedError(t),zr(r,n)}return r}function dn(e){if(0==zn(e))return null;const t=Qn(e),n=Fr(t);return void 0===n&&mt(!1,`JS object JSHandle ${t} was not found`),n}function fn(e){const t=zn(e);if(0==t)return null;if(13==t)return Fr(Qn(e));if(21==t)return mn(e,Vn(e));if(14==t){const t=Zn(e);if(t===u)return null;let n=qr(t);return n||(n=new ManagedObject,zr(n,t)),n}const n=vn.get(t);return n||mt(!1,`Unknown converter for type ${t}. ${Kr}`),n(e)}function _n(e,t){return t||mt(!1,"Expected valid element_type parameter"),mn(e,t)}function mn(e,t){if(0==zn(e))return null;-1==rr(t)&&mt(!1,`Element type ${t} not supported`);const n=Hn(e),r=tr(e);let s=null;if(15==t){s=new Array(r);for(let e=0;e0?(t=fe.pop(),t._set_address(e)):t=new ge(e),t}(e)}function tr(e){return e||mt(!1,"Null arg"),V(e+8)}function nr(e,t){e||mt(!1,"Null arg"),T(e+8,t)}class ManagedObject{dispose(){Vr(this,u)}get isDisposed(){return this[Or]===u}toString(){return`CsObject(gc_handle: ${this[Or]})`}}class ManagedError extends Error{constructor(e){super(e),this.superStack=Object.getOwnPropertyDescriptor(this,"stack"),Object.defineProperty(this,"stack",{get:this.getManageStack})}getSuperStack(){if(this.superStack){if(void 0!==this.superStack.value)return this.superStack.value;if(void 0!==this.superStack.get)return this.superStack.get.call(this)}return super.stack}getManageStack(){if(this.managed_stack)return this.managed_stack;if(!lt.is_runtime_running())return this.managed_stack="... omitted managed stack trace.\n"+this.getSuperStack(),this.managed_stack;{const e=this[Or];if(e!==u){const t=function(e){lt.assert_runtime_running();const t=Ke.stackSave();try{const t=$n(3),n=Ln(t,2);return Wn(n,16),Kn(n,e),kn(yn.GetManagedStackTrace,t),pn(Ln(t,1))}finally{lt.is_runtime_running()&&Ke.stackRestore(t)}}(e);if(t)return this.managed_stack=t+"\n"+this.getSuperStack(),this.managed_stack}}return this.getSuperStack()}dispose(){Vr(this,u)}get isDisposed(){return this[Or]===u}}function rr(e){return 4==e?1:7==e?4:8==e||10==e?8:15==e||14==e||13==e?In:-1}class or{constructor(e,t,n){this._pointer=e,this._length=t,this._viewType=n}_unsafe_create_view(){const e=0==this._viewType?new Uint8Array(K().buffer,this._pointer,this._length):1==this._viewType?new Int32Array(Y().buffer,this._pointer,this._length):2==this._viewType?new Float64Array(re().buffer,this._pointer,this._length):null;if(!e)throw new Error("NotImplementedException");return e}set(e,t){if(this.isDisposed)throw new Error("Assert failed: ObjectDisposedException");const n=this._unsafe_create_view();if(!e||!n||e.constructor!==n.constructor)throw new Error(`Assert failed: Expected ${n.constructor}`);n.set(e,t)}copyTo(e,t){if(this.isDisposed)throw new Error("Assert failed: ObjectDisposedException");const n=this._unsafe_create_view();if(!e||!n||e.constructor!==n.constructor)throw new Error(`Assert failed: Expected ${n.constructor}`);const r=n.subarray(t);e.set(r)}slice(e,t){if(this.isDisposed)throw new Error("Assert failed: ObjectDisposedException");return this._unsafe_create_view().slice(e,t)}get length(){if(this.isDisposed)throw new Error("Assert failed: ObjectDisposedException");return this._length}get byteLength(){if(this.isDisposed)throw new Error("Assert failed: ObjectDisposedException");return 0==this._viewType?this._length:1==this._viewType?this._length<<2:2==this._viewType?this._length<<3:0}}class Span extends or{constructor(e,t,n){super(e,t,n),this.is_disposed=!1}dispose(){this.is_disposed=!0}get isDisposed(){return this.is_disposed}}class ArraySegment extends or{constructor(e,t,n){super(e,t,n)}dispose(){Vr(this,u)}get isDisposed(){return this[Or]===u}}const sr=[null];function ar(e){const t=e.args_count,r=e.arg_marshalers,o=e.res_converter,s=e.arg_cleanup,a=e.has_cleanup,i=e.fn,c=e.fqn;return e=null,function(l){const p=Ft();try{n&&e.isDisposed;const c=new Array(t);for(let e=0;e{const o=await n;return r&&(_r.set(e,o),lt.diagnosticTracing&&ze(`imported ES6 module '${e}' from '${t}'`)),o}))}function hr(){lt.assert_runtime_running(),ct.mono_wasm_bindings_is_ready||mt(!1,"The runtime must be initialized.")}function gr(e){e()}const br="function"==typeof globalThis.WeakRef;function yr(e){return br?new WeakRef(e):function(e){return{deref:()=>e,dispose:()=>{e=null}}}(e)}function wr(e,t,n,r,o,s,a){const i=`[${t}] ${n}.${r}:${o}`,c=Ft();lt.diagnosticTracing&&ze(`Binding [JSExport] ${n}.${r}:${o} from ${t} assembly`);const l=Mn(a);2!==l&&mt(!1,`Signature version ${l} mismatch.`);const p=Pn(a),u=new Array(p);for(let e=0;e0}function Nr(e){return e<-1}Ur&&(Tr=new globalThis.FinalizationRegistry(Hr));const Or=Symbol.for("wasm js_owned_gc_handle"),Cr=Symbol.for("wasm cs_owned_js_handle"),Dr=Symbol.for("wasm do_not_force_dispose");function Fr(e){return Br(e)?Er[e]:Rr(e)?xr[0-e]:null}function Pr(e){if(hr(),e[Cr])return e[Cr];const t=Ir.length?Ir.pop():Ar++;return Er[t]=e,Object.isExtensible(e)&&("function"==typeof e&&Object.prototype.hasOwnProperty.call(e,"prototype")||(e[Cr]=t)),t}function Mr(e){let t;Br(e)?(t=Er[e],Er[e]=void 0,Ir.push(e)):Rr(e)&&(t=xr[0-e],xr[0-e]=void 0),null==t&&mt(!1,"ObjectDisposedException"),void 0!==t[Cr]&&(t[Cr]=void 0)}function zr(e,t){hr(),e[Or]=t,Ur&&Tr.register(e,t,e);const n=yr(e);jr.set(t,n)}function Vr(e,t,r){var o;hr(),e&&(t=e[Or],e[Or]=u,Ur&&Tr.unregister(e)),t!==u&&jr.delete(t)&&!r&<.is_runtime_running()&&!Gr&&function(e){e||mt(!1,"Must be valid gc_handle"),lt.assert_runtime_running();const t=Ke.stackSave();try{const t=$n(3),r=Ln(t,2);Wn(r,14),Kn(r,e),n&&!Nr(e)&&bn.isUI||kn(yn.ReleaseJSOwnedObjectByGCHandle,t)}finally{lt.is_runtime_running()&&Ke.stackRestore(t)}}(t),Nr(t)&&(o=t,$r.push(o))}function Wr(e){const t=e[Or];if(t==u)throw new Error("Assert failed: ObjectDisposedException");return t}function Hr(e){lt.is_runtime_running()&&Vr(null,e)}function qr(e){if(!e)return null;const t=jr.get(e);return t?t.deref():null}let Gr=!1;function Jr(e,t){let n=!1,r=!1;Gr=!0;let o=0,s=0,a=0,i=0;const c=[...jr.keys()];for(const e of c){const r=jr.get(e),o=r&&r.deref();if(Ur&&o&&Tr.unregister(o),o){const s="boolean"==typeof o[Dr]&&o[Dr];if(t&&We(`Proxy of C# ${typeof o} with GCHandle ${e} was still alive. ${s?"keeping":"disposing"}.`),s)n=!0;else{const t=lt.getPromiseController(o);t&&t.reject(new Error("WebWorker which is origin of the Task is being terminated.")),"function"==typeof o.dispose&&o.dispose(),o[Or]===e&&(o[Or]=u),!br&&r&&r.dispose(),a++}}}n||(jr.clear(),Ur&&(Tr=new globalThis.FinalizationRegistry(Hr)));const l=(e,n)=>{const o=n[e],s=o&&"boolean"==typeof o[Dr]&&o[Dr];if(s||(n[e]=void 0),o)if(t&&We(`Proxy of JS ${typeof o} with JSHandle ${e} was still alive. ${s?"keeping":"disposing"}.`),s)r=!0;else{const t=lt.getPromiseController(o);t&&t.reject(new Error("WebWorker which is origin of the Task is being terminated.")),"function"==typeof o.dispose&&o.dispose(),o[Cr]===e&&(o[Cr]=void 0),i++}};for(let e=0;en.resolve(e))).catch((e=>n.reject(e))),t}const Yr=Symbol.for("wasm promise_holder");class Zr extends ManagedObject{constructor(e,t,n,r){super(),this.promise=e,this.gc_handle=t,this.promiseHolderPtr=n,this.res_converter=r,this.isResolved=!1,this.isPosted=!1,this.isPostponed=!1,this.data=null,this.reason=void 0}setIsResolving(){return!0}resolve(e){lt.is_runtime_running()?(this.isResolved&&mt(!1,"resolve could be called only once"),this.isDisposed&&mt(!1,"resolve is already disposed."),this.isResolved=!0,this.complete_task_wrapper(e,null)):lt.diagnosticTracing&&ze("This promise resolution can't be propagated to managed code, mono runtime already exited.")}reject(e){lt.is_runtime_running()?(e||(e=new Error),this.isResolved&&mt(!1,"reject could be called only once"),this.isDisposed&&mt(!1,"resolve is already disposed."),e[Yr],this.isResolved=!0,this.complete_task_wrapper(null,e)):lt.diagnosticTracing&&ze("This promise rejection can't be propagated to managed code, mono runtime already exited.")}cancel(){if(lt.is_runtime_running())if(this.isResolved&&mt(!1,"cancel could be called only once"),this.isDisposed&&mt(!1,"resolve is already disposed."),this.isPostponed)this.isResolved=!0,void 0!==this.reason?this.complete_task_wrapper(null,this.reason):this.complete_task_wrapper(this.data,null);else{const e=this.promise;lt.assertIsControllablePromise(e);const t=lt.getPromiseController(e),n=new Error("OperationCanceledException");n[Yr]=this,t.reject(n)}else lt.diagnosticTracing&&ze("This promise cancelation can't be propagated to managed code, mono runtime already exited.")}complete_task_wrapper(e,t){try{this.isPosted&&mt(!1,"Promise is already posted to managed."),this.isPosted=!0,Vr(this,this.gc_handle,!0),function(e,t,n,r){lt.assert_runtime_running();const o=Ke.stackSave();try{const o=$n(5),s=Ln(o,2);Wn(s,14),Kn(s,e);const a=Ln(o,3);if(t)wo(a,t);else{Wn(a,0);const e=Ln(o,4);r||mt(!1,"res_converter missing"),r(e,n)}wn(ct.ioThreadTID,yn.CompleteTask,o)}finally{lt.is_runtime_running()&&Ke.stackRestore(o)}}(this.gc_handle,t,e,this.res_converter||So)}catch(e){try{lt.mono_exit(1,e)}catch(e){}}}}const Kr="For more information see https://aka.ms/dotnet-wasm-jsinterop";function eo(e,t,n){if(0===t||1===t||2===t||26===t)return;let r,o,s,a;o=Vt(Cn(e)),s=Vt(Dn(e)),a=Vt(Fn(e));const i=On(e);r=to(i),19===t&&(t=i);const c=to(t),l=Cn(e),p=n*In;return(e,t)=>{c(e+p,t,l,r,o,s,a)}}function to(e){if(0===e||1===e)return;const t=Un.get(e);return t&&"function"==typeof t||mt(!1,`ERR30: Unknown converter for type ${e}`),t}function no(e,t){null==t?Wn(e,0):(Wn(e,3),qn(e,t))}function ro(e,t){null==t?Wn(e,0):(Wn(e,4),function(e,t){e||mt(!1,"Null arg"),w(e,t)}(e,t))}function oo(e,t){null==t?Wn(e,0):(Wn(e,5),function(e,t){e||mt(!1,"Null arg"),k(e,t)}(e,t))}function so(e,t){null==t?Wn(e,0):(Wn(e,6),function(e,t){e||mt(!1,"Null arg"),U(e,t)}(e,t))}function ao(e,t){null==t?Wn(e,0):(Wn(e,7),function(e,t){e||mt(!1,"Null arg"),T(e,t)}(e,t))}function io(e,t){null==t?Wn(e,0):(Wn(e,8),function(e,t){if(e||mt(!1,"Null arg"),!Number.isSafeInteger(t))throw new Error(`Assert failed: Value is not an integer: ${t} (${typeof t})`);$(e,t)}(e,t))}function co(e,t){null==t?Wn(e,0):(Wn(e,9),function(e,t){e||mt(!1,"Null arg"),A(e,t)}(e,t))}function lo(e,t){null==t?Wn(e,0):(Wn(e,10),Xn(e,t))}function po(e,t){null==t?Wn(e,0):(Wn(e,11),function(e,t){e||mt(!1,"Null arg"),j(e,t)}(e,t))}function uo(e,t){null==t?Wn(e,0):(Wn(e,12),Gn(e,t))}function fo(e,t){if(null==t)Wn(e,0);else{if(!(t instanceof Date))throw new Error("Assert failed: Value is not a Date");Wn(e,17),Jn(e,t)}}function _o(e,t){if(null==t)Wn(e,0);else{if(!(t instanceof Date))throw new Error("Assert failed: Value is not a Date");Wn(e,18),Jn(e,t)}}function mo(e,t){if(null==t)Wn(e,0);else{if(Wn(e,15),"string"!=typeof t)throw new Error("Assert failed: Value is not a String");ho(e,t)}}function ho(e,t){{const n=er(e);try{!function(e,t){if(t.clear(),null!==e)if("symbol"==typeof e)Ce(e,t);else{if("string"!=typeof e)throw new Error("Expected string argument, got "+typeof e);if(0===e.length)Ce(e,t);else{if(e.length<=256){const n=be.get(e);if(n)return void t.set(n)}De(e,t)}}}(t,n)}finally{n.release()}}}function go(e){Wn(e,0)}function bo(e,t,r,o,s,a,i){if(null==t)return void Wn(e,0);if(!(t&&t instanceof Function))throw new Error("Assert failed: Value is not a Function");const c=function(e){const r=Ln(e,0),l=Ln(e,1),p=Ln(e,2),u=Ln(e,3),d=Ln(e,4),f=ct.isPendingSynchronousCall;try{let e,r,f;n&&c.isDisposed,s&&(e=s(p)),a&&(r=a(u)),i&&(f=i(d)),ct.isPendingSynchronousCall=!0;const _=t(e,r,f);o&&o(l,_)}catch(e){wo(r,e)}finally{ct.isPendingSynchronousCall=f}};c[En]=!0,c.isDisposed=!1,c.dispose=()=>{c.isDisposed=!0},Yn(e,Pr(c)),Wn(e,25)}function yo(e,t,n,r){const o=30==zn(e);if(null==t)return void Wn(e,0);if(!Xr(t))throw new Error("Assert failed: Value is not a Promise");const s=o?Zn(e):$r.length?$r.pop():Lr--;o||(Kn(e,s),Wn(e,20));const a=new Zr(t,s,0,r);zr(a,s),t.then((e=>a.resolve(e)),(e=>a.reject(e)))}function wo(e,t){if(null==t)Wn(e,0);else if(t instanceof ManagedError)Wn(e,16),Kn(e,Wr(t));else{if("object"!=typeof t&&"string"!=typeof t)throw new Error("Assert failed: Value is not an Error "+typeof t);Wn(e,27),ho(e,t.toString());const n=t[Cr];Yn(e,n||Pr(t))}}function ko(e,t){if(null==t)Wn(e,0);else{if(void 0!==t[Or])throw new Error(`Assert failed: JSObject proxy of ManagedObject proxy is not supported. ${Kr}`);if("function"!=typeof t&&"object"!=typeof t)throw new Error(`Assert failed: JSObject proxy of ${typeof t} is not supported`);Wn(e,13),Yn(e,Pr(t))}}function So(e,t){if(null==t)Wn(e,0);else{const n=t[Or],r=typeof t;if(void 0===n)if("string"===r||"symbol"===r)Wn(e,15),ho(e,t);else if("number"===r)Wn(e,10),Xn(e,t);else{if("bigint"===r)throw new Error("NotImplementedException: bigint");if("boolean"===r)Wn(e,3),qn(e,t);else if(t instanceof Date)Wn(e,17),Jn(e,t);else if(t instanceof Error)wo(e,t);else if(t instanceof Uint8Array)Uo(e,t,4);else if(t instanceof Float64Array)Uo(e,t,10);else if(t instanceof Int32Array)Uo(e,t,7);else if(Array.isArray(t))Uo(e,t,14);else{if(t instanceof Int16Array||t instanceof Int8Array||t instanceof Uint8ClampedArray||t instanceof Uint16Array||t instanceof Uint32Array||t instanceof Float32Array)throw new Error("NotImplementedException: TypedArray");if(Xr(t))yo(e,t);else{if(t instanceof Span)throw new Error("NotImplementedException: Span");if("object"!=r)throw new Error(`JSObject proxy is not supported for ${r} ${t}`);{const n=Pr(t);Wn(e,13),Yn(e,n)}}}}else{if(Wr(t),t instanceof ArraySegment)throw new Error("NotImplementedException: ArraySegment. "+Kr);if(t instanceof ManagedError)Wn(e,16),Kn(e,n);else{if(!(t instanceof ManagedObject))throw new Error("NotImplementedException "+r+". "+Kr);Wn(e,14),Kn(e,n)}}}}function vo(e,t,n){n||mt(!1,"Expected valid element_type parameter"),Uo(e,t,n)}function Uo(e,t,n){if(null==t)Wn(e,0);else{const r=rr(n);-1==r&&mt(!1,`Element type ${n} not supported`);const s=t.length,a=r*s,i=_(a);if(15==n){if(!Array.isArray(t))throw new Error("Assert failed: Value is not an Array");g(i,a),o.mono_wasm_register_root(i,a,"marshal_array_to_cs");for(let e=0;e{e&&"AbortError"!==e&&"AbortError"!==e.name&&ze("http muted: "+e)}))}function No(e){try{e.isAborted||(e.streamWriter&&(Bo(e.streamWriter.abort()),e.isAborted=!0),e.streamReader&&(Bo(e.streamReader.cancel()),e.isAborted=!0)),e.isAborted||e.abortController.signal.aborted||e.abortController.abort("AbortError")}catch(e){}}function Oo(e,t,n){n>0||mt(!1,"expected bufferLength > 0");const r=new Span(t,n,0).slice();return Qr((async()=>{e.streamWriter||mt(!1,"expected streamWriter"),e.responsePromise||mt(!1,"expected fetch promise");try{await e.streamWriter.ready,await e.streamWriter.write(r)}catch(e){throw new Error("BrowserHttpWriteStream.Rejected")}}))}function Co(e){return e||mt(!1,"expected controller"),Qr((async()=>{e.streamWriter||mt(!1,"expected streamWriter"),e.responsePromise||mt(!1,"expected fetch promise");try{await e.streamWriter.ready,await e.streamWriter.close()}catch(e){throw new Error("BrowserHttpWriteStream.Rejected")}}))}function Do(e,t,n,r,o,s){const a=new TransformStream;return e.streamWriter=a.writable.getWriter(),Bo(e.streamWriter.closed),Bo(e.streamWriter.ready),Po(e,t,n,r,o,s,a.readable)}function Fo(e,t,n,r,o,s,a,i){return Po(e,t,n,r,o,s,new Span(a,i,0).slice())}function Po(e,t,n,r,o,s,a){jo(),hr(),t&&"string"==typeof t||mt(!1,"expected url string"),n&&r&&Array.isArray(n)&&Array.isArray(r)&&n.length===r.length||mt(!1,"expected headerNames and headerValues arrays"),o&&s&&Array.isArray(o)&&Array.isArray(s)&&o.length===s.length||mt(!1,"expected headerNames and headerValues arrays");const i=new Headers;for(let e=0;elt.fetch_like(t,c).then((t=>(e.response=t,null))))),e.responsePromise.then((()=>{if(e.response||mt(!1,"expected response"),e.responseHeaderNames=[],e.responseHeaderValues=[],e.response.headers&&e.response.headers.entries){const t=e.response.headers.entries();for(const n of t)e.responseHeaderNames.push(n[0]),e.responseHeaderValues.push(n[1])}})).catch((()=>{})),e.responsePromise}function Mo(e){var t;return null===(t=e.response)||void 0===t?void 0:t.type}function zo(e){var t,n;return null!==(n=null===(t=e.response)||void 0===t?void 0:t.status)&&void 0!==n?n:0}function Vo(e){return e.responseHeaderNames||mt(!1,"expected responseHeaderNames"),e.responseHeaderNames}function Wo(e){return e.responseHeaderValues||mt(!1,"expected responseHeaderValues"),e.responseHeaderValues}function Ho(e){return Qr((async()=>{const t=await e.response.arrayBuffer();return e.responseBuffer=t,e.currentBufferOffset=0,t.byteLength}))}function qo(e,t){if(e||mt(!1,"expected controller"),e.responseBuffer||mt(!1,"expected resoved arrayBuffer"),null==e.currentBufferOffset&&mt(!1,"expected currentBufferOffset"),e.currentBufferOffset==e.responseBuffer.byteLength)return 0;const n=new Uint8Array(e.responseBuffer,e.currentBufferOffset);t.set(n,0);const r=Math.min(t.byteLength,n.byteLength);return e.currentBufferOffset+=r,r}function Go(e,t,n){const r=new Span(t,n,0);return Qr((async()=>{if(await e.responsePromise,e.response||mt(!1,"expected response"),!e.response.body)return 0;if(e.streamReader||(e.streamReader=e.response.body.getReader(),Bo(e.streamReader.closed)),e.currentStreamReaderChunk&&void 0!==e.currentBufferOffset||(e.currentStreamReaderChunk=await e.streamReader.read(),e.currentBufferOffset=0),e.currentStreamReaderChunk.done){if(e.isAborted)throw new Error("OperationCanceledException");return 0}const t=e.currentStreamReaderChunk.value.byteLength-e.currentBufferOffset;t>0||mt(!1,"expected remaining_source to be greater than 0");const n=Math.min(t,r.byteLength),o=e.currentStreamReaderChunk.value.subarray(e.currentBufferOffset,e.currentBufferOffset+n);return r.set(o,0),e.currentBufferOffset+=n,t==n&&(e.currentStreamReaderChunk=void 0),n}))}let Jo,Xo,Qo=0;function Yo(){if(!lt.isChromium)return;const e=(new Date).valueOf(),t=e+36e4;for(let n=Math.max(e+1e3,Qo);n=this.queue.length&&(this.queue=this.queue.slice(this.offset),this.offset=0),e}peek(){return this.queue.length>0?this.queue[this.offset]:void 0}drain(e){for(;this.getLength();)e(this.dequeue())}}const ts=Symbol.for("wasm ws_pending_send_buffer"),ns=Symbol.for("wasm ws_pending_send_buffer_offset"),rs=Symbol.for("wasm ws_pending_send_buffer_type"),os=Symbol.for("wasm ws_pending_receive_event_queue"),ss=Symbol.for("wasm ws_pending_receive_promise_queue"),as=Symbol.for("wasm ws_pending_open_promise"),is=Symbol.for("wasm wasm_ws_pending_open_promise_used"),cs=Symbol.for("wasm wasm_ws_pending_error"),ls=Symbol.for("wasm ws_pending_close_promises"),ps=Symbol.for("wasm ws_pending_send_promises"),us=Symbol.for("wasm ws_is_aborted"),ds=Symbol.for("wasm wasm_ws_close_sent"),fs=Symbol.for("wasm wasm_ws_close_received"),_s=Symbol.for("wasm ws_receive_status_ptr"),ms=65536,hs=new Uint8Array;function gs(e){var t,n;return e.readyState!=WebSocket.CLOSED?null!==(t=e.readyState)&&void 0!==t?t:-1:0==e[os].getLength()?null!==(n=e.readyState)&&void 0!==n?n:-1:e[ds]?WebSocket.CLOSING:WebSocket.OPEN}function bs(e,t,n){let r;!function(){if(at)throw new Error("WebSockets are not supported in shell JS engine.");if("function"!=typeof globalThis.WebSocket)throw new Error(tt?"Please install `ws` npm package to enable networking support. See also https://aka.ms/dotnet-wasm-features":"This browser doesn't support WebSocket API. Please use a modern browser. See also https://aka.ms/dotnet-wasm-features")}(),hr(),e&&"string"==typeof e||mt(!1,"ERR12: Invalid uri "+typeof e);try{r=new globalThis.WebSocket(e,t||void 0)}catch(e){throw We("WebSocket error in ws_wasm_create: "+e.toString()),e}const{promise_control:o}=_t();r[os]=new es,r[ss]=new es,r[as]=o,r[ps]=[],r[ls]=[],r[_s]=n,r.binaryType="arraybuffer";const s=()=>{try{if(r[us])return;if(!lt.is_runtime_running())return;o.resolve(r),Yo()}catch(e){We("failed to propagate WebSocket open event: "+e.toString())}},a=e=>{try{if(r[us])return;if(!lt.is_runtime_running())return;!function(e,t){const n=e[os],r=e[ss];if("string"==typeof t.data)n.enqueue({type:0,data:je(t.data),offset:0});else{if("ArrayBuffer"!==t.data.constructor.name)throw new Error("ERR19: WebSocket receive expected ArrayBuffer");n.enqueue({type:1,data:new Uint8Array(t.data),offset:0})}if(r.getLength()&&n.getLength()>1)throw new Error("ERR21: Invalid WS state");for(;r.getLength()&&n.getLength();){const t=r.dequeue();Ts(e,n,t.buffer_ptr,t.buffer_length),t.resolve()}Yo()}(r,e),Yo()}catch(e){We("failed to propagate WebSocket message event: "+e.toString())}},i=e=>{try{if(r.removeEventListener("message",a),r[us])return;if(!lt.is_runtime_running())return;r[fs]=!0,r.close_status=e.code,r.close_status_description=e.reason,r[is]&&o.reject(new Error(e.reason));for(const e of r[ls])e.resolve();Ke.safeSetTimeout((()=>{r[ss].drain((e=>{T(n,0),T(n+4,2),T(n+8,1),e.resolve()}))}),0)}catch(e){We("failed to propagate WebSocket close event: "+e.toString())}},c=e=>{try{if(r[us])return;if(!lt.is_runtime_running())return;r.removeEventListener("message",a);const t=e.message?"WebSocket error: "+e.message:"WebSocket error";We(t),r[cs]=t,Us(r,new Error(t))}catch(e){We("failed to propagate WebSocket error event: "+e.toString())}};return r.addEventListener("message",a),r.addEventListener("open",s,{once:!0}),r.addEventListener("close",i,{once:!0}),r.addEventListener("error",c,{once:!0}),r.dispose=()=>{r.removeEventListener("message",a),r.removeEventListener("open",s),r.removeEventListener("close",i),r.removeEventListener("error",c),vs(r)},r}function ys(e){if(e||mt(!1,"ERR17: expected ws instance"),e[cs])return Es(e[cs]);const t=e[as];return e[is]=!0,t.promise}function ws(e,t,n,r,o){if(e||mt(!1,"ERR17: expected ws instance"),e[cs])return Es(e[cs]);if(e[us]||e[ds])return Es("InvalidState: The WebSocket is not connected.");if(e.readyState==WebSocket.CLOSED)return null;const s=function(e,t,n,r){let o=e[ts],s=0;const a=t.byteLength;if(o){if(s=e[ns],n=e[rs],0!==a){if(s+a>o.length){const n=new Uint8Array(1.5*(s+a+50));n.set(o,0),n.subarray(s).set(t),e[ts]=o=n}else o.subarray(s).set(t);s+=a,e[ns]=s}}else r?0!==a&&(o=t,s=a):(0!==a&&(o=t.slice(),s=a,e[ns]=s,e[ts]=o),e[rs]=n);return r?0==s||null==o?hs:0===n?function(e){return void 0===ve?Ke.UTF8ArrayToString(e,0,e.byteLength):ve.decode(e)}(Fe(o,0,s)):o.subarray(0,s):null}(e,new Uint8Array(K().buffer,t,n),r,o);return o&&s?function(e,t){if(e.send(t),e[ts]=null,e.bufferedAmount{try{if(0===e.bufferedAmount)r.resolve();else{const t=e.readyState;if(t!=WebSocket.OPEN&&t!=WebSocket.CLOSING)r.reject(new Error(`InvalidState: ${t} The WebSocket is not connected.`));else if(!r.isDone)return globalThis.setTimeout(a,s),void(s=Math.min(1.5*s,1e3))}const t=o.indexOf(r);t>-1&&o.splice(t,1)}catch(e){We("WebSocket error in web_socket_send_and_wait: "+e.toString()),r.reject(e)}};return globalThis.setTimeout(a,0),n}(e,s):null}function ks(e,t,n){if(e||mt(!1,"ERR18: expected ws instance"),e[cs])return Es(e[cs]);if(e[us]){const t=e[_s];return T(t,0),T(t+4,2),T(t+8,1),null}const r=e[os],o=e[ss];if(r.getLength())return 0!=o.getLength()&&mt(!1,"ERR20: Invalid WS state"),Ts(e,r,t,n),null;if(e[fs]){const t=e[_s];return T(t,0),T(t+4,2),T(t+8,1),null}const{promise:s,promise_control:a}=_t(),i=a;return i.buffer_ptr=t,i.buffer_length=n,o.enqueue(i),s}function Ss(e,t,n,r){if(e||mt(!1,"ERR19: expected ws instance"),e[us]||e[ds]||e.readyState==WebSocket.CLOSED)return null;if(e[cs])return Es(e[cs]);if(e[ds]=!0,r){const{promise:r,promise_control:o}=_t();return e[ls].push(o),"string"==typeof n?e.close(t,n):e.close(t),r}return"string"==typeof n?e.close(t,n):e.close(t),null}function vs(e){if(e||mt(!1,"ERR18: expected ws instance"),!e[us]&&!e[ds]){e[us]=!0,Us(e,new Error("OperationCanceledException"));try{e.close(1e3,"Connection was aborted.")}catch(e){We("WebSocket error in ws_wasm_abort: "+e.toString())}}}function Us(e,t){const n=e[as],r=e[is];n&&r&&n.reject(t);for(const n of e[ls])n.reject(t);for(const n of e[ps])n.reject(t);e[ss].drain((e=>{e.reject(t)}))}function Ts(e,t,n,r){const o=t.peek(),s=Math.min(r,o.data.length-o.offset);if(s>0){const e=o.data.subarray(o.offset,o.offset+s);new Uint8Array(K().buffer,n,r).set(e,0),o.offset+=s}const a=o.data.length===o.offset?1:0;a&&t.dequeue();const i=e[_s];T(i,s),T(i+4,o.type),T(i+8,a)}function Es(e){return function(e){const{promise:t,promise_control:n}=_t();return e.then((e=>n.resolve(e))).catch((e=>n.reject(e))),t}(Promise.reject(new Error(e)))}function xs(e,t,n){lt.diagnosticTracing&&ze(`Loaded:${e.name} as ${e.behavior} size ${n.length} from ${t}`);const r=Ft(),s="string"==typeof e.virtualPath?e.virtualPath:e.name;let a=null;switch(e.behavior){case"dotnetwasm":case"js-module-threads":case"js-module-diagnostics":case"symbols":break;case"resource":case"assembly":case"pdb":lt._loaded_files.push({url:t,file:s});case"heap":case"icu":a=function(e){const t=e.length+16;let n=Ke._sbrk(t);if(n<=0){if(n=Ke._sbrk(t),n<=0)throw He(`sbrk failed to allocate ${t} bytes, and failed upon retry.`),new Error("Out of memory");We(`sbrk failed to allocate ${t} bytes, but succeeded upon retry!`)}return new Uint8Array(K().buffer,n,e.length).set(e),n}(n);break;case"vfs":{const e=s.lastIndexOf("/");let t=e>0?s.substring(0,e):null,r=e>0?s.substring(e+1):s;r.startsWith("/")&&(r=r.substring(1)),t?(t.startsWith("/")||(t="/"+t),ze(`Creating directory '${t}'`),Ke.FS_createPath("/",t,!0,!0)):t="/",lt.diagnosticTracing&&ze(`Creating file '${r}' in directory '${t}'`),Ke.FS_createDataFile(t,r,n,!0,!0,!0);break}default:throw new Error(`Unrecognized asset behavior:${e.behavior}, for asset ${e.name}`)}if("assembly"===e.behavior){if(!o.mono_wasm_add_assembly(s,a,n.length)){const e=lt._loaded_files.findIndex((e=>e.file==s));lt._loaded_files.splice(e,1)}}else"pdb"===e.behavior?o.mono_wasm_add_assembly(s,a,n.length):"icu"===e.behavior?function(e){if(!o.mono_wasm_load_icu_data(e))throw new Error("Failed to load ICU data")}(a):"resource"===e.behavior&&o.mono_wasm_add_satellite_assembly(s,e.culture||"",a,n.length);Pt(r,"mono.instantiateAsset:",e.name),++lt.actual_instantiated_assets_count}async function Is(e){try{const n=await e.pendingDownloadInternal.response;t=await n.text(),Ge&&mt(!1,"Another symbol map was already loaded"),Ge=t,lt.diagnosticTracing&&ze(`Deferred loading of ${t.length}ch symbol map`)}catch(t){Ve(`Error loading symbol file ${e.name}: ${JSON.stringify(t)}`)}var t}function As(){return lt.loadedFiles}const js={};function $s(e){let t=js[e];if("string"!=typeof t){const n=o.mono_jiterp_get_opcode_info(e,0);js[e]=t=Le(n)}return t}const Ls=2,Rs=64,Bs=64,Ns=-2147483648,Os={};class Cs{constructor(e){this.locals=new Map,this.permanentFunctionTypeCount=0,this.permanentFunctionTypes={},this.permanentFunctionTypesByShape={},this.permanentFunctionTypesByIndex={},this.functionTypesByIndex={},this.permanentImportedFunctionCount=0,this.permanentImportedFunctions={},this.nextImportIndex=0,this.functions=[],this.estimatedExportBytes=0,this.frame=0,this.traceBuf=[],this.branchTargets=new Set,this.constantSlots=[],this.backBranchOffsets=[],this.callHandlerReturnAddresses=[],this.nextConstantSlot=0,this.backBranchTraceLevel=0,this.compressImportNames=!1,this.lockImports=!1,this._assignParameterIndices=e=>{let t=0;for(const n in e)this.locals.set(n,t),t++;return t},this.stack=[new Ds],this.clear(e),this.cfg=new Fs(this),this.defineType("__cpp_exception",{ptr:127},64,!0)}clear(e){if(this.options=fa(),this.options.maxModuleSize>=24576)throw new Error(`blobBuilderCapacity 24576 is not large enough for jiterpreter-max-module-size of ${this.options.maxModuleSize}`);this.stackSize=1,this.inSection=!1,this.inFunction=!1,this.lockImports=!1,this.locals.clear(),this.functionTypeCount=this.permanentFunctionTypeCount,this.functionTypes=Object.create(this.permanentFunctionTypes),this.functionTypesByShape=Object.create(this.permanentFunctionTypesByShape),this.functionTypesByIndex=Object.create(this.permanentFunctionTypesByIndex),this.nextImportIndex=0,this.importedFunctionCount=0,this.importedFunctions=Object.create(this.permanentImportedFunctions);for(const e in this.importedFunctions)this.importedFunctions[e].index=void 0;this.functions.length=0,this.estimatedExportBytes=0,this.argumentCount=0,this.current.clear(),this.traceBuf.length=0,this.branchTargets.clear(),this.activeBlocks=0,this.nextConstantSlot=0,this.constantSlots.length=this.options.useConstants?e:0;for(let e=0;e=this.stack.length&&this.stack.push(new Ds),this.current.clear()}_pop(e){if(this.stackSize<=1)throw new Error("Stack empty");const t=this.current;return this.stackSize--,e?(this.appendULeb(t.size),t.copyTo(this.current),null):t.getArrayView(!1).slice(0,t.size)}setImportFunction(e,t){const n=this.importedFunctions[e];if(!n)throw new Error("No import named "+e);n.func=t}getExceptionTag(){const e=Ke.wasmExports.__cpp_exception;return void 0!==e&&(e instanceof WebAssembly.Tag||mt(!1,`expected __cpp_exception export from dotnet.wasm to be WebAssembly.Tag but was ${e}`)),e}getWasmImports(){const e=ct.getMemory();e instanceof WebAssembly.Memory||mt(!1,`expected heap import to be WebAssembly.Memory but was ${e}`);const t=this.getExceptionTag(),n={c:this.getConstants(),m:{h:e}};t&&(n.x={e:t});const r=this.getImportsToEmit();for(let e=0;e>>0||e>255)throw new Error(`Byte out of range: ${e}`);return this.current.appendU8(e)}appendSimd(e,t){return this.current.appendU8(253),0|e||0===e&&!0===t||mt(!1,"Expected non-v128_load simd opcode or allowLoad==true"),this.current.appendULeb(e)}appendAtomic(e,t){return this.current.appendU8(254),0|e||0===e&&!0===t||mt(!1,"Expected non-notify atomic opcode or allowNotify==true"),this.current.appendU8(e)}appendU32(e){return this.current.appendU32(e)}appendF32(e){return this.current.appendF32(e)}appendF64(e){return this.current.appendF64(e)}appendBoundaryValue(e,t){return this.current.appendBoundaryValue(e,t)}appendULeb(e){return this.current.appendULeb(e)}appendLeb(e){return this.current.appendLeb(e)}appendLebRef(e,t){return this.current.appendLebRef(e,t)}appendBytes(e){return this.current.appendBytes(e)}appendName(e){return this.current.appendName(e)}ret(e){this.ip_const(e),this.appendU8(15)}i32_const(e){this.appendU8(65),this.appendLeb(e)}ptr_const(e){let t=this.options.useConstants?this.constantSlots.indexOf(e):-1;this.options.useConstants&&t<0&&this.nextConstantSlot=0?(this.appendU8(35),this.appendLeb(t)):this.i32_const(e)}ip_const(e){this.appendU8(65),this.appendLeb(e-this.base)}i52_const(e){this.appendU8(66),this.appendLeb(e)}v128_const(e){if(0===e)this.local("v128_zero");else{if("object"!=typeof e)throw new Error("Expected v128_const arg to be 0 or a Uint8Array");{16!==e.byteLength&&mt(!1,"Expected v128_const arg to be 16 bytes in size");let t=!0;for(let n=0;n<16;n++)0!==e[n]&&(t=!1);t?this.local("v128_zero"):(this.appendSimd(12),this.appendBytes(e))}}}defineType(e,t,n,r){if(this.functionTypes[e])throw new Error(`Function type ${e} already defined`);if(r&&this.functionTypeCount>this.permanentFunctionTypeCount)throw new Error("New permanent function types cannot be defined after non-permanent ones");let o="";for(const e in t)o+=t[e]+",";o+=n;let s=this.functionTypesByShape[o];"number"!=typeof s&&(s=this.functionTypeCount++,r?(this.permanentFunctionTypeCount++,this.permanentFunctionTypesByShape[o]=s,this.permanentFunctionTypesByIndex[s]=[t,Object.values(t).length,n]):(this.functionTypesByShape[o]=s,this.functionTypesByIndex[s]=[t,Object.values(t).length,n]));const a=[s,t,n,`(${JSON.stringify(t)}) -> ${n}`,r];return r?this.permanentFunctionTypes[e]=a:this.functionTypes[e]=a,s}generateTypeSection(){this.beginSection(1),this.appendULeb(this.functionTypeCount);for(let e=0;ee.index-t.index)),e}_generateImportSection(e){const t=this.getImportsToEmit();if(this.lockImports=!0,!1!==e)throw new Error("function table imports are disabled");const n=void 0!==this.getExceptionTag();this.beginSection(2),this.appendULeb(1+(n?1:0)+t.length+this.constantSlots.length+(!1!==e?1:0));for(let e=0;e0)throw new Error("New permanent imports cannot be defined after any indexes have been assigned");const s=this.functionTypes[n];if(!s)throw new Error("No function type named "+n);if(r&&!s[4])throw new Error("A permanent import must have a permanent function type");const a=s[0],i=r?this.permanentImportedFunctions:this.importedFunctions;if("number"==typeof o&&(o=qs().get(o)),"function"!=typeof o&&void 0!==o)throw new Error(`Value passed for imported function ${t} was not a function or valid function pointer or undefined`);return i[t]={index:void 0,typeIndex:a,module:e,name:t,func:o}}markImportAsUsed(e){const t=this.importedFunctions[e];if(!t)throw new Error("No imported function named "+e);"number"!=typeof t.index&&(t.index=this.importedFunctionCount++)}getTypeIndex(e){const t=this.functionTypes[e];if(!t)throw new Error("No type named "+e);return t[0]}defineFunction(e,t){const n={index:this.functions.length,name:e.name,typeName:e.type,typeIndex:this.getTypeIndex(e.type),export:e.export,locals:e.locals,generator:t,error:null,blob:null};return this.functions.push(n),n.export&&(this.estimatedExportBytes+=n.name.length+8),n}emitImportsAndFunctions(e){let t=0;for(let e=0;e0)throw new Error(`${this.activeBlocks} unclosed block(s) at end of function`);const t=this._pop(e);return this.inFunction=!1,t}block(e,t){const n=this.appendU8(t||2);return e?this.appendU8(e):this.appendU8(64),this.activeBlocks++,n}endBlock(){if(this.activeBlocks<=0)throw new Error("No blocks active");this.activeBlocks--,this.appendU8(11)}arg(e,t){const n="string"==typeof e?this.locals.has(e)?this.locals.get(e):void 0:e;if("number"!=typeof n)throw new Error("No local named "+e);t&&this.appendU8(t),this.appendULeb(n)}local(e,t){const n="string"==typeof e?this.locals.has(e)?this.locals.get(e):void 0:e+this.argumentCount;if("number"!=typeof n)throw new Error("No local named "+e);t?this.appendU8(t):this.appendU8(32),this.appendULeb(n)}appendMemarg(e,t){this.appendULeb(t),this.appendULeb(e)}lea(e,t){"string"==typeof e?this.local(e):this.i32_const(e),this.i32_const(t),this.appendU8(106)}getArrayView(e,t){if(!0!==t&&this.stackSize>1)throw new Error("Jiterpreter block stack not empty");return this.stack[0].getArrayView(e)}getConstants(){const e={};for(let t=0;t=this.capacity)throw new Error("Buffer full");const t=this.size;return K()[this.buffer+this.size++]=e,t}appendU32(e){const t=this.size;return o.mono_jiterp_write_number_unaligned(this.buffer+this.size,e,0),this.size+=4,t}appendI32(e){const t=this.size;return o.mono_jiterp_write_number_unaligned(this.buffer+this.size,e,1),this.size+=4,t}appendF32(e){const t=this.size;return o.mono_jiterp_write_number_unaligned(this.buffer+this.size,e,2),this.size+=4,t}appendF64(e){const t=this.size;return o.mono_jiterp_write_number_unaligned(this.buffer+this.size,e,3),this.size+=8,t}appendBoundaryValue(e,t){if(this.size+8>=this.capacity)throw new Error("Buffer full");const n=o.mono_jiterp_encode_leb_signed_boundary(this.buffer+this.size,e,t);if(n<1)throw new Error(`Failed to encode ${e} bit boundary value with sign ${t}`);return this.size+=n,n}appendULeb(e){if("number"!=typeof e&&mt(!1,`appendULeb expected number but got ${e}`),e>=0||mt(!1,"cannot pass negative value to appendULeb"),e<127){if(this.size+1>=this.capacity)throw new Error("Buffer full");return this.appendU8(e),1}if(this.size+8>=this.capacity)throw new Error("Buffer full");const t=o.mono_jiterp_encode_leb52(this.buffer+this.size,e,0);if(t<1)throw new Error(`Failed to encode value '${e}' as unsigned leb`);return this.size+=t,t}appendLeb(e){if("number"!=typeof e&&mt(!1,`appendLeb expected number but got ${e}`),this.size+8>=this.capacity)throw new Error("Buffer full");const t=o.mono_jiterp_encode_leb52(this.buffer+this.size,e,1);if(t<1)throw new Error(`Failed to encode value '${e}' as signed leb`);return this.size+=t,t}appendLebRef(e,t){if(this.size+8>=this.capacity)throw new Error("Buffer full");const n=o.mono_jiterp_encode_leb64_ref(this.buffer+this.size,e,t?1:0);if(n<1)throw new Error("Failed to encode value as leb");return this.size+=n,n}copyTo(e,t){if("number"!=typeof t&&(t=this.size),e.size+t>=e.capacity)throw new Error("Destination buffer full");K().copyWithin(e.buffer+e.size,this.buffer,this.buffer+t),e.size+=t}appendBytes(e,t){const n=this.size,r=K(),o="number"!=typeof t?e.length:t;if(this.size+o>=this.capacity)throw new Error("Buffer full");return e.buffer===r.buffer?(r.copyWithin(this.buffer+n,e.byteOffset,e.byteOffset+o),this.size+=o):("number"==typeof t&&(e=new Uint8Array(e.buffer,e.byteOffset,t)),this.getArrayView(!0).set(e,this.size),this.size+=e.length),n}appendName(e){let t=e.length,n=1===e.length?e.charCodeAt(0):-1;if(n>127&&(n=-1),t&&n<0)if(this.encoder)t=this.encoder.encodeInto(e,this.textBuf).written||0;else for(let n=0;n127)throw new Error("Out of range character and no TextEncoder available");this.textBuf[n]=t}this.appendULeb(t),n>=0?this.appendU8(n):t>1&&this.appendBytes(this.textBuf,t)}getArrayView(e){return new Uint8Array(K().buffer,this.buffer,e?this.capacity:this.size)}}class Fs{constructor(e){this.segments=[],this.backBranchTargets=null,this.lastSegmentEnd=0,this.overheadBytes=0,this.blockStack=[],this.backDispatchOffsets=[],this.dispatchTable=new Map,this.observedBackBranchTargets=new Set,this.trace=0,this.builder=e}initialize(e,t,n){this.segments.length=0,this.blockStack.length=0,this.startOfBody=e,this.backBranchTargets=t,this.base=this.builder.base,this.ip=this.lastSegmentStartIp=this.firstOpcodeIp=this.builder.base,this.lastSegmentEnd=0,this.overheadBytes=10,this.dispatchTable.clear(),this.observedBackBranchTargets.clear(),this.trace=n,this.backDispatchOffsets.length=0}entry(e){this.entryIp=e;const t=o.mono_jiterp_get_opcode_info(676,1);return this.firstOpcodeIp=e+2*t,this.appendBlob(),1!==this.segments.length&&mt(!1,"expected 1 segment"),"blob"!==this.segments[0].type&&mt(!1,"expected blob"),this.entryBlob=this.segments[0],this.segments.length=0,this.overheadBytes+=9,this.backBranchTargets&&(this.overheadBytes+=20,this.overheadBytes+=this.backBranchTargets.length),this.firstOpcodeIp}appendBlob(){this.builder.current.size!==this.lastSegmentEnd&&(this.segments.push({type:"blob",ip:this.lastSegmentStartIp,start:this.lastSegmentEnd,length:this.builder.current.size-this.lastSegmentEnd}),this.lastSegmentStartIp=this.ip,this.lastSegmentEnd=this.builder.current.size,this.overheadBytes+=2)}startBranchBlock(e,t){this.appendBlob(),this.segments.push({type:"branch-block-header",ip:e,isBackBranchTarget:t}),this.overheadBytes+=1}branch(e,t,n){t&&this.observedBackBranchTargets.add(e),this.appendBlob(),this.segments.push({type:"branch",from:this.ip,target:e,isBackward:t,branchType:n}),this.overheadBytes+=4,t&&(this.overheadBytes+=4)}jumpTable(e,t){this.appendBlob(),this.segments.push({type:"jump-table",from:this.ip,targets:e,fallthrough:t}),this.overheadBytes+=4,this.overheadBytes+=e.length,this.overheadBytes+=24}emitBlob(e,t){const n=t.subarray(e.start,e.start+e.length);this.builder.appendBytes(n)}generate(){this.appendBlob();const e=this.builder.endFunction(!1);this.builder._push(),this.builder.base=this.base,this.emitBlob(this.entryBlob,e),this.backBranchTargets&&this.builder.block(64,3);for(let e=0;ee-t));for(let e=0;e0&&Ve("No back branch targets were reachable after filtering");else if(1===this.backDispatchOffsets.length)this.trace>0&&(this.backDispatchOffsets[0]===this.entryIp?Ve(`Exactly one back dispatch offset and it was the entry point 0x${this.entryIp.toString(16)}`):Ve(`Exactly one back dispatch offset and it was 0x${this.backDispatchOffsets[0].toString(16)}`)),this.builder.local("disp"),this.builder.appendU8(13),this.builder.appendULeb(this.blockStack.indexOf(this.backDispatchOffsets[0]));else{this.trace>0&&Ve(`${this.backDispatchOffsets.length} back branch offsets after filtering.`),this.builder.block(64),this.builder.block(64),this.builder.local("disp"),this.builder.appendU8(14),this.builder.appendULeb(this.backDispatchOffsets.length+1),this.builder.appendULeb(1);for(let e=0;e0&&this.blockStack.push(0)}this.trace>1&&Ve(`blockStack=${this.blockStack}`);for(let t=0;t=0?(da(13,1),this.builder.appendULeb(n+e)):(da(14,1),this.trace>0&&Ve(`Switch target ${t} not found in block stack ${this.blockStack}`),this.builder.appendULeb(0))}const t=this.blockStack.indexOf(n.fallthrough);t>=0?(da(13,1),this.builder.appendULeb(t+e)):(da(14,1),this.trace>0&&Ve(`Switch fallthrough ${n.fallthrough} not found in block stack ${this.blockStack}`),this.builder.appendULeb(0)),this.builder.appendU8(0);break}case"branch":{const e=n.isBackward?0:n.target;let t,r=this.blockStack.indexOf(e),o=!1;if(n.isBackward&&(this.dispatchTable.has(n.target)?(t=this.dispatchTable.get(n.target),this.trace>1&&Ve(`backward br from ${n.from.toString(16)} to ${n.target.toString(16)}: disp=${t}`),o=!0):(this.trace>0&&Ve(`br from ${n.from.toString(16)} to ${n.target.toString(16)} failed: back branch target not in dispatch table`),r=-1)),r>=0||o){let e=0;switch(n.branchType){case 2:this.builder,n.from,void 0!==t&&(this.builder.i32_const(t),this.builder.local("disp",33)),this.builder.appendU8(12);break;case 3:this.builder.block(64,4),this.builder,n.from,void 0!==t&&(this.builder.i32_const(t),this.builder.local("disp",33)),this.builder.appendU8(12),e=1;break;case 0:void 0!==t&&(this.builder.i32_const(t),this.builder.local("disp",33)),this.builder.appendU8(12);break;case 1:void 0!==t?(this.builder.block(64,4),this.builder.i32_const(t),this.builder.local("disp",33),e=1,this.builder.appendU8(12)):this.builder.appendU8(13);break;default:throw new Error("Unimplemented branch type")}this.builder.appendULeb(e+r),e&&this.builder.endBlock(),this.trace>1&&Ve(`br from ${n.from.toString(16)} to ${n.target.toString(16)} breaking out ${e+r+1} level(s)`)}else{if(this.trace>0){const e=this.base;n.target>=e&&n.target1&&Ve(`br from ${n.from.toString(16)} to ${n.target.toString(16)} failed (outside of trace 0x${e.toString(16)} - 0x${this.exitIp.toString(16)})`)}const e=1===n.branchType||3===n.branchType;e&&this.builder.block(64,4),Ws(this.builder,n.target,4),e&&this.builder.endBlock()}break}default:throw new Error("unreachable")}}return this.backBranchTargets&&(this.blockStack.length<=1||mt(!1,"expected one or zero entries in the block stack at the end"),this.blockStack.length&&this.blockStack.shift(),this.builder.endBlock()),0!==this.blockStack.length&&mt(!1,`expected block stack to be empty at end of function but it was ${this.blockStack}`),this.builder.ip_const(this.exitIp),this.builder.appendU8(15),this.builder.appendU8(11),this.builder._pop(!1)}}let Ps;const Ms={},zs=globalThis.performance&&globalThis.performance.now?globalThis.performance.now.bind(globalThis.performance):Date.now;function Vs(e,t,n){let r;switch(n){case 633:r="prof_enter";break;case 634:r="prof_samplepoint";break;case 635:case 636:r="prof_leave";break;default:throw new Error(`Unimplemented profiler event ${n}`)}e.local("frame"),e.i32_const(t),e.callImport(r)}function Ws(e,t,n){e.ip_const(t),e.options.countBailouts&&(e.i32_const(e.traceIndex),e.i32_const(n),e.callImport("bailout")),e.appendU8(15)}function Hs(e,t,n,r){e.local("cinfo"),e.block(64,4),e.local("cinfo"),e.local("disp"),e.appendU8(54),e.appendMemarg(ea(19),0),n<=e.options.monitoringLongDistance+2&&(e.local("cinfo"),e.i32_const(n),e.appendU8(54),e.appendMemarg(ea(20),0)),e.endBlock(),e.ip_const(t),e.options.countBailouts&&(e.i32_const(e.traceIndex),e.i32_const(r),e.callImport("bailout")),e.appendU8(15)}function qs(){if(Ps||(Ps=ct.getWasmIndirectFunctionTable()),!Ps)throw new Error("Module did not export the indirect function table");return Ps}function Gs(e,t){t||mt(!1,"Attempting to set null function into table");const n=o.mono_jiterp_allocate_table_entry(e);return n>0&&qs().set(n,t),n}function Js(e,t,n,r,o){if(r<=0)return o&&e.appendU8(26),!0;if(r>=Rs)return!1;const s=o?"memop_dest":"pLocals";o&&e.local(s,33);let a=o?0:t;if(e.options.enableSimd){const t=16;for(;r>=t;)e.local(s),e.v128_const(0),e.appendSimd(11),e.appendMemarg(a,0),a+=t,r-=t}for(;r>=8;)e.local(s),e.i52_const(0),e.appendU8(55),e.appendMemarg(a,0),a+=8,r-=8;for(;r>=1;){e.local(s),e.i32_const(0);let t=r%4;switch(t){case 0:t=4,e.appendU8(54);break;case 1:e.appendU8(58);break;case 3:case 2:t=2,e.appendU8(59)}e.appendMemarg(a,0),a+=t,r-=t}return!0}function Xs(e,t,n){Js(e,0,0,n,!0)||(e.i32_const(t),e.i32_const(n),e.appendU8(252),e.appendU8(11),e.appendU8(0))}function Qs(e,t,n,r,o,s,a){if(r<=0)return o&&(e.appendU8(26),e.appendU8(26)),!0;if(r>=Bs)return!1;o?(s=s||"memop_dest",a=a||"memop_src",e.local(a,33),e.local(s,33)):s&&a||(s=a="pLocals");let i=o?0:t,c=o?0:n;if(e.options.enableSimd){const t=16;for(;r>=t;)e.local(s),e.local(a),e.appendSimd(0,!0),e.appendMemarg(c,0),e.appendSimd(11),e.appendMemarg(i,0),i+=t,c+=t,r-=t}for(;r>=8;)e.local(s),e.local(a),e.appendU8(41),e.appendMemarg(c,0),e.appendU8(55),e.appendMemarg(i,0),i+=8,c+=8,r-=8;for(;r>=1;){let t,n,o=r%4;switch(o){case 0:o=4,t=40,n=54;break;default:case 1:o=1,t=44,n=58;break;case 3:case 2:o=2,t=46,n=59}e.local(s),e.local(a),e.appendU8(t),e.appendMemarg(c,0),e.appendU8(n),e.appendMemarg(i,0),c+=o,i+=o,r-=o}return!0}function Ys(e,t){return Qs(e,0,0,t,!0)||(e.i32_const(t),e.appendU8(252),e.appendU8(10),e.appendU8(0),e.appendU8(0)),!0}function Zs(){const e=da(5,1);e>=Ls&&(Ve(`Disabling jiterpreter after ${e} failures`),pa({enableTraces:!1,enableInterpEntry:!1,enableJitCall:!1}))}const Ks={};function ea(e){const t=Ks[e];return void 0===t?Ks[e]=o.mono_jiterp_get_member_offset(e):t}function ta(e){const t=Ke.wasmExports[e];if("function"!=typeof t)throw new Error(`raw cwrap ${e} not found`);return t}const na={};function ra(e){let t=na[e];return"number"!=typeof t&&(t=na[e]=o.mono_jiterp_get_opcode_value_table_entry(e)),t}function oa(e,t){return[e,e,t]}let sa;function aa(){if(!o.mono_wasm_is_zero_page_reserved())return!1;if(!0===sa)return!1;const e=te();for(let t=0;t<8;t++)if(0!==e[t])return!1===sa&&He(`Zero page optimizations are enabled but garbage appeared in memory at address ${4*t}: ${e[t]}`),sa=!0,!1;return sa=!1,!0}const ia={enableTraces:"jiterpreter-traces-enabled",enableInterpEntry:"jiterpreter-interp-entry-enabled",enableJitCall:"jiterpreter-jit-call-enabled",enableBackwardBranches:"jiterpreter-backward-branch-entries-enabled",enableCallResume:"jiterpreter-call-resume-enabled",enableWasmEh:"jiterpreter-wasm-eh-enabled",enableSimd:"jiterpreter-simd-enabled",enableAtomics:"jiterpreter-atomics-enabled",zeroPageOptimization:"jiterpreter-zero-page-optimization",cprop:"jiterpreter-constant-propagation",enableStats:"jiterpreter-stats-enabled",disableHeuristic:"jiterpreter-disable-heuristic",estimateHeat:"jiterpreter-estimate-heat",countBailouts:"jiterpreter-count-bailouts",dumpTraces:"jiterpreter-dump-traces",useConstants:"jiterpreter-use-constants",eliminateNullChecks:"jiterpreter-eliminate-null-checks",noExitBackwardBranches:"jiterpreter-backward-branches-enabled",directJitCalls:"jiterpreter-direct-jit-calls",minimumTraceValue:"jiterpreter-minimum-trace-value",minimumTraceHitCount:"jiterpreter-minimum-trace-hit-count",monitoringPeriod:"jiterpreter-trace-monitoring-period",monitoringShortDistance:"jiterpreter-trace-monitoring-short-distance",monitoringLongDistance:"jiterpreter-trace-monitoring-long-distance",monitoringMaxAveragePenalty:"jiterpreter-trace-monitoring-max-average-penalty",backBranchBoost:"jiterpreter-back-branch-boost",jitCallHitCount:"jiterpreter-jit-call-hit-count",jitCallFlushThreshold:"jiterpreter-jit-call-queue-flush-threshold",interpEntryHitCount:"jiterpreter-interp-entry-hit-count",interpEntryFlushThreshold:"jiterpreter-interp-entry-queue-flush-threshold",wasmBytesLimit:"jiterpreter-wasm-bytes-limit",tableSize:"jiterpreter-table-size",aotTableSize:"jiterpreter-aot-table-size",maxModuleSize:"jiterpreter-max-module-size",maxSwitchSize:"jiterpreter-max-switch-size"};let ca=-1,la={};function pa(e){for(const t in e){const n=ia[t];if(!n){He(`Unrecognized jiterpreter option: ${t}`);continue}const r=e[t];"boolean"==typeof r?o.mono_jiterp_parse_option((r?"--":"--no-")+n):"number"==typeof r?o.mono_jiterp_parse_option(`--${n}=${r}`):He(`Jiterpreter option must be a boolean or a number but was ${typeof r} '${r}'`)}}function ua(e){return o.mono_jiterp_get_counter(e)}function da(e,t){return o.mono_jiterp_modify_counter(e,t)}function fa(){const e=o.mono_jiterp_get_options_version();return e!==ca&&(function(){la={};for(const e in ia){const t=o.mono_jiterp_get_option_as_int(ia[e]);t!==Ns?la[e]=t:Ve(`Failed to retrieve value of option ${ia[e]}`)}}(),ca=e),la}function _a(e,t,n,r){const s=qs(),a=t,i=a+n-1;return i= ${s.length}`),s.set(a,r),o.mono_jiterp_initialize_table(e,a,i),t+n}let ma=!1;const ha=["Unknown","InterpreterTiering","NullCheck","VtableNotInitialized","Branch","BackwardBranch","ConditionalBranch","ConditionalBackwardBranch","ComplexBranch","ArrayLoadFailed","ArrayStoreFailed","StringOperationFailed","DivideByZero","Overflow","Return","Call","Throw","AllocFailed","SpanOperationFailed","CastFailed","SafepointBranchTaken","UnboxFailed","CallDelegate","Debugging","Icall","UnexpectedRetIp","LeaveCheck","SwitchSize","SwitchTarget"],ga={2:["V128_I1_NEGATION","V128_I2_NEGATION","V128_I4_NEGATION","V128_ONES_COMPLEMENT","V128_U2_WIDEN_LOWER","V128_U2_WIDEN_UPPER","V128_I1_CREATE_SCALAR","V128_I2_CREATE_SCALAR","V128_I4_CREATE_SCALAR","V128_I8_CREATE_SCALAR","V128_I1_EXTRACT_MSB","V128_I2_EXTRACT_MSB","V128_I4_EXTRACT_MSB","V128_I8_EXTRACT_MSB","V128_I1_CREATE","V128_I2_CREATE","V128_I4_CREATE","V128_I8_CREATE","SplatX1","SplatX2","SplatX4","SplatX8","NegateD1","NegateD2","NegateD4","NegateD8","NegateR4","NegateR8","SqrtR4","SqrtR8","CeilingR4","CeilingR8","FloorR4","FloorR8","TruncateR4","TruncateR8","RoundToNearestR4","RoundToNearestR8","NotANY","AnyTrueANY","AllTrueD1","AllTrueD2","AllTrueD4","AllTrueD8","PopCountU1","BitmaskD1","BitmaskD2","BitmaskD4","BitmaskD8","AddPairwiseWideningI1","AddPairwiseWideningU1","AddPairwiseWideningI2","AddPairwiseWideningU2","AbsI1","AbsI2","AbsI4","AbsI8","AbsR4","AbsR8","ConvertToSingleI4","ConvertToSingleU4","ConvertToSingleR8","ConvertToDoubleLowerI4","ConvertToDoubleLowerU4","ConvertToDoubleLowerR4","ConvertToInt32SaturateR4","ConvertToUInt32SaturateR4","ConvertToInt32SaturateR8","ConvertToUInt32SaturateR8","SignExtendWideningLowerD1","SignExtendWideningLowerD2","SignExtendWideningLowerD4","SignExtendWideningUpperD1","SignExtendWideningUpperD2","SignExtendWideningUpperD4","ZeroExtendWideningLowerD1","ZeroExtendWideningLowerD2","ZeroExtendWideningLowerD4","ZeroExtendWideningUpperD1","ZeroExtendWideningUpperD2","ZeroExtendWideningUpperD4","LoadVector128ANY","LoadScalarVector128X4","LoadScalarVector128X8","LoadScalarAndSplatVector128X1","LoadScalarAndSplatVector128X2","LoadScalarAndSplatVector128X4","LoadScalarAndSplatVector128X8","LoadWideningVector128I1","LoadWideningVector128U1","LoadWideningVector128I2","LoadWideningVector128U2","LoadWideningVector128I4","LoadWideningVector128U4"],3:["V128_I1_ADD","V128_I2_ADD","V128_I4_ADD","V128_R4_ADD","V128_I1_SUB","V128_I2_SUB","V128_I4_SUB","V128_R4_SUB","V128_BITWISE_AND","V128_BITWISE_OR","V128_BITWISE_EQUALITY","V128_BITWISE_INEQUALITY","V128_R4_FLOAT_EQUALITY","V128_R8_FLOAT_EQUALITY","V128_EXCLUSIVE_OR","V128_I1_MULTIPLY","V128_I2_MULTIPLY","V128_I4_MULTIPLY","V128_R4_MULTIPLY","V128_R4_DIVISION","V128_I1_LEFT_SHIFT","V128_I2_LEFT_SHIFT","V128_I4_LEFT_SHIFT","V128_I8_LEFT_SHIFT","V128_I1_RIGHT_SHIFT","V128_I2_RIGHT_SHIFT","V128_I4_RIGHT_SHIFT","V128_I1_URIGHT_SHIFT","V128_I2_URIGHT_SHIFT","V128_I4_URIGHT_SHIFT","V128_I8_URIGHT_SHIFT","V128_U1_NARROW","V128_U1_GREATER_THAN","V128_I1_LESS_THAN","V128_U1_LESS_THAN","V128_I2_LESS_THAN","V128_I1_EQUALS","V128_I2_EQUALS","V128_I4_EQUALS","V128_R4_EQUALS","V128_I8_EQUALS","V128_I1_EQUALS_ANY","V128_I2_EQUALS_ANY","V128_I4_EQUALS_ANY","V128_I8_EQUALS_ANY","V128_AND_NOT","V128_U2_LESS_THAN_EQUAL","V128_I1_SHUFFLE","V128_I2_SHUFFLE","V128_I4_SHUFFLE","V128_I8_SHUFFLE","ExtractScalarI1","ExtractScalarU1","ExtractScalarI2","ExtractScalarU2","ExtractScalarD4","ExtractScalarD8","ExtractScalarR4","ExtractScalarR8","SwizzleD1","AddD1","AddD2","AddD4","AddD8","AddR4","AddR8","SubtractD1","SubtractD2","SubtractD4","SubtractD8","SubtractR4","SubtractR8","MultiplyD2","MultiplyD4","MultiplyD8","MultiplyR4","MultiplyR8","DivideR4","DivideR8","DotI2","ShiftLeftD1","ShiftLeftD2","ShiftLeftD4","ShiftLeftD8","ShiftRightArithmeticD1","ShiftRightArithmeticD2","ShiftRightArithmeticD4","ShiftRightArithmeticD8","ShiftRightLogicalD1","ShiftRightLogicalD2","ShiftRightLogicalD4","ShiftRightLogicalD8","AndANY","AndNotANY","OrANY","XorANY","CompareEqualD1","CompareEqualD2","CompareEqualD4","CompareEqualD8","CompareEqualR4","CompareEqualR8","CompareNotEqualD1","CompareNotEqualD2","CompareNotEqualD4","CompareNotEqualD8","CompareNotEqualR4","CompareNotEqualR8","CompareLessThanI1","CompareLessThanU1","CompareLessThanI2","CompareLessThanU2","CompareLessThanI4","CompareLessThanU4","CompareLessThanI8","CompareLessThanR4","CompareLessThanR8","CompareLessThanOrEqualI1","CompareLessThanOrEqualU1","CompareLessThanOrEqualI2","CompareLessThanOrEqualU2","CompareLessThanOrEqualI4","CompareLessThanOrEqualU4","CompareLessThanOrEqualI8","CompareLessThanOrEqualR4","CompareLessThanOrEqualR8","CompareGreaterThanI1","CompareGreaterThanU1","CompareGreaterThanI2","CompareGreaterThanU2","CompareGreaterThanI4","CompareGreaterThanU4","CompareGreaterThanI8","CompareGreaterThanR4","CompareGreaterThanR8","CompareGreaterThanOrEqualI1","CompareGreaterThanOrEqualU1","CompareGreaterThanOrEqualI2","CompareGreaterThanOrEqualU2","CompareGreaterThanOrEqualI4","CompareGreaterThanOrEqualU4","CompareGreaterThanOrEqualI8","CompareGreaterThanOrEqualR4","CompareGreaterThanOrEqualR8","ConvertNarrowingSaturateSignedI2","ConvertNarrowingSaturateSignedI4","ConvertNarrowingSaturateUnsignedI2","ConvertNarrowingSaturateUnsignedI4","MultiplyWideningLowerI1","MultiplyWideningLowerI2","MultiplyWideningLowerI4","MultiplyWideningLowerU1","MultiplyWideningLowerU2","MultiplyWideningLowerU4","MultiplyWideningUpperI1","MultiplyWideningUpperI2","MultiplyWideningUpperI4","MultiplyWideningUpperU1","MultiplyWideningUpperU2","MultiplyWideningUpperU4","AddSaturateI1","AddSaturateU1","AddSaturateI2","AddSaturateU2","SubtractSaturateI1","SubtractSaturateU1","SubtractSaturateI2","SubtractSaturateU2","MultiplyRoundedSaturateQ15I2","MinI1","MinI2","MinI4","MinU1","MinU2","MinU4","MaxI1","MaxI2","MaxI4","MaxU1","MaxU2","MaxU4","AverageRoundedU1","AverageRoundedU2","MinR4","MinR8","MaxR4","MaxR8","PseudoMinR4","PseudoMinR8","PseudoMaxR4","PseudoMaxR8","StoreANY"],4:["V128_CONDITIONAL_SELECT","ReplaceScalarD1","ReplaceScalarD2","ReplaceScalarD4","ReplaceScalarD8","ReplaceScalarR4","ReplaceScalarR8","ShuffleD1","BitwiseSelectANY","LoadScalarAndInsertX1","LoadScalarAndInsertX2","LoadScalarAndInsertX4","LoadScalarAndInsertX8","StoreSelectedScalarX1","StoreSelectedScalarX2","StoreSelectedScalarX4","StoreSelectedScalarX8"]},ba={13:[65,0],14:[65,1]},ya={456:168,462:174,457:170,463:176},wa={508:[69,40,54],428:[106,40,54],430:[107,40,54],432:[107,40,54],436:[115,40,54],429:[124,41,55],431:[125,41,55],433:[125,41,55],437:[133,41,55],511:[106,40,54],515:[108,40,54],513:[124,41,55],517:[126,41,55],434:[140,42,56],435:[154,43,57],464:[178,40,56],467:[183,40,57],438:[184,40,57],465:[180,41,56],468:[185,41,57],439:[186,41,57],469:[187,42,57],466:[182,43,56],460:[1,52,55],461:[1,53,55],444:[113,40,54],452:[113,40,54],440:[117,40,54],448:[117,40,54],445:[113,41,54],453:[113,41,54],441:[117,41,54],449:[117,41,54],525:[116,40,54],526:[134,41,55],527:[117,40,54],528:[135,41,55],523:[118,40,54],524:[136,41,55],640:[119,40,54],641:[137,41,55],642:[120,40,54],643:[138,41,55],644:[103,40,54],646:[104,40,54],648:[105,40,54],645:[121,41,55],647:[122,41,55],649:[123,41,55],512:[106,40,54],516:[108,40,54],514:[124,41,55],518:[126,41,55],519:[113,40,54],520:[113,40,54],521:[114,40,54],522:[114,40,54]},ka={394:187,395:1,398:187,399:1,402:187,403:1,406:187,407:1,412:187,413:1,416:187,417:1,426:187,427:1,420:187,421:1,65536:187,65537:187,65535:187,65539:1,65540:1,65538:1},Sa={344:[106,40,54],362:[106,40,54],364:[106,40,54],348:[107,40,54],352:[108,40,54],366:[108,40,54],368:[108,40,54],356:[109,40,54],360:[110,40,54],380:[111,40,54],384:[112,40,54],374:[113,40,54],376:[114,40,54],378:[115,40,54],388:[116,40,54],390:[117,40,54],386:[118,40,54],345:[124,41,55],349:[125,41,55],353:[126,41,55],357:[127,41,55],381:[129,41,55],361:[128,41,55],385:[130,41,55],375:[131,41,55],377:[132,41,55],379:[133,41,55],389:[134,41,55],391:[135,41,55],387:[136,41,55],346:[146,42,56],350:[147,42,56],354:[148,42,56],358:[149,42,56],347:[160,43,57],351:[161,43,57],355:[162,43,57],359:[163,43,57],392:[70,40,54],396:[71,40,54],414:[72,40,54],400:[74,40,54],418:[76,40,54],404:[78,40,54],424:[73,40,54],410:[75,40,54],422:[77,40,54],408:[79,40,54],393:[81,41,54],397:[82,41,54],415:[83,41,54],401:[85,41,54],419:[87,41,54],405:[89,41,54],425:[84,41,54],411:[86,41,54],423:[88,41,54],409:[90,41,54]},va={187:392,207:396,195:400,215:410,199:414,223:424,191:404,211:408,203:418,219:422,231:[392,!1,!0],241:[396,!1,!0],235:[400,!1,!0],245:[410,!1,!0],237:[414,!1,!0],249:[424,!1,!0],233:[404,!1,!0],243:[408,!1,!0],239:[418,!1,!0],247:[422,!1,!0],251:[392,65,!0],261:[396,65,!0],255:[400,65,!0],265:[410,65,!0],257:[414,65,!0],269:[424,65,!0],253:[404,65,!0],263:[408,65,!0],259:[418,65,!0],267:[422,65,!0],188:393,208:397,196:401,216:411,200:415,224:425,192:405,212:409,204:419,220:423,252:[393,66,!0],256:[401,66,!0],266:[411,66,!0],258:[415,66,!0],270:[425,66,!0],254:[405,66,!0],264:[409,66,!0],260:[419,66,!0],268:[423,66,!0],189:394,209:65535,197:402,217:412,201:416,225:426,193:406,213:65536,205:420,221:65537,190:395,210:65538,198:403,218:413,202:417,226:427,194:407,214:65539,206:421,222:65540},Ua={599:[!0,!1,159],626:[!0,!0,145],586:[!0,!1,155],613:[!0,!0,141],592:[!0,!1,156],619:[!0,!0,142],603:[!0,!1,153],630:[!0,!0,139],581:[!0,!1,"acos"],608:[!0,!0,"acosf"],582:[!0,!1,"acosh"],609:[!0,!0,"acoshf"],587:[!0,!1,"cos"],614:[!0,!0,"cosf"],579:[!0,!1,"asin"],606:[!0,!0,"asinf"],580:[!0,!1,"asinh"],607:[!0,!0,"asinhf"],598:[!0,!1,"sin"],625:[!0,!0,"sinf"],583:[!0,!1,"atan"],610:[!0,!0,"atanf"],584:[!0,!1,"atanh"],611:[!0,!0,"atanhf"],601:[!0,!1,"tan"],628:[!0,!0,"tanf"],588:[!0,!1,"cbrt"],615:[!0,!0,"cbrtf"],590:[!0,!1,"exp"],617:[!0,!0,"expf"],593:[!0,!1,"log"],620:[!0,!0,"logf"],594:[!0,!1,"log2"],621:[!0,!0,"log2f"],595:[!0,!1,"log10"],622:[!0,!0,"log10f"],604:[!1,!1,164],631:[!1,!0,150],605:[!1,!1,165],632:[!1,!0,151],585:[!1,!1,"atan2"],612:[!1,!0,"atan2f"],596:[!1,!1,"pow"],623:[!1,!0,"powf"],383:[!1,!1,"fmod"],382:[!1,!0,"fmodf"]},Ta={560:[67,0,0],561:[67,192,0],562:[68,0,1],563:[68,193,1],564:[65,0,2],565:[66,0,3]},Ea={566:[74,0,0],567:[74,192,0],568:[75,0,1],569:[75,193,1],570:[72,0,2],571:[73,0,3]},xa={653:1,654:2,655:4,656:8},Ia={653:44,654:46,655:40,656:41},Aa={653:58,654:59,655:54,656:55},ja=new Set([20,21,22,23,24,25,26,27,28,29,30,80,81,82,83,84,85,86,87,88,89,90,91]),$a={51:[16,54],52:[16,54],53:[8,54],54:[8,54],55:[4,54],57:[4,56],56:[2,55],58:[2,57]},La={1:[16,40],2:[8,40],3:[4,40],5:[4,42],4:[2,41],6:[2,43]},Ra=new Set([81,84,85,86,87,82,83,88,89,90,91,92,93]),Ba={13:[16],14:[8],15:[4],16:[2]},Na={10:100,11:132,12:164,13:196,45:100,46:132,47:164,48:196},Oa={6:[44,23],7:[46,26],8:[40,28],9:[41,30]};function Ca(e,t){return O(e+2*t)}function Da(e,t){return z(e+2*t)}function Fa(e,t){return P(e+2*t)}function Pa(e,t){return F(e+2*t)}function Ma(e){return P(e+ea(4))}function za(e,t){const n=P(Ma(e)+ea(5));return P(n+t*gc)}function Va(e,t){const n=P(Ma(e)+ea(12));return P(n+t*gc)}function Wa(e,t,n){if(!n)return!1;for(let r=0;r=40||mt(!1,`Expected load opcode but got ${n}`),e.appendU8(n),void 0!==r)e.appendULeb(r);else if(253===n)throw new Error("PREFIX_simd ldloc without a simdOpcode");const o=ti(t,n,r);e.appendMemarg(t,o)}function oi(e,t,n,r){n>=54||mt(!1,`Expected store opcode but got ${n}`),e.appendU8(n),void 0!==r&&e.appendULeb(r);const o=ti(t,n,r);e.appendMemarg(t,o),Za(t),void 0!==r&&Za(t+8)}function si(e,t,n){n>0&&Ka(t,n),e.lea("pLocals",t)}function ai(e,t,n,r){Ka(t,r),Js(e,t,0,r,!1)||(si(e,t,r),Xs(e,n,r))}function ii(e,t,n,r){if(Ka(t,r),Qs(e,t,n,r,!1))return!0;si(e,t,r),si(e,n,0),Ys(e,r)}function ci(e,t){return 0!==o.mono_jiterp_is_imethod_var_address_taken(Ma(e.frame),t)}function li(e,t,n,r){if(e.allowNullCheckOptimization&&Xa.has(t)&&!ci(e,t))return da(7,1),void(Qa===t?r&&e.local("cknull_ptr"):(ri(e,t,40),e.local("cknull_ptr",r?34:33),Qa=t));ri(e,t,40),e.local("cknull_ptr",34),e.appendU8(69),e.block(64,4),Ws(e,n,2),e.endBlock(),r&&e.local("cknull_ptr"),e.allowNullCheckOptimization&&!ci(e,t)?(Xa.set(t,n),Qa=t):Qa=-1}function pi(e,t,n){let r,s=54;const a=ba[n];if(a)e.local("pLocals"),e.appendU8(a[0]),r=a[1],e.appendLeb(r);else switch(n){case 15:e.local("pLocals"),r=Da(t,2),e.i32_const(r);break;case 16:e.local("pLocals"),r=Pa(t,2),e.i32_const(r);break;case 17:e.local("pLocals"),e.i52_const(0),s=55;break;case 19:e.local("pLocals"),e.appendU8(66),e.appendLebRef(t+4,!0),s=55;break;case 18:e.local("pLocals"),e.i52_const(Da(t,2)),s=55;break;case 20:e.local("pLocals"),e.appendU8(67),e.appendF32(function(e,t){return n=e+2*t,o.mono_wasm_get_f32_unaligned(n);var n}(t,2)),s=56;break;case 21:e.local("pLocals"),e.appendU8(68),e.appendF64(function(e,t){return n=e+2*t,o.mono_wasm_get_f64_unaligned(n);var n}(t,2)),s=57;break;default:return!1}e.appendU8(s);const i=Ca(t,1);return e.appendMemarg(i,2),Za(i),"number"==typeof r?Ha.set(i,{type:"i32",value:r}):Ha.delete(i),!0}function ui(e,t,n){let r=40,o=54;switch(n){case 74:r=44;break;case 75:r=45;break;case 76:r=46;break;case 77:r=47;break;case 78:r=45,o=58;break;case 79:r=47,o=59;break;case 80:break;case 81:r=41,o=55;break;case 82:{const n=Ca(t,3);return ii(e,Ca(t,1),Ca(t,2),n),!0}case 83:return ii(e,Ca(t,1),Ca(t,2),8),ii(e,Ca(t,3),Ca(t,4),8),!0;case 84:return ii(e,Ca(t,1),Ca(t,2),8),ii(e,Ca(t,3),Ca(t,4),8),ii(e,Ca(t,5),Ca(t,6),8),!0;case 85:return ii(e,Ca(t,1),Ca(t,2),8),ii(e,Ca(t,3),Ca(t,4),8),ii(e,Ca(t,5),Ca(t,6),8),ii(e,Ca(t,7),Ca(t,8),8),!0;default:return!1}return e.local("pLocals"),ri(e,Ca(t,2),r),oi(e,Ca(t,1),o),!0}function di(e,t,n,r){const o=r>=23&&r<=36||r>=50&&r<=60,s=Ca(n,o?2:1),a=Ca(n,3),i=Ca(n,o?1:2),c=e.allowNullCheckOptimization&&Xa.has(s)&&!ci(e,s);36!==r&&45!==r&&li(e,s,n,!1);let l=54,p=40;switch(r){case 23:p=44;break;case 24:p=45;break;case 25:p=46;break;case 26:p=47;break;case 31:case 41:case 27:break;case 43:case 29:p=42,l=56;break;case 44:case 30:p=43,l=57;break;case 37:case 38:l=58;break;case 39:case 40:l=59;break;case 28:case 42:p=41,l=55;break;case 45:return c||e.block(),e.local("pLocals"),e.i32_const(a),e.i32_const(s),e.i32_const(i),e.callImport("stfld_o"),c?(e.appendU8(26),da(7,1)):(e.appendU8(13),e.appendULeb(0),Ws(e,n,2),e.endBlock()),!0;case 32:{const t=Ca(n,4);return si(e,i,t),e.local("cknull_ptr"),0!==a&&(e.i32_const(a),e.appendU8(106)),Ys(e,t),!0}case 46:{const r=za(t,Ca(n,4));return e.local("cknull_ptr"),0!==a&&(e.i32_const(a),e.appendU8(106)),si(e,i,0),e.ptr_const(r),e.callImport("value_copy"),!0}case 47:{const t=Ca(n,4);return e.local("cknull_ptr"),0!==a&&(e.i32_const(a),e.appendU8(106)),si(e,i,0),Ys(e,t),!0}case 36:case 35:return e.local("pLocals"),ri(e,s,40),0!==a&&(e.i32_const(a),e.appendU8(106)),oi(e,i,l),!0;default:return!1}return o&&e.local("pLocals"),e.local("cknull_ptr"),o?(e.appendU8(p),e.appendMemarg(a,0),oi(e,i,l),!0):(ri(e,i,p),e.appendU8(l),e.appendMemarg(a,0),!0)}function fi(e,t,n,r){const o=r>=23&&r<=36||r>=50&&r<=60,s=Ca(n,1),a=za(t,Ca(n,2)),i=za(t,Ca(n,3));!function(e,t,n){e.block(),e.ptr_const(t),e.appendU8(45),e.appendMemarg(ea(0),0),e.appendU8(13),e.appendULeb(0),Ws(e,n,3),e.endBlock()}(e,a,n);let c=54,l=40;switch(r){case 50:l=44;break;case 51:l=45;break;case 52:l=46;break;case 53:l=47;break;case 58:case 65:case 54:break;case 67:case 56:l=42,c=56;break;case 68:case 57:l=43,c=57;break;case 61:case 62:c=58;break;case 63:case 64:c=59;break;case 55:case 66:l=41,c=55;break;case 69:return e.ptr_const(i),si(e,s,0),e.callImport("copy_ptr"),!0;case 59:{const t=Ca(n,4);return si(e,s,t),e.ptr_const(i),Ys(e,t),!0}case 72:return e.local("pLocals"),e.ptr_const(i),oi(e,s,c),!0;default:return!1}return o?(e.local("pLocals"),e.ptr_const(i),e.appendU8(l),e.appendMemarg(0,0),oi(e,s,c),!0):(e.ptr_const(i),ri(e,s,l),e.appendU8(c),e.appendMemarg(0,0),!0)}function _i(e,t,n){let r,o,s,a,i="math_lhs32",c="math_rhs32",l=!1;const p=ka[n];if(p){e.local("pLocals");const r=1==p;return ri(e,Ca(t,2),r?43:42),r||e.appendU8(p),ri(e,Ca(t,3),r?43:42),r||e.appendU8(p),e.i32_const(n),e.callImport("relop_fp"),oi(e,Ca(t,1),54),!0}switch(n){case 382:case 383:return wi(e,t,n);default:if(a=Sa[n],!a)return!1;a.length>3?(r=a[1],o=a[2],s=a[3]):(r=o=a[1],s=a[2])}switch(n){case 356:case 357:case 360:case 361:case 380:case 381:case 384:case 385:{const s=361===n||385===n||357===n||381===n;i=s?"math_lhs64":"math_lhs32",c=s?"math_rhs64":"math_rhs32",e.block(),ri(e,Ca(t,2),r),e.local(i,33),ri(e,Ca(t,3),o),e.local(c,34),l=!0,s&&(e.appendU8(80),e.appendU8(69)),e.appendU8(13),e.appendULeb(0),Ws(e,t,12),e.endBlock(),356!==n&&380!==n&&357!==n&&381!==n||(e.block(),e.local(c),s?e.i52_const(-1):e.i32_const(-1),e.appendU8(s?82:71),e.appendU8(13),e.appendULeb(0),e.local(i),e.appendU8(s?66:65),e.appendBoundaryValue(s?64:32,-1),e.appendU8(s?82:71),e.appendU8(13),e.appendULeb(0),Ws(e,t,13),e.endBlock());break}case 362:case 364:case 366:case 368:ri(e,Ca(t,2),r),e.local(i,34),ri(e,Ca(t,3),o),e.local(c,34),e.i32_const(n),e.callImport(364===n||368===n?"ckovr_u4":"ckovr_i4"),e.block(64,4),Ws(e,t,13),e.endBlock(),l=!0}return e.local("pLocals"),l?(e.local(i),e.local(c)):(ri(e,Ca(t,2),r),ri(e,Ca(t,3),o)),e.appendU8(a[0]),oi(e,Ca(t,1),s),!0}function mi(e,t,n){const r=wa[n];if(!r)return!1;const o=r[1],s=r[2];switch((n<472||n>507)&&e.local("pLocals"),n){case 428:case 430:ri(e,Ca(t,2),o),e.i32_const(1);break;case 432:e.i32_const(0),ri(e,Ca(t,2),o);break;case 436:ri(e,Ca(t,2),o),e.i32_const(-1);break;case 444:case 445:ri(e,Ca(t,2),o),41===o&&e.appendU8(167),e.i32_const(255);break;case 452:case 453:ri(e,Ca(t,2),o),41===o&&e.appendU8(167),e.i32_const(65535);break;case 440:case 441:ri(e,Ca(t,2),o),41===o&&e.appendU8(167),e.i32_const(24),e.appendU8(116),e.i32_const(24);break;case 448:case 449:ri(e,Ca(t,2),o),41===o&&e.appendU8(167),e.i32_const(16),e.appendU8(116),e.i32_const(16);break;case 429:case 431:ri(e,Ca(t,2),o),e.i52_const(1);break;case 433:e.i52_const(0),ri(e,Ca(t,2),o);break;case 437:ri(e,Ca(t,2),o),e.i52_const(-1);break;case 511:case 515:case 519:case 521:case 525:case 527:case 523:case 640:case 642:ri(e,Ca(t,2),o),e.i32_const(Da(t,3));break;case 512:case 516:case 520:case 522:ri(e,Ca(t,2),o),e.i32_const(Pa(t,3));break;case 513:case 517:case 526:case 528:case 524:case 641:case 643:ri(e,Ca(t,2),o),e.i52_const(Da(t,3));break;case 514:case 518:ri(e,Ca(t,2),o),e.i52_const(Pa(t,3));break;default:ri(e,Ca(t,2),o)}return 1!==r[0]&&e.appendU8(r[0]),oi(e,Ca(t,1),s),!0}function hi(e,t,n,r){const o=133===r?t+6:t+8,s=Va(n,O(o-2));e.local("pLocals"),e.ptr_const(o),e.appendU8(54),e.appendMemarg(s,0),e.callHandlerReturnAddresses.push(o)}function gi(e,t){const n=o.mono_jiterp_get_opcode_info(t,4),r=e+2+2*o.mono_jiterp_get_opcode_info(t,2);let s;switch(n){case 7:s=F(r);break;case 8:s=z(r);break;case 17:s=z(r+2);break;default:return}return s}function bi(e,t,n,r){const s=r>=227&&r<=270,a=gi(t,r);if("number"!=typeof a)return!1;switch(r){case 132:case 133:case 128:case 129:{const s=132===r||133===r,i=t+2*a;return a<=0?e.backBranchOffsets.indexOf(i)>=0?(e.backBranchTraceLevel>1&&Ve(`0x${t.toString(16)} performing backward branch to 0x${i.toString(16)}`),s&&hi(e,t,n,r),e.cfg.branch(i,!0,0),da(9,1),!0):(i1||e.cfg.trace>1)&&Ve(`0x${t.toString(16)} ${$s(r)} target 0x${i.toString(16)} before start of trace`):(e.backBranchTraceLevel>0||e.cfg.trace>0)&&Ve(`0x${t.toString(16)} ${$s(r)} target 0x${i.toString(16)} not found in list `+e.backBranchOffsets.map((e=>"0x"+e.toString(16))).join(", ")),o.mono_jiterp_boost_back_branch_target(i),Ws(e,i,5),da(10,1),!0):(e.branchTargets.add(i),s&&hi(e,t,n,r),e.cfg.branch(i,!1,0),!0)}case 145:case 143:case 229:case 227:case 146:case 144:{const n=146===r||144===r;ri(e,Ca(t,1),n?41:40),143===r||227===r?e.appendU8(69):144===r?e.appendU8(80):146===r&&(e.appendU8(80),e.appendU8(69));break}default:if(void 0===va[r])throw new Error(`Unsupported relop branch opcode: ${$s(r)}`);if(4!==o.mono_jiterp_get_opcode_info(r,1))throw new Error(`Unsupported long branch opcode: ${$s(r)}`)}const i=t+2*a;return a<0?e.backBranchOffsets.indexOf(i)>=0?(e.backBranchTraceLevel>1&&Ve(`0x${t.toString(16)} performing conditional backward branch to 0x${i.toString(16)}`),e.cfg.branch(i,!0,s?3:1),da(9,1)):(i1||e.cfg.trace>1)&&Ve(`0x${t.toString(16)} ${$s(r)} target 0x${i.toString(16)} before start of trace`):(e.backBranchTraceLevel>0||e.cfg.trace>0)&&Ve(`0x${t.toString(16)} ${$s(r)} target 0x${i.toString(16)} not found in list `+e.backBranchOffsets.map((e=>"0x"+e.toString(16))).join(", ")),o.mono_jiterp_boost_back_branch_target(i),e.block(64,4),Ws(e,i,5),e.endBlock(),da(10,1)):(e.branchTargets.add(i),e.cfg.branch(i,!1,s?3:1)),!0}function yi(e,t,n,r){const o=va[r];if(!o)return!1;const s=Array.isArray(o)?o[0]:o,a=Sa[s],i=ka[s];if(!a&&!i)return!1;const c=a?a[1]:1===i?43:42;return ri(e,Ca(t,1),c),a||1===i||e.appendU8(i),Array.isArray(o)&&o[1]?(e.appendU8(o[1]),e.appendLeb(Da(t,2))):ri(e,Ca(t,2),c),a||1==i||e.appendU8(i),a?e.appendU8(a[0]):(e.i32_const(s),e.callImport("relop_fp")),bi(e,t,n,r)}function wi(e,t,n){let r,o,s,a;const i=Ca(t,1),c=Ca(t,2),l=Ca(t,3),p=Ua[n];if(!p)return!1;if(r=p[0],o=p[1],"string"==typeof p[2]?s=p[2]:a=p[2],e.local("pLocals"),r){if(ri(e,c,o?42:43),a)e.appendU8(a);else{if(!s)throw new Error("internal error");e.callImport(s)}return oi(e,i,o?56:57),!0}if(ri(e,c,o?42:43),ri(e,l,o?42:43),a)e.appendU8(a);else{if(!s)throw new Error("internal error");e.callImport(s)}return oi(e,i,o?56:57),!0}function ki(e,t,n){const r=n>=87&&n<=112,o=n>=107&&n<=112,s=n>=95&&n<=106||n>=120&&n<=127||o,a=n>=101&&n<=106||n>=124&&n<=127||o;let i,c,l=-1,p=0,u=1;o?(i=Ca(t,1),c=Ca(t,2),l=Ca(t,3),p=Da(t,4),u=Da(t,5)):s?a?r?(i=Ca(t,1),c=Ca(t,2),p=Da(t,3)):(i=Ca(t,2),c=Ca(t,1),p=Da(t,3)):r?(i=Ca(t,1),c=Ca(t,2),l=Ca(t,3)):(i=Ca(t,3),c=Ca(t,1),l=Ca(t,2)):r?(c=Ca(t,2),i=Ca(t,1)):(c=Ca(t,1),i=Ca(t,2));let d,f=54;switch(n){case 87:case 95:case 101:case 107:d=44;break;case 88:case 96:case 102:case 108:d=45;break;case 89:case 97:case 103:case 109:d=46;break;case 90:case 98:case 104:case 110:d=47;break;case 113:case 120:case 124:d=40,f=58;break;case 114:case 121:case 125:d=40,f=59;break;case 91:case 99:case 105:case 111:case 115:case 122:case 126:case 119:d=40;break;case 93:case 117:d=42,f=56;break;case 94:case 118:d=43,f=57;break;case 92:case 100:case 106:case 112:case 116:case 123:case 127:d=41,f=55;break;default:return!1}const _=ni(e,c,40,!0,!0);return _||li(e,c,t,!1),r?(e.local("pLocals"),_?mt(ni(e,c,40,!1,!0),"Unknown jiterpreter cprop failure"):e.local("cknull_ptr"),o?(ri(e,l,40),0!==p&&(e.i32_const(p),e.appendU8(106),p=0),1!==u&&(e.i32_const(u),e.appendU8(108)),e.appendU8(106)):s&&l>=0?(ri(e,l,40),e.appendU8(106)):p<0&&(e.i32_const(p),e.appendU8(106),p=0),e.appendU8(d),e.appendMemarg(p,0),oi(e,i,f)):119===n?(_?mt(ni(e,c,40,!1,!0),"Unknown jiterpreter cprop failure"):e.local("cknull_ptr"),si(e,i,0),e.callImport("copy_ptr")):(_?mt(ni(e,c,40,!1,!0),"Unknown jiterpreter cprop failure"):e.local("cknull_ptr"),s&&l>=0?(ri(e,l,40),e.appendU8(106)):p<0&&(e.i32_const(p),e.appendU8(106),p=0),ri(e,i,d),e.appendU8(f),e.appendMemarg(p,0)),!0}function Si(e,t,n,r,o){e.block(),ri(e,r,40),e.local("index",34);let s="cknull_ptr";e.options.zeroPageOptimization&&aa()?(da(8,1),ri(e,n,40),s="src_ptr",e.local(s,34)):li(e,n,t,!0),e.appendU8(40),e.appendMemarg(ea(9),2),e.appendU8(73),e.appendU8(13),e.appendULeb(0),Ws(e,t,9),e.endBlock(),e.local(s),e.i32_const(ea(1)),e.appendU8(106),e.local("index"),1!=o&&(e.i32_const(o),e.appendU8(108)),e.appendU8(106)}function vi(e,t,n,r){const o=r<=328&&r>=315||341===r,s=Ca(n,o?2:1),a=Ca(n,o?1:3),i=Ca(n,o?3:2);let c,l,p=54;switch(r){case 341:return e.local("pLocals"),li(e,s,n,!0),e.appendU8(40),e.appendMemarg(ea(9),2),oi(e,a,54),!0;case 326:return e.local("pLocals"),l=Ca(n,4),Si(e,n,s,i,l),oi(e,a,54),!0;case 337:return e.block(),ri(e,Ca(n,1),40),ri(e,Ca(n,2),40),ri(e,Ca(n,3),40),e.callImport("stelemr_tc"),e.appendU8(13),e.appendULeb(0),Ws(e,n,10),e.endBlock(),!0;case 340:return Si(e,n,s,i,4),si(e,a,0),e.callImport("copy_ptr"),!0;case 324:case 320:case 319:case 333:l=4,c=40;break;case 315:l=1,c=44;break;case 316:l=1,c=45;break;case 330:case 329:l=1,c=40,p=58;break;case 317:l=2,c=46;break;case 318:l=2,c=47;break;case 332:case 331:l=2,c=40,p=59;break;case 322:case 335:l=4,c=42,p=56;break;case 321:case 334:l=8,c=41,p=55;break;case 323:case 336:l=8,c=43,p=57;break;case 325:{const t=Ca(n,4);return e.local("pLocals"),e.i32_const(Ca(n,1)),e.appendU8(106),Si(e,n,s,i,t),Ys(e,t),Ka(Ca(n,1),t),!0}case 338:{const r=Ca(n,5),o=za(t,Ca(n,4));return Si(e,n,s,i,r),si(e,a,0),e.ptr_const(o),e.callImport("value_copy"),!0}case 339:{const t=Ca(n,5);return Si(e,n,s,i,t),si(e,a,0),Ys(e,t),!0}default:return!1}return o?(e.local("pLocals"),Si(e,n,s,i,l),e.appendU8(c),e.appendMemarg(0,0),oi(e,a,p)):(Si(e,n,s,i,l),ri(e,a,c),e.appendU8(p),e.appendMemarg(0,0)),!0}function Ui(e,t,n){const r=`${t}_${n.toString(16)}`;return"object"!=typeof e.importedFunctions[r]&&e.defineImportedFunction("s",r,t,!1,n),r}function Ti(e,t,n,r,s,a){if(e.options.enableSimd&&ct.featureWasmSimd)switch(s){case 2:if(function(e,t,n){const r=o.mono_jiterp_get_simd_opcode(1,n),s=Na[n];if(s)return xi(e,t),e.appendSimd(s),oi(e,Ca(t,1),54),!0;if(r>=0)return Ra.has(n)?(e.local("pLocals"),ri(e,Ca(t,2),40),e.appendSimd(r,!0),e.appendMemarg(0,0),Ei(e,t)):(xi(e,t),e.appendSimd(r),Ei(e,t)),!0;switch(n){case 6:case 7:case 8:case 9:{const r=Oa[n];return e.local("pLocals"),e.v128_const(0),ri(e,Ca(t,2),r[0]),e.appendSimd(r[1]),e.appendU8(0),oi(e,Ca(t,1),253,11),!0}case 14:return xi(e,t,7),Ei(e,t),!0;case 15:return xi(e,t,8),Ei(e,t),!0;case 16:return xi(e,t,9),Ei(e,t),!0;case 17:return xi(e,t,10),Ei(e,t),!0;default:return!1}}(e,t,a))return!0;break;case 3:if(function(e,t,n){const r=o.mono_jiterp_get_simd_opcode(2,n);if(r>=0){const o=ja.has(n),s=$a[n];if(o)e.local("pLocals"),ri(e,Ca(t,2),253,0),ri(e,Ca(t,3),40),e.appendSimd(r),Ei(e,t);else if(Array.isArray(s)){const n=Ga(e,Ca(t,3)),o=s[0];if("number"!=typeof n)return He(`${e.functions[0].name}: Non-constant lane index passed to ExtractScalar`),!1;if(n>=o||n<0)return He(`${e.functions[0].name}: ExtractScalar index ${n} out of range (0 - ${o-1})`),!1;e.local("pLocals"),ri(e,Ca(t,2),253,0),e.appendSimd(r),e.appendU8(n),oi(e,Ca(t,1),s[1])}else Ii(e,t),e.appendSimd(r),Ei(e,t);return!0}switch(n){case 191:return ri(e,Ca(t,2),40),ri(e,Ca(t,3),253,0),e.appendSimd(11),e.appendMemarg(0,0),!0;case 10:case 11:return Ii(e,t),e.appendSimd(214),e.appendSimd(195),11===n&&e.appendU8(69),oi(e,Ca(t,1),54),!0;case 12:case 13:{const r=13===n,o=r?71:65;return e.local("pLocals"),ri(e,Ca(t,2),253,0),e.local("math_lhs128",34),ri(e,Ca(t,3),253,0),e.local("math_rhs128",34),e.appendSimd(o),e.local("math_lhs128"),e.local("math_lhs128"),e.appendSimd(o),e.local("math_rhs128"),e.local("math_rhs128"),e.appendSimd(o),e.appendSimd(80),e.appendSimd(77),e.appendSimd(80),e.appendSimd(r?195:163),oi(e,Ca(t,1),54),!0}case 47:{const n=Ca(t,3),r=Ga(e,n);return e.local("pLocals"),ri(e,Ca(t,2),253,0),"object"==typeof r?(e.appendSimd(12),e.appendBytes(r)):ri(e,n,253,0),e.appendSimd(14),Ei(e,t),!0}case 48:case 49:return function(e,t,n){const r=16/n,o=Ca(t,3),s=Ga(e,o);if(2!==r&&4!==r&&mt(!1,"Unsupported shuffle element size"),e.local("pLocals"),ri(e,Ca(t,2),253,0),"object"==typeof s){const t=new Uint8Array(bc),o=2===r?new Uint16Array(s.buffer,s.byteOffset,n):new Uint32Array(s.buffer,s.byteOffset,n);for(let e=0,s=0;e=0){const o=La[n],s=Ba[n];if(Array.isArray(o)){const n=o[0],s=Ga(e,Ca(t,3));if("number"!=typeof s)return He(`${e.functions[0].name}: Non-constant lane index passed to ReplaceScalar`),!1;if(s>=n||s<0)return He(`${e.functions[0].name}: ReplaceScalar index ${s} out of range (0 - ${n-1})`),!1;e.local("pLocals"),ri(e,Ca(t,2),253,0),ri(e,Ca(t,4),o[1]),e.appendSimd(r),e.appendU8(s),Ei(e,t)}else if(Array.isArray(s)){const n=s[0],o=Ga(e,Ca(t,4));if("number"!=typeof o)return He(`${e.functions[0].name}: Non-constant lane index passed to store method`),!1;if(o>=n||o<0)return He(`${e.functions[0].name}: Store lane ${o} out of range (0 - ${n-1})`),!1;ri(e,Ca(t,2),40),ri(e,Ca(t,3),253,0),e.appendSimd(r),e.appendMemarg(0,0),e.appendU8(o)}else!function(e,t){e.local("pLocals"),ri(e,Ca(t,2),253,0),ri(e,Ca(t,3),253,0),ri(e,Ca(t,4),253,0)}(e,t),e.appendSimd(r),Ei(e,t);return!0}switch(n){case 0:return e.local("pLocals"),ri(e,Ca(t,3),253,0),ri(e,Ca(t,4),253,0),ri(e,Ca(t,2),253,0),e.appendSimd(82),Ei(e,t),!0;case 7:{const n=Ga(e,Ca(t,4));if("object"!=typeof n)return He(`${e.functions[0].name}: Non-constant indices passed to PackedSimd.Shuffle`),!1;for(let t=0;t<32;t++){const r=n[t];if(r<0||r>31)return He(`${e.functions[0].name}: Shuffle lane index #${t} (${r}) out of range (0 - 31)`),!1}return e.local("pLocals"),ri(e,Ca(t,2),253,0),ri(e,Ca(t,3),253,0),e.appendSimd(13),e.appendBytes(n),Ei(e,t),!0}default:return!1}}(e,t,a))return!0}switch(n){case 652:if(e.options.enableSimd&&ct.featureWasmSimd){e.local("pLocals");const n=K().slice(t+4,t+4+bc);e.v128_const(n),Ei(e,t),Ha.set(Ca(t,1),{type:"v128",value:n})}else si(e,Ca(t,1),bc),e.ptr_const(t+4),Ys(e,bc);return!0;case 653:case 654:case 655:case 656:{const r=xa[n],o=bc/r,s=Ca(t,1),a=Ca(t,2),i=Ia[n],c=Aa[n];for(let t=0;t2;return e.local("pLocals"),li(e,Ca(t,2),t,!0),ri(e,Ca(t,3),n?41:40),e.appendAtomic(r[0],!1),e.appendMemarg(0,r[2]),0!==r[1]&&e.appendU8(r[1]),oi(e,Ca(t,1),n?55:54),!0}const o=Ea[n];if(o){const n=o[2]>2;return e.local("pLocals"),li(e,Ca(t,2),t,!0),ri(e,Ca(t,4),n?41:40),ri(e,Ca(t,3),n?41:40),e.appendAtomic(o[0],!1),e.appendMemarg(0,o[2]),0!==o[1]&&e.appendU8(o[1]),oi(e,Ca(t,1),n?55:54),!0}return!1}function ji(e,t,n){const r=Ja(t,271),o=function(e){271!==O(e)&&mt(!1,"decodeSwitch called on a non-switch");const t=Fa(e,2),n=[];for(let r=0;re.options.maxSwitchSize)s=!0;else for(const n of o)n>t&&e.branchTargets.add(n);if(s)return da(14,o.length),Ws(e,t,27),!0;const a=t+2*r;return e.branchTargets.add(a),e.block(),ri(e,Ca(t,1),40),e.cfg.jumpTable(o,a),e.endBlock(),Hs(e,t,n,28),!0}const $i=64;let Li,Ri,Bi,Ni=0;const Oi={};function Ci(){return Ri||(Ri=[oa("interp_entry_prologue",ta("mono_jiterp_interp_entry_prologue")),oa("interp_entry",ta("mono_jiterp_interp_entry")),oa("unbox",ta("mono_jiterp_object_unbox")),oa("stackval_from_data",ta("mono_jiterp_stackval_from_data"))],Ri)}let Di,Fi=class{constructor(e,t,n,r,o,s,a,i){this.imethod=e,this.method=t,this.argumentCount=n,this.unbox=o,this.hasThisReference=s,this.hasReturnValue=a,this.paramTypes=new Array(n);for(let e=0;ee&&(n=n.substring(n.length-e,n.length)),n=`${this.imethod.toString(16)}_${n}`}else n=`${this.imethod.toString(16)}_${this.hasThisReference?"i":"s"}${this.hasReturnValue?"_r":""}_${this.argumentCount}`;this.traceName=n}finally{e&&m(e)}}getTraceName(){return this.traceName||this.generateName(),this.traceName||"unknown"}getName(){return this.name||this.generateName(),this.name||"unknown"}};function Pi(){const e=[];let t=0;for(;0!=(t=o.mono_jiterp_tlqueue_next(1));){const n=Oi[t];n?e.push(n):Ve(`Failed to find corresponding info for method ptr ${t} from jit queue!`)}if(!e.length)return;const n=4*e.length+1;let r=Li;if(r?r.clear(n):(Li=r=new Cs(n),r.defineType("unbox",{pMonoObject:127},127,!0),r.defineType("interp_entry_prologue",{pData:127,this_arg:127},127,!0),r.defineType("interp_entry",{pData:127,res:127},64,!0),r.defineType("stackval_from_data",{type:127,result:127,value:127},64,!0)),r.options.wasmBytesLimit<=ua(6))return;const s=zs();let a=0,i=!0,c=!1;try{r.appendU32(1836278016),r.appendU32(1);for(let t=0;tec[o.mono_jiterp_type_to_ldind(e)])),this.enableDirect=fa().directJitCalls&&!this.noWrapper&&this.wasmNativeReturnType&&(0===this.wasmNativeSignature.length||this.wasmNativeSignature.every((e=>e))),this.enableDirect&&(this.target=this.addr);let c=this.target.toString(16);const l=Gi++;this.name=`${this.enableDirect?"jcp":"jcw"}_${c}_${l.toString(16)}`}}function Zi(e){let t=Ji[e];return t||(e>=Ji.length&&(Ji.length=e+1),qi||(qi=qs()),Ji[e]=t=qi.get(e)),t}function Ki(){const e=[];let t=0;for(;0!=(t=o.mono_jiterp_tlqueue_next(0));){const n=Qi[t];if(n)for(let t=0;t0){o.mono_jiterp_register_jit_call_thunk(n.cinfo,r);for(let e=0;e0&&(kc.push(["trace_eip","trace_eip",Ic]),kc.push(["trace_args","trace_eip",Ac])),(ct.emscriptenBuildOptions.enableEventPipe||ct.emscriptenBuildOptions.enableDevToolsProfiler)&&(kc.push(oa("prof_enter",ta("mono_jiterp_prof_enter"))),kc.push(oa("prof_samplepoint",ta("mono_jiterp_prof_samplepoint"))),kc.push(oa("prof_leave",ta("mono_jiterp_prof_leave"))));const e=(e,t)=>{for(let n=0;n>>0,ac.operand2=t>>>0}function jc(e,t,n,r){if("number"==typeof r)o.mono_jiterp_adjust_abort_count(r,1),r=$s(r);else{let e=mc[r];"number"!=typeof e?e=1:e++,mc[r]=e}hc[e].abortReason=r}function $c(e){if(!ct.runtimeReady)return;if(ic||(ic=fa()),!ic.enableStats)return;const t=ua(9),n=ua(10),r=ua(7),s=ua(8),a=ua(3),i=ua(4),c=ua(2),l=ua(1),p=ua(0),u=ua(6),d=ua(11),f=ua(12),_=ua(13),m=ua(14),h=t/(t+n)*100,g=o.mono_jiterp_get_rejected_trace_count(),b=ic.eliminateNullChecks?r.toString():"off",y=ic.zeroPageOptimization?s.toString()+(aa()?"":" (disabled)"):"off",w=ic.enableBackwardBranches?`emitted: ${t}, failed: ${n} (${h.toFixed(1)}%)`:": off",k=a?ic.directJitCalls?`direct jit calls: ${i} (${(i/a*100).toFixed(1)}%)`:"direct jit calls: off":"";if(Ve(`// jitted ${u}b; ${l} traces (${(l/p*100).toFixed(1)}%) (${g} rejected); ${a} jit_calls; ${c} interp_entries`),Ve(`// cknulls pruned: ${b}, fused: ${y}; back-brs ${w}; switch tgts ${_}/${m+_}; ${k}`),Ve(`// time: ${0|d}ms generating, ${0|f}ms compiling wasm.`),!e){if(ic.countBailouts){const e=Object.values(hc);e.sort(((e,t)=>(t.bailoutCount||0)-(e.bailoutCount||0)));for(let e=0;et.hitCount-e.hitCount)),Ve("// hottest failed traces:");for(let e=0,n=0;e=0)){if(t[e].abortReason){if(t[e].abortReason.startsWith("mono_icall_")||t[e].abortReason.startsWith("ret."))continue;switch(t[e].abortReason){case"trace-too-small":case"trace-too-big":case"call":case"callvirt.fast":case"calli.nat.fast":case"calli.nat":case"call.delegate":case"newobj":case"newobj_vt":case"newobj_slow":case"switch":case"rethrow":case"end-of-body":case"ret":case"intrins_marvin_block":case"intrins_ascii_chars_to_uppercase":continue}}n++,Ve(`${t[e].name} @${t[e].ip} (${t[e].hitCount} hits) ${t[e].abortReason}`)}const n=[];for(const t in e)n.push([t,e[t]]);n.sort(((e,t)=>t[1]-e[1])),Ve("// heat:");for(let e=0;e0?mc[t]=n:delete mc[t]}const e=Object.keys(mc);e.sort(((e,t)=>mc[t]-mc[e]));for(let t=0;te.toString(16).padStart(2,"0"))).join("")}`}async function Cc(e){const t=lt.config.resources.lazyAssembly;if(!t)throw new Error("No assemblies have been marked as lazy-loadable. Use the 'BlazorWebAssemblyLazyLoad' item group in your project file to enable lazy loading an assembly.");let n=e;e.endsWith(".dll")?n=e.substring(0,e.length-4):e.endsWith(".wasm")&&(n=e.substring(0,e.length-5));const r=n+".dll",o=n+".wasm";let s=null;for(let e=0;eObject.prototype.hasOwnProperty.call(t,e))).map((e=>{const n=[];for(let r=0;re.concat(t)),new Array).map((async e=>{const t=await e;!function(e){lt.assert_runtime_running();const t=Ke.stackSave();try{const t=$n(3),n=Ln(t,2);Wn(n,21),vo(n,e,4),kn(yn.LoadSatelliteAssembly,t)}finally{lt.is_runtime_running()&&Ke.stackRestore(t)}}(new Uint8Array(t))})))}function Fc(e){if(e===l)return null;const t=o.mono_wasm_read_as_bool_or_null_unsafe(e);return 0!==t&&(1===t||null)}function Pc(e){if(e)try{(e=e.toLocaleLowerCase().replace("_","-")).startsWith("zh-")&&(e=e.replace("-chs","-Hans").replace("-cht","-Hant"));const t=Intl.getCanonicalLocales(e);return t.length>0?t[0]:void 0}catch(e){return}}const Mc=[function(e){Xo&&(globalThis.clearTimeout(Xo),Xo=void 0),Xo=Ke.safeSetTimeout(mono_wasm_schedule_timer_tick,e)},function(e,t,n,r,o){if(!0!==ct.mono_wasm_runtime_is_ready)return;const s=K(),a=0!==e?Le(e).concat(".dll"):"",i=ht(new Uint8Array(s.buffer,t,n));let c;r&&(c=ht(new Uint8Array(s.buffer,r,o))),Lt({eventName:"AssemblyLoaded",assembly_name:a,assembly_b64:i,pdb_b64:c})},function(e,t){const n=Le(t);et.logging&&"function"==typeof et.logging.debugger&&et.logging.debugger(e,n)},function(e,t,n,r){const o={res_ok:e,res:{id:t,value:ht(new Uint8Array(K().buffer,n,r))}};bt.has(t)&&We(`Adding an id (${t}) that already exists in commands_received`),bt.set(t,o)},function mono_wasm_fire_debugger_agent_message_with_data(e,t){mono_wasm_fire_debugger_agent_message_with_data_to_pause(ht(new Uint8Array(K().buffer,e,t)))},mono_wasm_fire_debugger_agent_message_with_data_to_pause,function(){Jo||(Jo=Ke.safeSetTimeout(Ko,0))},function(e,t,n,r,s,a,i,c){if(n||mt(!1,"expected instruction pointer"),ic||(ic=fa()),!ic.enableTraces)return 1;if(ic.wasmBytesLimit<=ua(6))return 1;if(cc)return 1;let l,p=hc[r];if(p||(hc[r]=p=new dc(n,r,i)),da(0,1),ic.estimateHeat||pc.length>0||p.isVerbose){const e=o.mono_wasm_method_get_full_name(t);l=Le(e),m(e)}const u=Le(o.mono_wasm_method_get_name(t));p.name=l||u;let d=ic.noExitBackwardBranches?function(e,t,n){const r=t+n,o=[],s=(e-t)/2;for(;e=s&&o.push(r)}switch(r){case 132:case 133:o.push(n+a)}}e+=2*a}return o.length<=0?null:new Uint16Array(o)}(n,s,a):null;if(d&&n!==s){const e=(n-s)/2;let t=!1;for(let n=0;n=e){t=!0;break}t||(d=null)}const f=function(e,t,n,r,s,a,i,c,l){let p=wc;p?p.clear(8):(wc=p=new Cs(8),function(e){e.defineType("trace",{frame:127,pLocals:127,cinfo:127,ip:127},127,!0),e.defineType("bailout",{retval:127,base:127,reason:127},127,!0),e.defineType("copy_ptr",{dest:127,src:127},64,!0),e.defineType("value_copy",{dest:127,src:127,klass:127},64,!0),e.defineType("entry",{imethod:127},127,!0),e.defineType("strlen",{ppString:127,pResult:127},127,!0),e.defineType("getchr",{ppString:127,pIndex:127,pResult:127},127,!0),e.defineType("getspan",{destination:127,span:127,index:127,element_size:127},127,!0),e.defineType("overflow_check_i4",{lhs:127,rhs:127,opcode:127},127,!0),e.defineType("mathop_d_d",{value:124},124,!0),e.defineType("mathop_dd_d",{lhs:124,rhs:124},124,!0),e.defineType("mathop_f_f",{value:125},125,!0),e.defineType("mathop_ff_f",{lhs:125,rhs:125},125,!0),e.defineType("fmaf",{x:125,y:125,z:125},125,!0),e.defineType("fma",{x:124,y:124,z:124},124,!0),e.defineType("trace_eip",{traceId:127,eip:127},64,!0),e.defineType("newobj_i",{ppDestination:127,vtable:127},127,!0),e.defineType("newstr",{ppDestination:127,length:127},127,!0),e.defineType("newarr",{ppDestination:127,vtable:127,length:127},127,!0),e.defineType("localloc",{destination:127,len:127,frame:127},64,!0),e.defineType("ld_del_ptr",{ppDestination:127,ppSource:127},64,!0),e.defineType("ldtsflda",{ppDestination:127,offset:127},64,!0),e.defineType("gettype",{destination:127,source:127},127,!0),e.defineType("castv2",{destination:127,source:127,klass:127,opcode:127},127,!0),e.defineType("hasparent",{klass:127,parent:127},127,!0),e.defineType("imp_iface",{vtable:127,klass:127},127,!0),e.defineType("imp_iface_s",{obj:127,vtable:127,klass:127},127,!0),e.defineType("box",{vtable:127,destination:127,source:127,vt:127},64,!0),e.defineType("conv",{destination:127,source:127,opcode:127},127,!0),e.defineType("relop_fp",{lhs:124,rhs:124,opcode:127},127,!0),e.defineType("safepoint",{frame:127,ip:127},64,!0),e.defineType("prof_enter",{frame:127,ip:127},64,!0),e.defineType("prof_samplepoint",{frame:127,ip:127},64,!0),e.defineType("prof_leave",{frame:127,ip:127},64,!0),e.defineType("hashcode",{ppObj:127},127,!0),e.defineType("try_hash",{ppObj:127},127,!0),e.defineType("hascsize",{ppObj:127},127,!0),e.defineType("hasflag",{klass:127,dest:127,sp1:127,sp2:127},64,!0),e.defineType("array_rank",{destination:127,source:127},127,!0),e.defineType("stfld_o",{locals:127,fieldOffsetBytes:127,targetLocalOffsetBytes:127,sourceLocalOffsetBytes:127},127,!0),e.defineType("notnull",{ptr:127,expected:127,traceIp:127,ip:127},64,!0),e.defineType("stelemr",{o:127,aindex:127,ref:127},127,!0),e.defineType("simd_p_p",{arg0:127,arg1:127},64,!0),e.defineType("simd_p_pp",{arg0:127,arg1:127,arg2:127},64,!0),e.defineType("simd_p_ppp",{arg0:127,arg1:127,arg2:127,arg3:127},64,!0);const t=xc();for(let n=0;ni.indexOf(e)>=0))>=0;b&&!i&&mt(!1,"Expected methodFullName if trace is instrumented");const y=b?_c++:0;b&&(Ve(`instrumenting: ${i}`),fc[y]=new uc(i)),p.compressImportNames=!b;try{p.appendU32(1836278016),p.appendU32(1),p.generateTypeSection();const t={disp:127,cknull_ptr:127,dest_ptr:127,src_ptr:127,memop_dest:127,memop_src:127,index:127,count:127,math_lhs32:127,math_rhs32:127,math_lhs64:126,math_rhs64:126,temp_f32:125,temp_f64:124};p.options.enableSimd&&(t.v128_zero=123,t.math_lhs128=123,t.math_rhs128=123);let s=!0,i=0;if(p.defineFunction({type:"trace",name:d,export:!0,locals:t},(()=>{switch(p.base=n,p.traceIndex=a,p.frame=e,O(n)){case 674:case 675:case 677:case 676:break;default:throw new Error(`Expected *ip to be a jiterpreter opcode but it was ${O(n)}`)}return p.cfg.initialize(r,c,b?1:0),i=function(e,t,n,r,s,a,i,c){let l=!0,p=!1,u=!1,d=!1,f=0,_=0,m=0;Ya(),a.backBranchTraceLevel=i?2:0;let h=a.cfg.entry(n);for(;n&&n;){if(a.cfg.ip=n,n>=s){jc(a.traceIndex,0,0,"end-of-body"),i&&Ve(`instrumented trace ${t} exited at end of body @${n.toString(16)}`);break}const g=a.options.maxModuleSize-300-a.bytesGeneratedSoFar-a.cfg.overheadBytes;if(a.size>=g){jc(a.traceIndex,0,0,"trace-too-big"),i&&Ve(`instrumented trace ${t} exited because of size limit at @${n.toString(16)} (spaceLeft=${g}b)`);break}let b=O(n);const y=o.mono_jiterp_get_opcode_info(b,2),w=o.mono_jiterp_get_opcode_info(b,3),k=Ja(n,b),S=b>=657&&b<=659,v=S?b-657+2:0,U=S?Ca(n,1+v):0;b>=0&&b<691||mt(!1,`invalid opcode ${b}`);const T=S?ga[v][U]:$s(b),E=n,x=a.options.noExitBackwardBranches&&Wa(n,r,c),I=a.branchTargets.has(n),A=x||I||l&&c,j=m+_+a.branchTargets.size;let $=!1,L=ra(b);switch(x&&(a.backBranchTraceLevel>1&&Ve(`${t} recording back branch target 0x${n.toString(16)}`),a.backBranchOffsets.push(n)),A&&(u=!1,d=!1,ei(a,n,x),p=!0,Ya(),m=0),L<-1&&p&&(L=-2===L?2:0),l=!1,271===b||(lc.indexOf(b)>=0?(Ws(a,n,23),b=678):u&&(b=678)),b){case 271:ji(a,n,j)||(n=0);break;case 678:u&&(d||a.appendU8(0),d=!0);break;case 313:case 314:ai(a,Ca(n,1),0,Ca(n,2));break;case 312:si(a,Ca(n,1),0),ri(a,Ca(n,2),40),a.local("frame"),a.callImport("localloc");break;case 285:ri(a,Ca(n,1),40),a.i32_const(0),ri(a,Ca(n,2),40),a.appendU8(252),a.appendU8(11),a.appendU8(0);break;case 286:ri(a,Ca(n,1),40),Xs(a,0,Ca(n,2));break;case 310:{const e=Ca(n,3),t=Ca(n,2),r=Ca(n,1),o=Ga(a,e);0!==o&&("number"!=typeof o?(ri(a,e,40),a.local("count",34),a.block(64,4)):(a.i32_const(o),a.local("count",33)),ri(a,r,40),a.local("dest_ptr",34),a.appendU8(69),ri(a,t,40),a.local("src_ptr",34),a.appendU8(69),a.appendU8(114),a.block(64,4),Ws(a,n,2),a.endBlock(),"number"==typeof o&&Qs(a,0,0,o,!1,"dest_ptr","src_ptr")||(a.local("dest_ptr"),a.local("src_ptr"),a.local("count"),a.appendU8(252),a.appendU8(10),a.appendU8(0),a.appendU8(0)),"number"!=typeof o&&a.endBlock());break}case 311:{const e=Ca(n,3),t=Ca(n,2);li(a,Ca(n,1),n,!0),ri(a,t,40),ri(a,e,40),a.appendU8(252),a.appendU8(11),a.appendU8(0);break}case 143:case 145:case 227:case 229:case 144:case 146:case 129:case 132:case 133:bi(a,n,e,b)?p=!0:n=0;break;case 538:{const e=Ca(n,2),t=Ca(n,1);e!==t?(a.local("pLocals"),li(a,e,n,!0),oi(a,t,54)):li(a,e,n,!1),a.allowNullCheckOptimization&&Xa.set(t,n),$=!0;break}case 638:case 639:{const t=P(e+ea(4));a.ptr_const(t),a.callImport("entry"),a.block(64,4),Ws(a,n,1),a.endBlock();break}case 676:L=0;break;case 138:break;case 86:{a.local("pLocals");const e=Ca(n,2),r=ci(a,e),o=Ca(n,1),s=Ca(n,3);r||He(`${t}: Expected local ${e} to have address taken flag`),si(a,e,s),oi(a,o,54),Ha.set(o,{type:"ldloca",offset:e}),$=!0;break}case 272:case 300:case 301:case 556:{a.local("pLocals");let t=za(e,Ca(n,2));300===b&&(t=o.mono_jiterp_imethod_to_ftnptr(t)),a.ptr_const(t),oi(a,Ca(n,1),54);break}case 305:{const t=za(e,Ca(n,3));ri(a,Ca(n,1),40),ri(a,Ca(n,2),40),a.ptr_const(t),a.callImport("value_copy");break}case 306:{const e=Ca(n,3);ri(a,Ca(n,1),40),ri(a,Ca(n,2),40),Ys(a,e);break}case 307:{const e=Ca(n,3);si(a,Ca(n,1),e),li(a,Ca(n,2),n,!0),Ys(a,e);break}case 308:{const t=za(e,Ca(n,3));ri(a,Ca(n,1),40),si(a,Ca(n,2),0),a.ptr_const(t),a.callImport("value_copy");break}case 309:{const e=Ca(n,3);ri(a,Ca(n,1),40),si(a,Ca(n,2),0),Ys(a,e);break}case 540:a.local("pLocals"),li(a,Ca(n,2),n,!0),a.appendU8(40),a.appendMemarg(ea(2),2),oi(a,Ca(n,1),54);break;case 539:{a.block(),ri(a,Ca(n,3),40),a.local("index",34);let e="cknull_ptr";a.options.zeroPageOptimization&&aa()?(da(8,1),ri(a,Ca(n,2),40),e="src_ptr",a.local(e,34)):li(a,Ca(n,2),n,!0),a.appendU8(40),a.appendMemarg(ea(2),2),a.appendU8(72),a.local("index"),a.i32_const(0),a.appendU8(78),a.appendU8(113),a.appendU8(13),a.appendULeb(0),Ws(a,n,11),a.endBlock(),a.local("pLocals"),a.local("index"),a.i32_const(2),a.appendU8(108),a.local(e),a.appendU8(106),a.appendU8(47),a.appendMemarg(ea(3),1),oi(a,Ca(n,1),54);break}case 342:case 343:{const e=Da(n,4);a.block(),ri(a,Ca(n,3),40),a.local("index",34);let t="cknull_ptr";342===b?li(a,Ca(n,2),n,!0):(si(a,Ca(n,2),0),t="src_ptr",a.local(t,34)),a.appendU8(40),a.appendMemarg(ea(7),2),a.appendU8(73),a.local("index"),a.i32_const(0),a.appendU8(78),a.appendU8(113),a.appendU8(13),a.appendULeb(0),Ws(a,n,18),a.endBlock(),a.local("pLocals"),a.local(t),a.appendU8(40),a.appendMemarg(ea(8),2),a.local("index"),a.i32_const(e),a.appendU8(108),a.appendU8(106),oi(a,Ca(n,1),54);break}case 664:a.block(),ri(a,Ca(n,3),40),a.local("count",34),a.i32_const(0),a.appendU8(78),a.appendU8(13),a.appendULeb(0),Ws(a,n,18),a.endBlock(),si(a,Ca(n,1),16),a.local("dest_ptr",34),ri(a,Ca(n,2),40),a.appendU8(54),a.appendMemarg(0,0),a.local("dest_ptr"),a.local("count"),a.appendU8(54),a.appendMemarg(4,0);break;case 577:si(a,Ca(n,1),4),si(a,Ca(n,2),4),a.callImport("ld_del_ptr");break;case 73:si(a,Ca(n,1),4),a.ptr_const(Pa(n,2)),a.callImport("ldtsflda");break;case 663:a.block(),si(a,Ca(n,1),4),si(a,Ca(n,2),0),a.callImport("gettype"),a.appendU8(13),a.appendULeb(0),Ws(a,n,2),a.endBlock();break;case 660:{const t=za(e,Ca(n,4));a.ptr_const(t),si(a,Ca(n,1),4),si(a,Ca(n,2),0),si(a,Ca(n,3),0),a.callImport("hasflag");break}case 669:{const e=ea(1);a.local("pLocals"),li(a,Ca(n,2),n,!0),a.i32_const(e),a.appendU8(106),oi(a,Ca(n,1),54);break}case 661:a.local("pLocals"),si(a,Ca(n,2),0),a.callImport("hashcode"),oi(a,Ca(n,1),54);break;case 662:a.local("pLocals"),si(a,Ca(n,2),0),a.callImport("try_hash"),oi(a,Ca(n,1),54);break;case 665:a.local("pLocals"),si(a,Ca(n,2),0),a.callImport("hascsize"),oi(a,Ca(n,1),54);break;case 670:a.local("pLocals"),ri(a,Ca(n,2),40),a.local("math_lhs32",34),ri(a,Ca(n,3),40),a.appendU8(115),a.i32_const(2),a.appendU8(116),a.local("math_rhs32",33),a.local("math_lhs32"),a.i32_const(327685),a.appendU8(106),a.i32_const(10485920),a.appendU8(114),a.i32_const(1703962),a.appendU8(106),a.i32_const(-8388737),a.appendU8(114),a.local("math_rhs32"),a.appendU8(113),a.appendU8(69),oi(a,Ca(n,1),54);break;case 541:case 542:a.block(),si(a,Ca(n,1),4),si(a,Ca(n,2),0),a.callImport(541===b?"array_rank":"a_elesize"),a.appendU8(13),a.appendULeb(0),Ws(a,n,2),a.endBlock();break;case 289:case 290:{const t=za(e,Ca(n,3)),r=o.mono_jiterp_is_special_interface(t),s=289===b,i=Ca(n,1);if(!t){jc(a.traceIndex,0,0,"null-klass"),n=0;continue}a.block(),a.options.zeroPageOptimization&&aa()?(ri(a,Ca(n,2),40),a.local("dest_ptr",34),da(8,1)):(a.block(),ri(a,Ca(n,2),40),a.local("dest_ptr",34),a.appendU8(13),a.appendULeb(0),a.local("pLocals"),a.i32_const(0),oi(a,i,54),a.appendU8(12),a.appendULeb(1),a.endBlock(),a.local("dest_ptr")),r&&a.local("dest_ptr"),a.appendU8(40),a.appendMemarg(ea(14),0),a.ptr_const(t),a.callImport(r?"imp_iface_s":"imp_iface"),s&&(a.local("dest_ptr"),a.appendU8(69),a.appendU8(114)),a.block(64,4),a.local("pLocals"),a.local("dest_ptr"),oi(a,i,54),a.appendU8(5),s?Ws(a,n,19):(a.local("pLocals"),a.i32_const(0),oi(a,i,54)),a.endBlock(),a.endBlock();break}case 291:case 292:case 287:case 288:{const t=za(e,Ca(n,3)),r=291===b||292===b,o=287===b||291===b,s=Ca(n,1);if(!t){jc(a.traceIndex,0,0,"null-klass"),n=0;continue}a.block(),a.options.zeroPageOptimization&&aa()?(ri(a,Ca(n,2),40),a.local("dest_ptr",34),da(8,1)):(a.block(),ri(a,Ca(n,2),40),a.local("dest_ptr",34),a.appendU8(13),a.appendULeb(0),a.local("pLocals"),a.i32_const(0),oi(a,s,54),a.appendU8(12),a.appendULeb(1),a.endBlock(),a.local("dest_ptr")),a.appendU8(40),a.appendMemarg(ea(14),0),a.appendU8(40),a.appendMemarg(ea(15),0),r&&a.local("src_ptr",34),a.i32_const(t),a.appendU8(70),a.block(64,4),a.local("pLocals"),a.local("dest_ptr"),oi(a,s,54),a.appendU8(5),r?(a.local("src_ptr"),a.ptr_const(t),a.callImport("hasparent"),o&&(a.local("dest_ptr"),a.appendU8(69),a.appendU8(114)),a.block(64,4),a.local("pLocals"),a.local("dest_ptr"),oi(a,s,54),a.appendU8(5),o?Ws(a,n,19):(a.local("pLocals"),a.i32_const(0),oi(a,s,54)),a.endBlock()):(si(a,Ca(n,1),4),a.local("dest_ptr"),a.ptr_const(t),a.i32_const(b),a.callImport("castv2"),a.appendU8(69),a.block(64,4),Ws(a,n,19),a.endBlock()),a.endBlock(),a.endBlock();break}case 295:case 296:a.ptr_const(za(e,Ca(n,3))),si(a,Ca(n,1),4),si(a,Ca(n,2),0),a.i32_const(296===b?1:0),a.callImport("box");break;case 299:{const t=za(e,Ca(n,3)),r=ea(17),o=Ca(n,1),s=P(t+r);if(!t||!s){jc(a.traceIndex,0,0,"null-klass"),n=0;continue}a.options.zeroPageOptimization&&aa()?(ri(a,Ca(n,2),40),a.local("dest_ptr",34),da(8,1)):(li(a,Ca(n,2),n,!0),a.local("dest_ptr",34)),a.appendU8(40),a.appendMemarg(ea(14),0),a.appendU8(40),a.appendMemarg(ea(15),0),a.local("src_ptr",34),a.appendU8(40),a.appendMemarg(r,0),a.i32_const(s),a.appendU8(70),a.local("src_ptr"),a.appendU8(45),a.appendMemarg(ea(16),0),a.appendU8(69),a.appendU8(113),a.block(64,4),a.local("pLocals"),a.local("dest_ptr"),a.i32_const(ea(18)),a.appendU8(106),oi(a,o,54),a.appendU8(5),Ws(a,n,21),a.endBlock();break}case 294:a.block(),si(a,Ca(n,1),4),ri(a,Ca(n,2),40),a.callImport("newstr"),a.appendU8(13),a.appendULeb(0),Ws(a,n,17),a.endBlock();break;case 293:{a.block(),si(a,Ca(n,1),4);const t=za(e,Ca(n,3));a.i32_const(t),ri(a,Ca(n,2),40),a.callImport("newarr"),a.appendU8(13),a.appendULeb(0),Ws(a,n,17),a.endBlock();break}case 283:a.block(),si(a,Ca(n,1),4),a.ptr_const(za(e,Ca(n,2))),a.callImport("newobj_i"),a.appendU8(13),a.appendULeb(0),Ws(a,n,17),a.endBlock();break;case 282:case 284:case 544:case 543:p?(Hs(a,n,j,15),u=!0,L=0):n=0;break;case 546:case 547:case 548:case 549:case 545:p?(Hs(a,n,j,545==b?22:15),u=!0):n=0;break;case 137:case 134:Ws(a,n,16),u=!0;break;case 130:case 131:Ws(a,n,26),u=!0;break;case 136:if(a.callHandlerReturnAddresses.length>0&&a.callHandlerReturnAddresses.length<=3){const t=Va(e,Ca(n,1));a.local("pLocals"),a.appendU8(40),a.appendMemarg(t,0),a.local("index",33);for(let e=0;e=3&&b<=12||b>=509&&b<=510?p||a.options.countBailouts?(Ws(a,n,14),u=!0):n=0:b>=13&&b<=21?pi(a,n,b)?$=!0:n=0:b>=74&&b<=85?ui(a,n,b)||(n=0):b>=344&&b<=427?_i(a,n,b)||(n=0):wa[b]?mi(a,n,b)||(n=0):va[b]?yi(a,n,e,b)?p=!0:n=0:b>=23&&b<=49?di(a,e,n,b)||(n=0):b>=50&&b<=73?fi(a,e,n,b)||(n=0):b>=87&&b<=127?ki(a,n,b)||(n=0):b>=579&&b<=632?wi(a,n,b)||(n=0):b>=315&&b<=341?vi(a,e,n,b)||(n=0):b>=227&&b<=270?a.branchTargets.size>0?(Hs(a,n,j,8),u=!0):n=0:b>=652&&b<=659?(a.containsSimd=!0,Ti(a,n,b,T,v,U)?$=!0:n=0):b>=559&&b<=571?(a.containsAtomics=!0,Ai(a,n,b)||(n=0)):0===L||(n=0)}if(n){if(!$){const e=n+2;for(let t=0;t0&&(e+=" -> ");for(let n=0;n0&&(p?m++:_++,f+=L),(n+=2*k)<=s&&(h=n)}else i&&Ve(`instrumented trace ${t} aborted for opcode ${T} @${E.toString(16)}`),jc(a.traceIndex,0,0,b)}for(;a.activeBlocks>0;)a.endBlock();return a.cfg.exitIp=h,a.containsSimd&&(f+=10240),f}(e,d,n,r,u,p,y,c),s=i>=ic.minimumTraceValue,p.cfg.generate()})),p.emitImportsAndFunctions(!1),!s)return g&&"end-of-body"===g.abortReason&&(g.abortReason="trace-too-small"),0;_=zs();const f=p.getArrayView();if(da(6,f.length),f.length>=p.options.maxModuleSize)return We(`Jiterpreter generated too much code (${f.length} bytes) for trace ${d}. Please report this issue.`),0;const h=new WebAssembly.Module(f),w=p.getWasmImports(),k=new WebAssembly.Instance(h,w).exports[d];let S;m=!1,l?(qs().set(l,k),S=l):(S=Gs(0,k),0===S&&(cc=!0));const v=ua(1);return p.options.enableStats&&v&&v%500==0&&$c(!0),S}catch(e){h=!0,m=!1;let t=p.containsSimd?" (simd)":"";return p.containsAtomics&&(t+=" (atomics)"),He(`${i||d}${t} code generation failed: ${e} ${e.stack}`),Zs(),0}finally{const e=zs();if(_?(da(11,_-f),da(12,e-_)):da(11,e-f),h||!m&&ic.dumpTraces||b){if(h||ic.dumpTraces||b)for(let e=0;e0;)p.endBlock();p.inSection&&p.endSection()}catch(e){}const n=p.getArrayView(!1,!0);for(let r=0;r=4?Pi():Ni>0||"function"==typeof globalThis.setTimeout&&(Ni=globalThis.setTimeout((()=>{Ni=0,Pi()}),10))}},function(e,t,n,r,o,s,a,i){if(n>16)return 0;const c=new Fi(e,t,n,r,o,s,a,i);Bi||(Bi=qs());const l=Bi.get(i),p=(s?a?29:20:a?11:2)+n;return c.result=Gs(p,l),Oi[e]=c,c.result},function(e,t,n,r,s){const a=P(n+0),i=Xi[a];if(i)return void(i.result>0?o.mono_jiterp_register_jit_call_thunk(n,i.result):(i.queue.push(n),i.queue.length>12&&Ki()));const c=new Yi(e,t,n,r,0!==s);Xi[a]=c;const l=o.mono_jiterp_tlqueue_add(0,e);let p=Qi[e];p||(p=Qi[e]=[]),p.push(c),l>=6&&Ki()},function(e,t,n,r,s){const a=Zi(e);try{a(t,n,r,s)}catch(e){const t=Ke.wasmExports.__cpp_exception,n=t instanceof WebAssembly.Tag;if(n&&!(e instanceof WebAssembly.Exception&&e.is(t)))throw e;if(i=s,Ke.HEAPU32[i>>>2]=1,n){const n=e.getArg(t,0);o.mono_jiterp_begin_catch(n),o.mono_jiterp_end_catch()}else{if("number"!=typeof e)throw e;o.mono_jiterp_begin_catch(e),o.mono_jiterp_end_catch()}}var i},Ki,function(e,t,n){ct.emscriptenBuildOptions.enableDevToolsProfiler&&function(e){Mt.delete(e)}(e),delete hc[n],function(e){delete Oi[e]}(t),function(e){const t=Qi[e];if(t){for(let e=0;e",a=!!r,i=e?Le(e):"",c=o,l=t?Le(t):"",p=`[MONO] ${s}`;if(et.logging&&"function"==typeof et.logging.trace)et.logging.trace(i,l,p,a,c);else switch(l){case"critical":case"error":{const e=p+"\n"+(new Error).stack;lt.exitReason||(lt.exitReason=e),console.error(Qe(e))}break;case"warning":console.warn(p);break;case"message":default:console.log(p);break;case"info":console.info(p);break;case"debug":console.debug(p)}},function(e){wt=lt.config.mainAssemblyName+".dll",kt=e,console.assert(!0,`Adding an entrypoint breakpoint ${wt} at method token ${kt}`);debugger},function(e,t){if(!globalThis.crypto||!globalThis.crypto.getRandomValues)return-1;const n=K(),r=n.subarray(e,e+t),o=(n.buffer,!1),s=o?new Uint8Array(t):r;for(let e=0;e{e&&e.dispose()},u=!0)}const d=Bn(e,1),f=Nn(d),_=eo(d,f,1),m=26==f,h=20==f||30==f,g={fn:i,fqn:s+":"+o,args_count:c,arg_marshalers:l,res_converter:_,has_cleanup:u,arg_cleanup:p,is_discard_no_wait:m,is_async:h,isDisposed:!1};let b;b=h||m||u?ar(g):0!=c||_?1!=c||_?1==c&&_?function(e){const t=e.fn,r=e.arg_marshalers[0],o=e.res_converter,s=e.fqn;return e=null,function(a){const i=Ft();try{n&&e.isDisposed;const s=r(a),i=t(s);o(a,i)}catch(e){wo(a,e)}finally{Pt(i,"mono.callCsFunction:",s)}}}(g):2==c&&_?function(e){const t=e.fn,r=e.arg_marshalers[0],o=e.arg_marshalers[1],s=e.res_converter,a=e.fqn;return e=null,function(i){const c=Ft();try{n&&e.isDisposed;const a=r(i),c=o(i),l=t(a,c);s(i,l)}catch(e){wo(i,e)}finally{Pt(c,"mono.callCsFunction:",a)}}}(g):ar(g):function(e){const t=e.fn,r=e.arg_marshalers[0],o=e.fqn;return e=null,function(s){const a=Ft();try{n&&e.isDisposed;const o=r(s);t(o)}catch(e){wo(s,e)}finally{Pt(a,"mono.callCsFunction:",o)}}}(g):function(e){const t=e.fn,r=e.fqn;return e=null,function(o){const s=Ft();try{n&&e.isDisposed,t()}catch(e){wo(o,e)}finally{Pt(s,"mono.callCsFunction:",r)}}}(g);let y=b;y[xn]=g,sr[a]=y,Pt(t,"mono.bindJsFunction:",o)}(e),0}catch(e){return Ne(function(e){let t="unknown exception";if(e){t=e.toString();const n=e.stack;n&&(n.startsWith(t)?t=n:t+="\n"+n),t=Xe(t)}return t}(e))}},function(e,t){!function(e,t){lt.assert_runtime_running();const n=Fr(e);n&&"function"==typeof n&&n[En]||mt(!1,`Bound function handle expected ${e}`),n(t=oe(t,0))}(e,t)},function(e,t){lt.assert_runtime_running(),t=oe(t,0);const n=sr[e];n||mt(!1,`Imported function handle expected ${e}`),n(t)},function(e){gr((()=>function(e){if(!lt.is_runtime_running())return void(lt.diagnosticTracing&&ze("This promise resolution/rejection can't be propagated to managed code, mono runtime already exited."));const t=Ln(e=oe(e,0),0),r=n;try{lt.assert_runtime_running();const n=Ln(e,1),o=Ln(e,2),s=Ln(e,3),a=zn(o),i=Qn(o),c=Fr(i);c||mt(!1,`Cannot find Promise for JSHandle ${i}`),c.resolve_or_reject(a,i,s),r||(Wn(n,1),Wn(t,0))}catch(e){wo(t,e)}}(e)))},function(e){gr((()=>function(e){if(!lt.is_runtime_running())return void(lt.diagnosticTracing&&ze("This promise can't be canceled, mono runtime already exited."));const t=qr(e);t||mt(!1,`Expected Promise for GCHandle ${e}`),t.cancel()}(e)))},function(e,t,n,r,o,s,a){try{const i=Re(n,n+2*r),c=Pc(i);if(!c&&i)return Be(o,o+2*i.length,i),T(a,i.length),0;const l=Pc(Re(e,e+2*t));if(!c||!l)throw new Error(`Locale or culture name is null or empty. localeName=${c}, cultureName=${l}`);const p=c.split("-");let u,d;try{const e=p.length>1?p.pop():void 0;d=e?new Intl.DisplayNames([l],{type:"region"}).of(e):void 0;const t=p.join("-");u=new Intl.DisplayNames([l],{type:"language"}).of(t)}catch(e){if(!(e instanceof RangeError))throw e;try{u=new Intl.DisplayNames([l],{type:"language"}).of(c)}catch(e){if(e instanceof RangeError&&i)return Be(o,o+2*i.length,i),T(a,i.length),0;throw e}}const f={LanguageName:u,RegionName:d},_=Object.values(f).join("##");if(!_)throw new Error(`Locale info for locale=${c} is null or empty.`);if(_.length>s)throw new Error(`Locale info for locale=${c} exceeds length of ${s}.`);return Be(o,o+2*_.length,_),T(a,_.length),0}catch(e){return T(a,-1),Ne(e.toString())}},function(e){return pt.ds_rt_websocket_create(e)},function(e,t,n){return pt.ds_rt_websocket_send(e,t,n)},function(e){return pt.ds_rt_websocket_poll(e)},function(e,t,n){return pt.ds_rt_websocket_recv(e,t,n)},function(e){return pt.ds_rt_websocket_close(e)}];async function zc(e,t){try{const n=await Vc(e,t);return lt.mono_exit(n),n}catch(e){try{lt.mono_exit(1,e)}catch(e){}return e&&"number"==typeof e.status?e.status:1}}async function Vc(e,t){null!=e&&""!==e||(e=lt.config.mainAssemblyName)||mt(!1,"Null or empty config.mainAssemblyName"),null==t&&(t=ct.config.applicationArguments),null==t&&(t=tt?(await import(/*! webpackIgnore: true */"process")).argv.slice(2):[]),function(e,t){const n=t.length+1,r=_(4*n);let s=0;Ke.setValue(r+4*s,o.mono_wasm_strdup(e),"i32"),s+=1;for(let e=0;e{const t=setInterval((()=>{1==ct.waitForDebugger&&(clearInterval(t),e())}),100)})));try{return Ke.runtimeKeepalivePush(),await new Promise((e=>globalThis.setTimeout(e,0))),await function(e,t,n){lt.assert_runtime_running();const r=Ke.stackSave();try{const r=$n(5),o=Ln(r,1),s=Ln(r,2),a=Ln(r,3),i=Ln(r,4);uo(s,$e(e)),Uo(a,t&&!t.length?void 0:t,15),no(i,n);let c=sn(o,0,Jt);return wn(ct.managedThreadTID,yn.CallEntrypoint,r),c=an(r,Jt,c),null==c&&(c=Promise.resolve(0)),c[Dr]=!0,c}finally{lt.is_runtime_running()&&Ke.stackRestore(r)}}(e,t,1==ct.waitForDebugger)}finally{Ke.runtimeKeepalivePop()}}function Wc(e){ct.runtimeReady&&(ct.runtimeReady=!1,o.mono_wasm_exit(e))}function Hc(e){if(lt.exitReason=e,ct.runtimeReady){ct.runtimeReady=!1;const t=Qe(e);Ke.abort(t)}throw e}var qc,Gc;const Jc=2147483647&(null!==(Gc=null===(qc=globalThis.performance)||void 0===qc?void 0:qc.timeOrigin)&&void 0!==Gc?Gc:Date.now());function Xc(){return Jc}async function Qc(e){e.out||(e.out=console.log.bind(console)),e.err||(e.err=console.error.bind(console)),e.print||(e.print=e.out),e.printErr||(e.printErr=e.err),lt.out=e.print,lt.err=e.printErr,await async function(){var e;if(tt){if(globalThis.performance===Io){const{performance:e}=et.require("perf_hooks");globalThis.performance=e}if(et.process=await import(/*! webpackIgnore: true */"process"),globalThis.crypto||(globalThis.crypto={}),!globalThis.crypto.getRandomValues){let e;try{e=et.require("node:crypto")}catch(e){}e?e.webcrypto?globalThis.crypto=e.webcrypto:e.randomBytes&&(globalThis.crypto.getRandomValues=t=>{t&&t.set(e.randomBytes(t.length))}):globalThis.crypto.getRandomValues=()=>{throw new Error("Using node without crypto support. To enable current operation, either provide polyfill for 'globalThis.crypto.getRandomValues' or enable 'node:crypto' module.")}}}ct.subtle=null===(e=globalThis.crypto)||void 0===e?void 0:e.subtle}()}function Yc(e){const t=Ft();e.locateFile||(e.locateFile=e.__locateFile=e=>lt.scriptDirectory+e),e.mainScriptUrlOrBlob=lt.scriptUrl;const s=e.instantiateWasm,i=e.preInit?"function"==typeof e.preInit?[e.preInit]:e.preInit:[],l=e.preRun?"function"==typeof e.preRun?[e.preRun]:e.preRun:[],p=e.postRun?"function"==typeof e.postRun?[e.postRun]:e.postRun:[],u=e.onRuntimeInitialized?e.onRuntimeInitialized:()=>{};e.instantiateWasm=(e,t)=>function(e,t,n){const r=Ft();if(n){const o=n(e,((e,n)=>{Pt(r,"mono.instantiateWasm"),ct.afterInstantiateWasm.promise_control.resolve(),t(e,n)}));return o}return async function(e,t){try{await lt.afterConfigLoaded,lt.diagnosticTracing&&ze("instantiate_wasm_module"),await ct.beforePreInit.promise,Ke.addRunDependency("instantiate_wasm_module"),await async function(){const e=lt.simd(),t=lt.relaxedSimd(),n=lt.exceptions();ct.featureWasmSimd=await e,ct.featureWasmRelaxedSimd=await t,ct.featureWasmEh=await n,ct.emscriptenBuildOptions.wasmEnableSIMD&&(ct.featureWasmSimd||mt(!1,"This browser/engine doesn't support WASM SIMD. Please use a modern version. See also https://aka.ms/dotnet-wasm-features")),ct.emscriptenBuildOptions.wasmEnableEH&&(ct.featureWasmEh||mt(!1,"This browser/engine doesn't support WASM exception handling. Please use a modern version. See also https://aka.ms/dotnet-wasm-features"))}(),function(e){const t=e.env||e.a;if(!t)return void We("WARNING: Neither imports.env or imports.a were present when instantiating the wasm module. This likely indicates an emscripten configuration issue.");const n=new Array(Mc.length);for(const e in t){const r=t[e];if("function"==typeof r&&-1!==r.toString().indexOf("runtime_idx"))try{const{runtime_idx:t}=r();if(void 0!==n[t])throw new Error(`Duplicate runtime_idx ${t}`);n[t]=e}catch(e){}}for(const[e,r]of Mc.entries()){const o=n[e];if(void 0!==o){if("function"!=typeof t[o])throw new Error(`Expected ${o} to be a function`);t[o]=r}}}(e);const n=await lt.wasmCompilePromise.promise;t(await WebAssembly.instantiate(n,e),n),lt.diagnosticTracing&&ze("instantiate_wasm_module done"),ct.afterInstantiateWasm.promise_control.resolve()}catch(e){throw He("instantiate_wasm_module() failed",e),lt.mono_exit(1,e),e}Ke.removeRunDependency("instantiate_wasm_module")}(e,t),[]}(e,t,s),e.preInit=[()=>function(e){Ke.addRunDependency("mono_pre_init");const t=Ft();try{Ke.addRunDependency("mono_wasm_pre_init_essential"),lt.diagnosticTracing&&ze("mono_wasm_pre_init_essential"),lt.gitHash!==ct.gitHash&&We(`The version of dotnet.runtime.js ${ct.gitHash} is different from the version of dotnet.js ${lt.gitHash}!`),lt.gitHash!==ct.emscriptenBuildOptions.gitHash&&We(`The version of dotnet.native.js ${ct.emscriptenBuildOptions.gitHash} is different from the version of dotnet.js ${lt.gitHash}!`),n!==ct.emscriptenBuildOptions.wasmEnableThreads&&We(`The threads of dotnet.native.js ${ct.emscriptenBuildOptions.wasmEnableThreads} is different from the version of dotnet.runtime.js ${n}!`),function(){const e=[...r];for(const t of e){const e=o,[n,r,s,a,i]=t,l="function"==typeof n;if(!0===n||l)e[r]=function(...t){!l||!n()||mt(!1,`cwrap ${r} should not be called when binding was skipped`);const o=c(r,s,a,i);return e[r]=o,o(...t)};else{const t=c(r,s,a,i);e[r]=t}}}(),s=et,Object.assign(s,{mono_wasm_exit:o.mono_wasm_exit,mono_wasm_profiler_init_aot:a.mono_wasm_profiler_init_aot,mono_wasm_profiler_init_browser_devtools:a.mono_wasm_profiler_init_browser_devtools,mono_wasm_exec_regression:o.mono_wasm_exec_regression,mono_wasm_print_thread_dump:void 0}),Ke.removeRunDependency("mono_wasm_pre_init_essential"),lt.diagnosticTracing&&ze("preInit"),ct.beforePreInit.promise_control.resolve(),e.forEach((e=>e(Ke)))}catch(e){throw He("user preInint() failed",e),lt.mono_exit(1,e),e}var s;(async()=>{try{await async function(){lt.diagnosticTracing&&ze("mono_wasm_pre_init_essential_async"),Ke.addRunDependency("mono_wasm_pre_init_essential_async"),Ke.removeRunDependency("mono_wasm_pre_init_essential_async")}(),Pt(t,"mono.preInit")}catch(e){throw lt.mono_exit(1,e),e}ct.afterPreInit.promise_control.resolve(),Ke.removeRunDependency("mono_pre_init")})()}(i)],e.preRun=[()=>async function(e){Ke.addRunDependency("mono_pre_run_async");try{await ct.afterInstantiateWasm.promise,await ct.afterPreInit.promise,lt.diagnosticTracing&&ze("preRunAsync");const t=Ft();e.map((e=>e(Ke))),Pt(t,"mono.preRun")}catch(e){throw He("preRunAsync() failed",e),lt.mono_exit(1,e),e}ct.afterPreRun.promise_control.resolve(),Ke.removeRunDependency("mono_pre_run_async")}(l)],e.onRuntimeInitialized=()=>async function(e){try{await ct.afterPreRun.promise,lt.diagnosticTracing&&ze("onRuntimeInitialized"),ct.nativeExit=Wc,ct.nativeAbort=Hc;const t=Ft();if(ct.beforeOnRuntimeInitialized.promise_control.resolve(),await ct.coreAssetsInMemory.promise,ct.config.virtualWorkingDirectory){const e=Ke.FS,t=ct.config.virtualWorkingDirectory;try{const n=e.stat(t);n?n&&e.isDir(n.mode)||mt(!1,`FS.chdir: ${t} is not a directory`):Ke.FS_createPath("/",t,!0,!0)}catch(e){Ke.FS_createPath("/",t,!0,!0)}e.chdir(t)}ct.config.interpreterPgo&&setTimeout(Kc,1e3*(ct.config.interpreterPgoSaveDelay||15)),Ke.runtimeKeepalivePush(),n||await async function(){try{const t=Ft(),n=ct.config.environmentVariables||{};lt.diagnosticTracing&&ze("Initializing mono runtime");for(const e in n){const t=n[e];if("string"!=typeof t)throw new Error(`Expected environment variable '${e}' to be a string but it was ${typeof t}: '${t}'`);Zc(e,t)}if(ct.config.runtimeOptions&&function(e){if(!Array.isArray(e))throw new Error("Expected runtimeOptions to be an array of strings");const t=_(4*e.length);let n=0;for(let r=0;raot; in your project file."),null==e&&(e={}),"writeAt"in e||(e.writeAt="System.Runtime.InteropServices.JavaScript.JavaScriptExports::StopProfile"),"sendTo"in e||(e.sendTo="Interop/Runtime::DumpAotProfileData");const t="aot:write-at-method="+e.writeAt+",send-to-method="+e.sendTo;a.mono_wasm_profiler_init_aot(t)}(ct.config.aotProfilerOptions||{}):ct.emscriptenBuildOptions.enableDevToolsProfiler?function(){ct.emscriptenBuildOptions.enableDevToolsProfiler||mt(!1,"DevTools profiler is not enabled, please use browser:callspec=N:Sample in your project file."),Dt=globalThis.performance&&"function"==typeof globalThis.performance.measure;const e=`${ct.config.environmentVariables.DOTNET_WasmPerformanceInstrumentation||"callspec=all"}`;a.mono_wasm_profiler_init_browser_devtools(e)}():ct.emscriptenBuildOptions.enableLogProfiler&&(e=ct.config.logProfilerOptions||{},ct.emscriptenBuildOptions.enableLogProfiler||mt(!1,"Log profiler is not enabled, please use log; in your project file."),e.takeHeapshot||mt(!1,"Log profiler is not enabled, the takeHeapshot method must be defined in LogProfilerOptions.takeHeapshot"),e.configuration||(e.configuration="log:alloc,output=output.mlpd"),e.takeHeapshot?a.mono_wasm_profiler_init_log(`${e.configuration},take-heapshot-method=${e.takeHeapshot}`):a.mono_wasm_profiler_init_log(e.configuration));!function(){var e,t,n,r;lt.diagnosticTracing&&ze("mono_wasm_load_runtime");try{const s=Ft();let a=ct.config.debugLevel;null==a&&(a=0,ct.config.debugLevel&&(a=0+a)),lt.isDebuggingSupported()&&(ct.config.resources.corePdb||ct.config.resources.pdb)||(a=0);const i=new Map;if(null===(t=null===(e=ct.config.runtimeConfig)||void 0===e?void 0:e.runtimeOptions)||void 0===t?void 0:t.configProperties)for(const[e,t]of Object.entries(null===(r=null===(n=ct.config.runtimeConfig)||void 0===n?void 0:n.runtimeOptions)||void 0===r?void 0:r.configProperties))i.set(e,""+t);i.set("APP_CONTEXT_BASE_DIRECTORY","/"),i.set("RUNTIME_IDENTIFIER","browser-wasm");const c=i.size,l=[],p=_(4*i.size),u=_(4*i.size);l.push(p),l.push(u);let d=0;for(const[e,t]of i.entries()){const n=$e(e),r=$e(t);S(p+4*d,n),S(u+4*d,r),d++,l.push(n),l.push(r)}o.mono_wasm_load_runtime(a,c,p,u);for(const e of l)Ke._free(e);Pt(s,"mono.loadRuntime")}catch(e){throw He("mono_wasm_load_runtime () failed",e),lt.mono_exit(1,e),e}}(),function(){if(ma)return;ma=!0;const e=fa(),t=e.tableSize,n=ct.emscriptenBuildOptions.runAOTCompilation?e.tableSize:1,r=ct.emscriptenBuildOptions.runAOTCompilation?e.aotTableSize:1,s=t+n+36*r+1,a=qs();let i=a.length;const c=performance.now();a.grow(s);const l=performance.now();e.enableStats&&Ve(`Allocated ${s} function table entries for jiterpreter, bringing total table size to ${a.length}`),i=_a(0,i,t,ta("mono_jiterp_placeholder_trace")),i=_a(1,i,n,ta("mono_jiterp_placeholder_jit_call"));for(let e=2;e<=37;e++)i=_a(e,i,r,a.get(o.mono_jiterp_get_interp_entry_func(e)));const p=performance.now();e.enableStats&&Ve(`Growing wasm function table took ${l-c}. Filling table took ${p-l}.`)}(),function(){if(!ct.mono_wasm_bindings_is_ready){lt.diagnosticTracing&&ze("bindings_init"),ct.mono_wasm_bindings_is_ready=!0;try{const e=Ft();we||("undefined"!=typeof TextDecoder&&(Se=new TextDecoder("utf-16le"),ve=new TextDecoder("utf-8",{fatal:!1}),Ue=new TextDecoder("utf-8"),Te=new TextEncoder),we=_(12)),Ee||(Ee=function(e){let t;if(de.length>0)t=de.pop();else{const e=function(){if(null==le||!pe){le=_e(ce,"js roots"),pe=new Int32Array(ce),ue=ce;for(let e=0;elt.loadedFiles.push(e.url))),lt.diagnosticTracing&&ze("all assets are loaded in wasm memory"))}(),tl.registerRuntime(it),ct.mono_wasm_runtime_is_ready||function mono_wasm_runtime_ready(){if(et.mono_wasm_runtime_is_ready=ct.mono_wasm_runtime_is_ready=!0,vt=0,St={},Ut=-1,globalThis.dotnetDebugger)debugger}();try{e(Ke)}catch(e){throw He("user callback onRuntimeInitialized() failed",e),e}await async function(){lt.diagnosticTracing&&ze("mono_wasm_after_user_runtime_initialized");try{if(Ke.onDotnetReady)try{await Ke.onDotnetReady()}catch(e){throw He("onDotnetReady () failed",e),e}}catch(e){throw He("mono_wasm_after_user_runtime_initialized () failed",e),e}}(),Pt(t,"mono.onRuntimeInitialized")}catch(e){throw Ke.runtimeKeepalivePop(),He("onRuntimeInitializedAsync() failed",e),lt.mono_exit(1,e),e}ct.afterOnRuntimeInitialized.promise_control.resolve()}(u),e.postRun=[()=>async function(e){try{await ct.afterOnRuntimeInitialized.promise,lt.diagnosticTracing&&ze("postRunAsync");const t=Ft();Ke.FS_createPath("/","usr",!0,!0),Ke.FS_createPath("/","usr/share",!0,!0),e.map((e=>e(Ke))),Pt(t,"mono.postRun")}catch(e){throw He("postRunAsync() failed",e),lt.mono_exit(1,e),e}ct.afterPostRun.promise_control.resolve()}(p)],e.ready.then((async()=>{await ct.afterPostRun.promise,Pt(t,"mono.emscriptenStartup"),ct.dotnetReady.promise_control.resolve(it)})).catch((e=>{ct.dotnetReady.promise_control.reject(e)})),e.ready=ct.dotnetReady.promise}function Zc(e,t){o.mono_wasm_setenv(e,t)}async function Kc(){void 0!==lt.exitCode&&0!==lt.exitCode||await Rc()}async function el(e){}let tl;function nl(r){const o=Ke,a=r,i=globalThis;Object.assign(a.internal,{mono_wasm_exit:e=>{Ke.err("early exit "+e)},forceDisposeProxies:Jr,mono_wasm_dump_threads:void 0,logging:void 0,mono_wasm_stringify_as_error_with_stack:Qe,mono_wasm_get_loaded_files:As,mono_wasm_send_dbg_command_with_parms:Et,mono_wasm_send_dbg_command:xt,mono_wasm_get_dbg_command_info:It,mono_wasm_get_details:Nt,mono_wasm_release_object:Ct,mono_wasm_call_function_on:Bt,mono_wasm_debugger_resume:At,mono_wasm_detach_debugger:jt,mono_wasm_raise_debug_event:Lt,mono_wasm_change_debugger_log_level:$t,mono_wasm_debugger_attached:Rt,mono_wasm_runtime_is_ready:ct.mono_wasm_runtime_is_ready,mono_wasm_get_func_id_to_name_mappings:Ze,get_property:lr,set_property:cr,has_property:pr,get_typeof_property:ur,get_global_this:dr,get_dotnet_instance:()=>it,dynamic_import:mr,mono_wasm_bind_cs_function:wr,ws_wasm_create:bs,ws_wasm_open:ys,ws_wasm_send:ws,ws_wasm_receive:ks,ws_wasm_close:Ss,ws_wasm_abort:vs,ws_get_state:gs,http_wasm_supports_streaming_request:$o,http_wasm_supports_streaming_response:Lo,http_wasm_create_controller:Ro,http_wasm_get_response_type:Mo,http_wasm_get_response_status:zo,http_wasm_abort:No,http_wasm_transform_stream_write:Oo,http_wasm_transform_stream_close:Co,http_wasm_fetch:Po,http_wasm_fetch_stream:Do,http_wasm_fetch_bytes:Fo,http_wasm_get_response_header_names:Vo,http_wasm_get_response_header_values:Wo,http_wasm_get_response_bytes:qo,http_wasm_get_response_length:Ho,http_wasm_get_streamed_response_bytes:Go,jiterpreter_dump_stats:$c,jiterpreter_apply_options:pa,jiterpreter_get_options:fa,interp_pgo_load_data:Bc,interp_pgo_save_data:Rc,mono_wasm_gc_lock:ae,mono_wasm_gc_unlock:ie,monoObjectAsBoolOrNullUnsafe:Fc,monoStringToStringUnsafe:Pe,loadLazyAssembly:Cc,loadSatelliteAssemblies:Dc});const c={stringify_as_error_with_stack:Qe,instantiate_symbols_asset:Is,instantiate_asset:xs,jiterpreter_dump_stats:$c,forceDisposeProxies:Jr,utf8ToString:Le,mono_wasm_process_current_pid:Xc,mono_background_exec:()=>s.mono_background_exec(),mono_wasm_ds_exec:()=>s.mono_wasm_ds_exec()};Object.assign(ct,c);const l={runMain:Vc,runMainAndExit:zc,exit:lt.mono_exit,setEnvironmentVariable:Zc,getAssemblyExports:vr,setModuleImports:ir,getConfig:()=>ct.config,invokeLibraryInitializers:lt.invokeLibraryInitializers,setHeapB32:b,setHeapB8:y,setHeapU8:w,setHeapU16:k,setHeapU32:S,setHeapI8:v,setHeapI16:U,setHeapI32:T,setHeapI52:x,setHeapU52:I,setHeapI64Big:A,setHeapF32:j,setHeapF64:$,getHeapB32:R,getHeapB8:B,getHeapU8:N,getHeapU16:O,getHeapU32:C,getHeapI8:M,getHeapI16:z,getHeapI32:V,getHeapI52:W,getHeapU52:H,getHeapI64Big:q,getHeapF32:G,getHeapF64:J,localHeapViewU8:K,localHeapViewU16:ee,localHeapViewU32:te,localHeapViewI8:X,localHeapViewI16:Q,localHeapViewI32:Y,localHeapViewI64Big:Z,localHeapViewF32:ne,localHeapViewF64:re,collectCpuSamples:null,collectMetrics:null,collectGcDump:null,connectDSRouter:null};return Object.assign(it,{INTERNAL:a.internal,Module:o,runtimeBuildInfo:{productVersion:e,gitHash:ct.gitHash,buildConfiguration:t,wasmEnableThreads:n,wasmEnableSIMD:!0,wasmEnableExceptionHandling:!0},...l}),i.getDotnetRuntime?tl=i.getDotnetRuntime.__list:(i.getDotnetRuntime=e=>i.getDotnetRuntime.__list.getRuntime(e),i.getDotnetRuntime.__list=tl=new rl),it}class rl{constructor(){this.list={}}registerRuntime(e){return void 0===e.runtimeId&&(e.runtimeId=Object.keys(this.list).length),this.list[e.runtimeId]=yr(e),lt.config.runtimeId=e.runtimeId,e.runtimeId}getRuntime(e){const t=this.list[e];return t?t.deref():void 0}}export{Yc as configureEmscriptenStartup,Qc as configureRuntimeStartup,el as configureWorkerStartup,nl as initializeExports,Ao as initializeReplacements,dt as passEmscriptenInternals,tl as runtimeList,ft as setRuntimeGlobals}; +//# sourceMappingURL=dotnet.runtime.js.map diff --git a/public/engines/dotnet/engine-metadata.json b/public/engines/dotnet/engine-metadata.json new file mode 100644 index 0000000..8e90807 --- /dev/null +++ b/public/engines/dotnet/engine-metadata.json @@ -0,0 +1,166 @@ +{ + "schemaVersion": 1, + "engine": "dotnet", + "engineName": "System.Text.RegularExpressions", + "engineVersion": ".NET 10.0.10 System.Text.RegularExpressions", + "semanticIdentity": ".NET 10.0.10 System.Text.RegularExpressions; invariant culture; UTF-16 offsets", + "status": "production-native-runtime", + "bridge": { + "abiVersion": 1, + "nativeOffsetUnit": "UTF-16 code units", + "requestEncoding": "bounded JSON passed to fixed JSExport methods", + "userSourceEvaluation": false, + "replacement": "Fixed streaming parser for .NET replacement tokens ($$, $n, ${name}, $&, $`, $', $+, $_), verified against Match.Result at load", + "replacementOutputTransport": "bounded UTF-8 bytes encoded as canonical base64 in the JSON response", + "supportedApplicationFlags": [ + "g", + "i", + "m", + "s", + "n", + "x", + "r", + "c", + "b" + ], + "matchTimeoutMilliseconds": 9000, + "limits": { + "maximumPatternUtf16": 65536, + "maximumSubjectUtf16": 16777216, + "maximumReplacementUtf16": 65536, + "maximumMatches": 10000, + "maximumCaptureRows": 100000, + "maximumCaptureGroups": 1000, + "maximumOutputBytes": 67108864 + }, + "sourceFiles": [ + { + "path": "engines/dotnet/Program.cs", + "sha256": "52c7bdf7b95f985e22fe2eff8cf5b0173537c701bb8712c012b558ee5a35f530", + "bytes": 28310 + }, + { + "path": "engines/dotnet/README.md", + "sha256": "080fa57b00d7c593fc630a8353f5467393879441630790280beb8a39edb81a47", + "bytes": 1359 + }, + { + "path": "engines/dotnet/RegexTools.DotNet.csproj", + "sha256": "95eefcd69634c79a1a27afbfd68dae28af81803116dc8a9f29d73246fdbf8d5e", + "bytes": 813 + }, + { + "path": "engines/dotnet/wwwroot/main.js", + "sha256": "1288cf008091453e23640cc7cca21c3bb811cac41be58c98e75b417828f7ff39", + "bytes": 150 + } + ] + }, + "source": { + "project": ".NET", + "repository": "https://github.com/dotnet/runtime", + "license": "MIT", + "runtimeVersion": "10.0.10", + "runtimeCommit": "f7d90799ce" + }, + "toolchain": { + "sdkVersion": "10.0.302", + "sdkCommit": "35b593bebf", + "workload": "wasm-tools", + "target": "browser-wasm", + "command": "dotnet publish engines/dotnet/RegexTools.DotNet.csproj -c Release --no-restore -p:PathMap==/regex-tools-source -p:EmccExtraCFlags=-ffile-prefix-map==/dotnet-sdk-10.0.302" + }, + "sourceDateEpoch": 1785110400, + "files": [ + { + "path": "LICENSE-dotnet.txt", + "sha256": "cfc21f5e8bd655ae997eec916138b707b1d290b83272c02a95c9f821b8c87310", + "bytes": 1116 + }, + { + "path": "THIRD-PARTY-NOTICES.txt", + "sha256": "2dc8f8c5a39401e928b5784ab564eb8b3ceb99ead3df8f260e0cab7e0bbecc7a", + "bytes": 77436 + }, + { + "path": "_framework/RegexTools.DotNet.nq07srqsrv.wasm", + "sha256": "8178d080bf8b139da2417184ad607664f0abb8bf5f7bc3acfdd19dac1c01be57", + "bytes": 25877 + }, + { + "path": "_framework/System.Collections.035l5xddsu.wasm", + "sha256": "fc65ef6182d0633e5da7fb634f3c6bbc9cda00c04fb9318023a0d75c91fd0be6", + "bytes": 7445 + }, + { + "path": "_framework/System.IO.Pipelines.9846faqurl.wasm", + "sha256": "e95181d82588827027195b7be3ba2a4df8b1580b0a1a98cf3e4275378f673984", + "bytes": 8469 + }, + { + "path": "_framework/System.Linq.0mnik33gd9.wasm", + "sha256": "08f8ff79ef495e642c1f000b7d9e2d8d651675f67cf3c3b974acc85bfba38ecc", + "bytes": 23317 + }, + { + "path": "_framework/System.Memory.1p33wui4du.wasm", + "sha256": "8b52fd95bdaafddde9c041faaf908153ff3763712ebb8c274897df1e97bd8840", + "bytes": 15125 + }, + { + "path": "_framework/System.Private.CoreLib.kprynbd0oq.wasm", + "sha256": "c813dfea69a9161b6e721c663b960193597fe148f48acbae57315cae7988681d", + "bytes": 1089813 + }, + { + "path": "_framework/System.Runtime.8ovzk6bt8k.wasm", + "sha256": "18e7c4e1816cab053848fa468beedc191c5d57b7f8050e82e2d74541c9c05467", + "bytes": 6933 + }, + { + "path": "_framework/System.Runtime.InteropServices.JavaScript.sx1hj7vtls.wasm", + "sha256": "f03ceddaccb17a82e8e27e2ae71f7bcea8155c527f50569f94b52199ea11d451", + "bytes": 40213 + }, + { + "path": "_framework/System.Security.Cryptography.nx98zbj2m5.wasm", + "sha256": "4ba3b0e95e97a3897fc5dd4823dfb91de0497166f389cbfd1e1bdc9df548a8b3", + "bytes": 6933 + }, + { + "path": "_framework/System.Text.Encodings.Web.efde74c33p.wasm", + "sha256": "864de168a4ce82a9aa8deea10bf30f76d0de302a382b20f2fea69f324ff0eadb", + "bytes": 26389 + }, + { + "path": "_framework/System.Text.Json.yzatygskj6.wasm", + "sha256": "12c10b1368766432adc311b48a7970f67bc2cffc76f92336224a1f846673e146", + "bytes": 83733 + }, + { + "path": "_framework/System.Text.RegularExpressions.imqsl0y08u.wasm", + "sha256": "caca9e11dc0df1917a8b14f213bf6c2c404faeddb43ab10551f1807d07c7fc43", + "bytes": 243989 + }, + { + "path": "_framework/dotnet.js", + "sha256": "647cf2841162fa23115ff9b0c55a4e370ab432912da48dd844a3d16e38c09a1a", + "bytes": 43459 + }, + { + "path": "_framework/dotnet.native.224bc09dfc8b.js", + "sha256": "224bc09dfc8b875fff993976d256f751b4f72ccd758e4a9144eab8c9d9f98ed1", + "bytes": 215271 + }, + { + "path": "_framework/dotnet.native.6k8j5v15h5.wasm", + "sha256": "1603c30cea37bbfc154d37528b99ffd5fcf7ca833d07112bc239d7cee598bff7", + "bytes": 1484398 + }, + { + "path": "_framework/dotnet.runtime.web2r9gqbh.js", + "sha256": "48e507110dc58430226c1491daef74356669a018cfb964661f40400135258495", + "bytes": 198480 + } + ] +} diff --git a/public/engines/go/LICENSE-Go.txt b/public/engines/go/LICENSE-Go.txt new file mode 100644 index 0000000..2a7cf70 --- /dev/null +++ b/public/engines/go/LICENSE-Go.txt @@ -0,0 +1,27 @@ +Copyright 2009 The Go Authors. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following disclaimer +in the documentation and/or other materials provided with the +distribution. + * Neither the name of Google LLC nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/public/engines/go/SHA256SUMS b/public/engines/go/SHA256SUMS new file mode 100644 index 0000000..6321927 --- /dev/null +++ b/public/engines/go/SHA256SUMS @@ -0,0 +1,4 @@ +911f8f5782931320f5b8d1160a76365b83aea6447ee6c04fa6d5591467db9dad LICENSE-Go.txt +208034ac6bb2a1867fa082c51edd5e77098f16ff55e7907f9c9a51b59e6390ff engine-metadata.json +ddafd6401e0674c048ee066677157db0b03480f716262845ea30639daffb3ae5 go-regex.wasm +0c949f4996f9a89698e4b5c586de32249c3b69b7baadb64d220073cc04acba14 wasm_exec.mjs diff --git a/public/engines/go/engine-metadata.json b/public/engines/go/engine-metadata.json new file mode 100644 index 0000000..6abed6f --- /dev/null +++ b/public/engines/go/engine-metadata.json @@ -0,0 +1,82 @@ +{ + "schemaVersion": 1, + "engine": "go", + "engineName": "Go standard-library regexp", + "engineVersion": "1.26.5", + "semanticIdentity": "Go 1.26.5 standard-library regexp (RE2 syntax), official js/wasm runtime", + "status": "production-native-runtime", + "bridge": { + "abiVersion": 1, + "offsetUnit": "utf8-byte", + "requestEncoding": "Exact UTF-8-bounded JSON values with worst-case escape allowance; fixed callbacks; base64 UTF-8 replacement output; no source evaluation", + "supportedApplicationFlags": [ + "g", + "i", + "m", + "s", + "U" + ], + "replacement": "Bounded streaming expansion with regexp.ExpandString grammar, parity-checked against the native API.", + "limits": { + "maximumPatternBytes": 262144, + "maximumSubjectBytes": 16777216, + "maximumReplacementBytes": 262144, + "maximumMatches": 10000, + "maximumCaptureRows": 100000, + "maximumCaptureGroups": 1000, + "maximumOutputBytes": 67108864, + "maximumRequestJSONBytes": 103874560 + }, + "sourceFiles": [ + { + "path": "engines/go/README.md", + "sha256": "c23792b39383ab1f68880354b829d926e3bd08b1f6afa19a595f0d228a4a5059", + "bytes": 1453 + }, + { + "path": "engines/go/go.mod", + "sha256": "b2744a26c11ce6be55fabd2109b89f34b0db413abab8b40c9f7e8ea83e8b7bff", + "bytes": 85 + }, + { + "path": "engines/go/main.go", + "sha256": "e9411ffedc844ed1a3af3642cac52efbedfd64407ad2cb99e9ccdddf039b6578", + "bytes": 15179 + } + ] + }, + "source": { + "repository": "https://go.googlesource.com/go", + "tag": "go1.26.5", + "commitSha1": "c19862e5f8415b4f24b189d065ed739517c548ba", + "treeSha1": "0bb2fb1cc06c334c36a2a92d2f0b07fea7236d74", + "license": "BSD-3-Clause" + }, + "toolchain": { + "version": "go1.26.5", + "host": "linux/amd64", + "target": "js/wasm", + "archive": "https://go.dev/dl/go1.26.5.linux-amd64.tar.gz", + "archiveSha256": "5c2c3b16caefa1d968a94c1daca04a7ca301a496d9b086e17ad77bb81393f053", + "wasmExecSha256": "0c949f4996f9a89698e4b5c586de32249c3b69b7baadb64d220073cc04acba14", + "build": "CGO_ENABLED=0 GOOS=js GOARCH=wasm go build -trimpath -buildvcs=false -ldflags=-s,-w,-buildid=" + }, + "sourceDateEpoch": 1783452544, + "files": [ + { + "path": "LICENSE-Go.txt", + "sha256": "911f8f5782931320f5b8d1160a76365b83aea6447ee6c04fa6d5591467db9dad", + "bytes": 1453 + }, + { + "path": "go-regex.wasm", + "sha256": "ddafd6401e0674c048ee066677157db0b03480f716262845ea30639daffb3ae5", + "bytes": 3904895 + }, + { + "path": "wasm_exec.mjs", + "sha256": "0c949f4996f9a89698e4b5c586de32249c3b69b7baadb64d220073cc04acba14", + "bytes": 16992 + } + ] +} diff --git a/public/engines/go/go-regex.wasm b/public/engines/go/go-regex.wasm new file mode 100644 index 0000000..58d3fd4 Binary files /dev/null and b/public/engines/go/go-regex.wasm differ diff --git a/public/engines/go/wasm_exec.mjs b/public/engines/go/wasm_exec.mjs new file mode 100644 index 0000000..d71af9e --- /dev/null +++ b/public/engines/go/wasm_exec.mjs @@ -0,0 +1,575 @@ +// Copyright 2018 The Go Authors. All rights reserved. +// Use of this source code is governed by a BSD-style +// license that can be found in the LICENSE file. + +"use strict"; + +(() => { + const enosys = () => { + const err = new Error("not implemented"); + err.code = "ENOSYS"; + return err; + }; + + if (!globalThis.fs) { + let outputBuf = ""; + globalThis.fs = { + constants: { O_WRONLY: -1, O_RDWR: -1, O_CREAT: -1, O_TRUNC: -1, O_APPEND: -1, O_EXCL: -1, O_DIRECTORY: -1 }, // unused + writeSync(fd, buf) { + outputBuf += decoder.decode(buf); + const nl = outputBuf.lastIndexOf("\n"); + if (nl != -1) { + console.log(outputBuf.substring(0, nl)); + outputBuf = outputBuf.substring(nl + 1); + } + return buf.length; + }, + write(fd, buf, offset, length, position, callback) { + if (offset !== 0 || length !== buf.length || position !== null) { + callback(enosys()); + return; + } + const n = this.writeSync(fd, buf); + callback(null, n); + }, + chmod(path, mode, callback) { callback(enosys()); }, + chown(path, uid, gid, callback) { callback(enosys()); }, + close(fd, callback) { callback(enosys()); }, + fchmod(fd, mode, callback) { callback(enosys()); }, + fchown(fd, uid, gid, callback) { callback(enosys()); }, + fstat(fd, callback) { callback(enosys()); }, + fsync(fd, callback) { callback(null); }, + ftruncate(fd, length, callback) { callback(enosys()); }, + lchown(path, uid, gid, callback) { callback(enosys()); }, + link(path, link, callback) { callback(enosys()); }, + lstat(path, callback) { callback(enosys()); }, + mkdir(path, perm, callback) { callback(enosys()); }, + open(path, flags, mode, callback) { callback(enosys()); }, + read(fd, buffer, offset, length, position, callback) { callback(enosys()); }, + readdir(path, callback) { callback(enosys()); }, + readlink(path, callback) { callback(enosys()); }, + rename(from, to, callback) { callback(enosys()); }, + rmdir(path, callback) { callback(enosys()); }, + stat(path, callback) { callback(enosys()); }, + symlink(path, link, callback) { callback(enosys()); }, + truncate(path, length, callback) { callback(enosys()); }, + unlink(path, callback) { callback(enosys()); }, + utimes(path, atime, mtime, callback) { callback(enosys()); }, + }; + } + + if (!globalThis.process) { + globalThis.process = { + getuid() { return -1; }, + getgid() { return -1; }, + geteuid() { return -1; }, + getegid() { return -1; }, + getgroups() { throw enosys(); }, + pid: -1, + ppid: -1, + umask() { throw enosys(); }, + cwd() { throw enosys(); }, + chdir() { throw enosys(); }, + } + } + + if (!globalThis.path) { + globalThis.path = { + resolve(...pathSegments) { + return pathSegments.join("/"); + } + } + } + + if (!globalThis.crypto) { + throw new Error("globalThis.crypto is not available, polyfill required (crypto.getRandomValues only)"); + } + + if (!globalThis.performance) { + throw new Error("globalThis.performance is not available, polyfill required (performance.now only)"); + } + + if (!globalThis.TextEncoder) { + throw new Error("globalThis.TextEncoder is not available, polyfill required"); + } + + if (!globalThis.TextDecoder) { + throw new Error("globalThis.TextDecoder is not available, polyfill required"); + } + + const encoder = new TextEncoder("utf-8"); + const decoder = new TextDecoder("utf-8"); + + globalThis.Go = class { + constructor() { + this.argv = ["js"]; + this.env = {}; + this.exit = (code) => { + if (code !== 0) { + console.warn("exit code:", code); + } + }; + this._exitPromise = new Promise((resolve) => { + this._resolveExitPromise = resolve; + }); + this._pendingEvent = null; + this._scheduledTimeouts = new Map(); + this._nextCallbackTimeoutID = 1; + + const setInt64 = (addr, v) => { + this.mem.setUint32(addr + 0, v, true); + this.mem.setUint32(addr + 4, Math.floor(v / 4294967296), true); + } + + const setInt32 = (addr, v) => { + this.mem.setUint32(addr + 0, v, true); + } + + const getInt64 = (addr) => { + const low = this.mem.getUint32(addr + 0, true); + const high = this.mem.getInt32(addr + 4, true); + return low + high * 4294967296; + } + + const loadValue = (addr) => { + const f = this.mem.getFloat64(addr, true); + if (f === 0) { + return undefined; + } + if (!isNaN(f)) { + return f; + } + + const id = this.mem.getUint32(addr, true); + return this._values[id]; + } + + const storeValue = (addr, v) => { + const nanHead = 0x7FF80000; + + if (typeof v === "number" && v !== 0) { + if (isNaN(v)) { + this.mem.setUint32(addr + 4, nanHead, true); + this.mem.setUint32(addr, 0, true); + return; + } + this.mem.setFloat64(addr, v, true); + return; + } + + if (v === undefined) { + this.mem.setFloat64(addr, 0, true); + return; + } + + let id = this._ids.get(v); + if (id === undefined) { + id = this._idPool.pop(); + if (id === undefined) { + id = this._values.length; + } + this._values[id] = v; + this._goRefCounts[id] = 0; + this._ids.set(v, id); + } + this._goRefCounts[id]++; + let typeFlag = 0; + switch (typeof v) { + case "object": + if (v !== null) { + typeFlag = 1; + } + break; + case "string": + typeFlag = 2; + break; + case "symbol": + typeFlag = 3; + break; + case "function": + typeFlag = 4; + break; + } + this.mem.setUint32(addr + 4, nanHead | typeFlag, true); + this.mem.setUint32(addr, id, true); + } + + const loadSlice = (addr) => { + const array = getInt64(addr + 0); + const len = getInt64(addr + 8); + return new Uint8Array(this._inst.exports.mem.buffer, array, len); + } + + const loadSliceOfValues = (addr) => { + const array = getInt64(addr + 0); + const len = getInt64(addr + 8); + const a = new Array(len); + for (let i = 0; i < len; i++) { + a[i] = loadValue(array + i * 8); + } + return a; + } + + const loadString = (addr) => { + const saddr = getInt64(addr + 0); + const len = getInt64(addr + 8); + return decoder.decode(new DataView(this._inst.exports.mem.buffer, saddr, len)); + } + + const testCallExport = (a, b) => { + this._inst.exports.testExport0(); + return this._inst.exports.testExport(a, b); + } + + const timeOrigin = Date.now() - performance.now(); + this.importObject = { + _gotest: { + add: (a, b) => a + b, + callExport: testCallExport, + }, + gojs: { + // Go's SP does not change as long as no Go code is running. Some operations (e.g. calls, getters and setters) + // may synchronously trigger a Go event handler. This makes Go code get executed in the middle of the imported + // function. A goroutine can switch to a new stack if the current stack is too small (see morestack function). + // This changes the SP, thus we have to update the SP used by the imported function. + + // func wasmExit(code int32) + "runtime.wasmExit": (sp) => { + sp >>>= 0; + const code = this.mem.getInt32(sp + 8, true); + this.exited = true; + delete this._inst; + delete this._values; + delete this._goRefCounts; + delete this._ids; + delete this._idPool; + this.exit(code); + }, + + // func wasmWrite(fd uintptr, p unsafe.Pointer, n int32) + "runtime.wasmWrite": (sp) => { + sp >>>= 0; + const fd = getInt64(sp + 8); + const p = getInt64(sp + 16); + const n = this.mem.getInt32(sp + 24, true); + fs.writeSync(fd, new Uint8Array(this._inst.exports.mem.buffer, p, n)); + }, + + // func resetMemoryDataView() + "runtime.resetMemoryDataView": (sp) => { + sp >>>= 0; + this.mem = new DataView(this._inst.exports.mem.buffer); + }, + + // func nanotime1() int64 + "runtime.nanotime1": (sp) => { + sp >>>= 0; + setInt64(sp + 8, (timeOrigin + performance.now()) * 1000000); + }, + + // func walltime() (sec int64, nsec int32) + "runtime.walltime": (sp) => { + sp >>>= 0; + const msec = (new Date).getTime(); + setInt64(sp + 8, msec / 1000); + this.mem.setInt32(sp + 16, (msec % 1000) * 1000000, true); + }, + + // func scheduleTimeoutEvent(delay int64) int32 + "runtime.scheduleTimeoutEvent": (sp) => { + sp >>>= 0; + const id = this._nextCallbackTimeoutID; + this._nextCallbackTimeoutID++; + this._scheduledTimeouts.set(id, setTimeout( + () => { + this._resume(); + while (this._scheduledTimeouts.has(id)) { + // for some reason Go failed to register the timeout event, log and try again + // (temporary workaround for https://github.com/golang/go/issues/28975) + console.warn("scheduleTimeoutEvent: missed timeout event"); + this._resume(); + } + }, + getInt64(sp + 8), + )); + this.mem.setInt32(sp + 16, id, true); + }, + + // func clearTimeoutEvent(id int32) + "runtime.clearTimeoutEvent": (sp) => { + sp >>>= 0; + const id = this.mem.getInt32(sp + 8, true); + clearTimeout(this._scheduledTimeouts.get(id)); + this._scheduledTimeouts.delete(id); + }, + + // func getRandomData(r []byte) + "runtime.getRandomData": (sp) => { + sp >>>= 0; + crypto.getRandomValues(loadSlice(sp + 8)); + }, + + // func finalizeRef(v ref) + "syscall/js.finalizeRef": (sp) => { + sp >>>= 0; + const id = this.mem.getUint32(sp + 8, true); + this._goRefCounts[id]--; + if (this._goRefCounts[id] === 0) { + const v = this._values[id]; + this._values[id] = null; + this._ids.delete(v); + this._idPool.push(id); + } + }, + + // func stringVal(value string) ref + "syscall/js.stringVal": (sp) => { + sp >>>= 0; + storeValue(sp + 24, loadString(sp + 8)); + }, + + // func valueGet(v ref, p string) ref + "syscall/js.valueGet": (sp) => { + sp >>>= 0; + const result = Reflect.get(loadValue(sp + 8), loadString(sp + 16)); + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 32, result); + }, + + // func valueSet(v ref, p string, x ref) + "syscall/js.valueSet": (sp) => { + sp >>>= 0; + Reflect.set(loadValue(sp + 8), loadString(sp + 16), loadValue(sp + 32)); + }, + + // func valueDelete(v ref, p string) + "syscall/js.valueDelete": (sp) => { + sp >>>= 0; + Reflect.deleteProperty(loadValue(sp + 8), loadString(sp + 16)); + }, + + // func valueIndex(v ref, i int) ref + "syscall/js.valueIndex": (sp) => { + sp >>>= 0; + storeValue(sp + 24, Reflect.get(loadValue(sp + 8), getInt64(sp + 16))); + }, + + // valueSetIndex(v ref, i int, x ref) + "syscall/js.valueSetIndex": (sp) => { + sp >>>= 0; + Reflect.set(loadValue(sp + 8), getInt64(sp + 16), loadValue(sp + 24)); + }, + + // func valueCall(v ref, m string, args []ref) (ref, bool) + "syscall/js.valueCall": (sp) => { + sp >>>= 0; + try { + const v = loadValue(sp + 8); + const m = Reflect.get(v, loadString(sp + 16)); + const args = loadSliceOfValues(sp + 32); + const result = Reflect.apply(m, v, args); + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 56, result); + this.mem.setUint8(sp + 64, 1); + } catch (err) { + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 56, err); + this.mem.setUint8(sp + 64, 0); + } + }, + + // func valueInvoke(v ref, args []ref) (ref, bool) + "syscall/js.valueInvoke": (sp) => { + sp >>>= 0; + try { + const v = loadValue(sp + 8); + const args = loadSliceOfValues(sp + 16); + const result = Reflect.apply(v, undefined, args); + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 40, result); + this.mem.setUint8(sp + 48, 1); + } catch (err) { + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 40, err); + this.mem.setUint8(sp + 48, 0); + } + }, + + // func valueNew(v ref, args []ref) (ref, bool) + "syscall/js.valueNew": (sp) => { + sp >>>= 0; + try { + const v = loadValue(sp + 8); + const args = loadSliceOfValues(sp + 16); + const result = Reflect.construct(v, args); + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 40, result); + this.mem.setUint8(sp + 48, 1); + } catch (err) { + sp = this._inst.exports.getsp() >>> 0; // see comment above + storeValue(sp + 40, err); + this.mem.setUint8(sp + 48, 0); + } + }, + + // func valueLength(v ref) int + "syscall/js.valueLength": (sp) => { + sp >>>= 0; + setInt64(sp + 16, parseInt(loadValue(sp + 8).length)); + }, + + // valuePrepareString(v ref) (ref, int) + "syscall/js.valuePrepareString": (sp) => { + sp >>>= 0; + const str = encoder.encode(String(loadValue(sp + 8))); + storeValue(sp + 16, str); + setInt64(sp + 24, str.length); + }, + + // valueLoadString(v ref, b []byte) + "syscall/js.valueLoadString": (sp) => { + sp >>>= 0; + const str = loadValue(sp + 8); + loadSlice(sp + 16).set(str); + }, + + // func valueInstanceOf(v ref, t ref) bool + "syscall/js.valueInstanceOf": (sp) => { + sp >>>= 0; + this.mem.setUint8(sp + 24, (loadValue(sp + 8) instanceof loadValue(sp + 16)) ? 1 : 0); + }, + + // func copyBytesToGo(dst []byte, src ref) (int, bool) + "syscall/js.copyBytesToGo": (sp) => { + sp >>>= 0; + const dst = loadSlice(sp + 8); + const src = loadValue(sp + 32); + if (!(src instanceof Uint8Array || src instanceof Uint8ClampedArray)) { + this.mem.setUint8(sp + 48, 0); + return; + } + const toCopy = src.subarray(0, dst.length); + dst.set(toCopy); + setInt64(sp + 40, toCopy.length); + this.mem.setUint8(sp + 48, 1); + }, + + // func copyBytesToJS(dst ref, src []byte) (int, bool) + "syscall/js.copyBytesToJS": (sp) => { + sp >>>= 0; + const dst = loadValue(sp + 8); + const src = loadSlice(sp + 16); + if (!(dst instanceof Uint8Array || dst instanceof Uint8ClampedArray)) { + this.mem.setUint8(sp + 48, 0); + return; + } + const toCopy = src.subarray(0, dst.length); + dst.set(toCopy); + setInt64(sp + 40, toCopy.length); + this.mem.setUint8(sp + 48, 1); + }, + + "debug": (value) => { + console.log(value); + }, + } + }; + } + + async run(instance) { + if (!(instance instanceof WebAssembly.Instance)) { + throw new Error("Go.run: WebAssembly.Instance expected"); + } + this._inst = instance; + this.mem = new DataView(this._inst.exports.mem.buffer); + this._values = [ // JS values that Go currently has references to, indexed by reference id + NaN, + 0, + null, + true, + false, + globalThis, + this, + ]; + this._goRefCounts = new Array(this._values.length).fill(Infinity); // number of references that Go has to a JS value, indexed by reference id + this._ids = new Map([ // mapping from JS values to reference ids + [0, 1], + [null, 2], + [true, 3], + [false, 4], + [globalThis, 5], + [this, 6], + ]); + this._idPool = []; // unused ids that have been garbage collected + this.exited = false; // whether the Go program has exited + + // Pass command line arguments and environment variables to WebAssembly by writing them to the linear memory. + let offset = 4096; + + const strPtr = (str) => { + const ptr = offset; + const bytes = encoder.encode(str + "\0"); + new Uint8Array(this.mem.buffer, offset, bytes.length).set(bytes); + offset += bytes.length; + if (offset % 8 !== 0) { + offset += 8 - (offset % 8); + } + return ptr; + }; + + const argc = this.argv.length; + + const argvPtrs = []; + this.argv.forEach((arg) => { + argvPtrs.push(strPtr(arg)); + }); + argvPtrs.push(0); + + const keys = Object.keys(this.env).sort(); + keys.forEach((key) => { + argvPtrs.push(strPtr(`${key}=${this.env[key]}`)); + }); + argvPtrs.push(0); + + const argv = offset; + argvPtrs.forEach((ptr) => { + this.mem.setUint32(offset, ptr, true); + this.mem.setUint32(offset + 4, 0, true); + offset += 8; + }); + + // The linker guarantees global data starts from at least wasmMinDataAddr. + // Keep in sync with cmd/link/internal/ld/data.go:wasmMinDataAddr. + const wasmMinDataAddr = 4096 + 8192; + if (offset >= wasmMinDataAddr) { + throw new Error("total length of command line and environment variables exceeds limit"); + } + + this._inst.exports.run(argc, argv); + if (this.exited) { + this._resolveExitPromise(); + } + await this._exitPromise; + } + + _resume() { + if (this.exited) { + throw new Error("Go program has already exited"); + } + this._inst.exports.resume(); + if (this.exited) { + this._resolveExitPromise(); + } + } + + _makeFuncWrapper(id) { + const go = this; + return function () { + const event = { id: id, this: this, args: arguments }; + go._pendingEvent = event; + go._resume(); + return event.result; + }; + } + } +})(); diff --git a/public/engines/java/SHA256SUMS b/public/engines/java/SHA256SUMS index 4078123..3d62747 100644 --- a/public/engines/java/SHA256SUMS +++ b/public/engines/java/SHA256SUMS @@ -1,4 +1,4 @@ cfc7749b96f63bd31c3c42b5c471bf756814053e847c10f3eb003417bc523d30 LICENSE.txt 71bbe79ff78d0e5e64096acdd418589abfe886b8f827048dc655df438a57e477 NOTICE.txt -719cb99761c8f0964835bf7b954fcf6e0df30ec14d2c06050c07c23a978d6d22 engine-metadata.json +86caa45d9b23eb64b4a0e06709b72e47c7f6307639c0866c0db9f8562d814184 engine-metadata.json fd7974e7bde911ef0682cdc432d28e93c5db9d56f7268482a62e40a2ad86d62f java-regex.mjs diff --git a/public/engines/java/engine-metadata.json b/public/engines/java/engine-metadata.json index d5b34c1..7b55481 100644 --- a/public/engines/java/engine-metadata.json +++ b/public/engines/java/engine-metadata.json @@ -57,7 +57,9 @@ "treeSha1": "1cdc5c332d5809828c8952f96d73f9e7504a0cec", "license": "Apache-2.0", "upstreamLicenseSha256": "cfc7749b96f63bd31c3c42b5c471bf756814053e847c10f3eb003417bc523d30", - "upstreamNoticeSha256": "6c2b3372a6beee7fbaad482248ac0f5ad2b099d92ff2a528c04261cc9c0636f4" + "upstreamNoticeSha256": "6c2b3372a6beee7fbaad482248ac0f5ad2b099d92ff2a528c04261cc9c0636f4", + "packagedNoticeSha256": "71bbe79ff78d0e5e64096acdd418589abfe886b8f827048dc655df438a57e477", + "noticeNormalization": "The packaged notice removes one redundant blank line and adds a final LF; its attribution text is unchanged." }, "toolchain": { "mavenVersion": "3.9.15", diff --git a/public/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt b/public/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt new file mode 100644 index 0000000..55cfbd6 --- /dev/null +++ b/public/engines/perl/LICENSE-Devel-StackTrace-Artistic-2.0.txt @@ -0,0 +1,207 @@ +This software is Copyright (c) 2000 - 2017 by David Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + + The Artistic License 2.0 + + Copyright (c) 2000-2006, The Perl Foundation. + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +Preamble + +This license establishes the terms under which a given free software +Package may be copied, modified, distributed, and/or redistributed. +The intent is that the Copyright Holder maintains some artistic +control over the development of that Package while still keeping the +Package available as open source and free software. + +You are always permitted to make arrangements wholly outside of this +license directly with the Copyright Holder of a given Package. If the +terms of this license do not permit the full use that you propose to +make of the Package, you should contact the Copyright Holder and seek +a different licensing arrangement. + +Definitions + + "Copyright Holder" means the individual(s) or organization(s) + named in the copyright notice for the entire Package. + + "Contributor" means any party that has contributed code or other + material to the Package, in accordance with the Copyright Holder's + procedures. + + "You" and "your" means any person who would like to copy, + distribute, or modify the Package. + + "Package" means the collection of files distributed by the + Copyright Holder, and derivatives of that collection and/or of + those files. A given Package may consist of either the Standard + Version, or a Modified Version. + + "Distribute" means providing a copy of the Package or making it + accessible to anyone else, or in the case of a company or + organization, to others outside of your company or organization. + + "Distributor Fee" means any fee that you charge for Distributing + this Package or providing support for this Package to another + party. It does not mean licensing fees. + + "Standard Version" refers to the Package if it has not been + modified, or has been modified only in ways explicitly requested + by the Copyright Holder. + + "Modified Version" means the Package, if it has been changed, and + such changes were not explicitly requested by the Copyright + Holder. + + "Original License" means this Artistic License as Distributed with + the Standard Version of the Package, in its current version or as + it may be modified by The Perl Foundation in the future. + + "Source" form means the source code, documentation source, and + configuration files for the Package. + + "Compiled" form means the compiled bytecode, object code, binary, + or any other form resulting from mechanical transformation or + translation of the Source form. + + +Permission for Use and Modification Without Distribution + +(1) You are permitted to use the Standard Version and create and use +Modified Versions for any purpose without restriction, provided that +you do not Distribute the Modified Version. + + +Permissions for Redistribution of the Standard Version + +(2) You may Distribute verbatim copies of the Source form of the +Standard Version of this Package in any medium without restriction, +either gratis or for a Distributor Fee, provided that you duplicate +all of the original copyright notices and associated disclaimers. At +your discretion, such verbatim copies may or may not include a +Compiled form of the Package. + +(3) You may apply any bug fixes, portability changes, and other +modifications made available from the Copyright Holder. The resulting +Package will still be considered the Standard Version, and as such +will be subject to the Original License. + + +Distribution of Modified Versions of the Package as Source + +(4) You may Distribute your Modified Version as Source (either gratis +or for a Distributor Fee, and with or without a Compiled form of the +Modified Version) provided that you clearly document how it differs +from the Standard Version, including, but not limited to, documenting +any non-standard features, executables, or modules, and provided that +you do at least ONE of the following: + + (a) make the Modified Version available to the Copyright Holder + of the Standard Version, under the Original License, so that the + Copyright Holder may include your modifications in the Standard + Version. + + (b) ensure that installation of your Modified Version does not + prevent the user installing or running the Standard Version. In + addition, the Modified Version must bear a name that is different + from the name of the Standard Version. + + (c) allow anyone who receives a copy of the Modified Version to + make the Source form of the Modified Version available to others + under + + (i) the Original License or + + (ii) a license that permits the licensee to freely copy, + modify and redistribute the Modified Version using the same + licensing terms that apply to the copy that the licensee + received, and requires that the Source form of the Modified + Version, and of any works derived from it, be made freely + available in that license fees are prohibited but Distributor + Fees are allowed. + + +Distribution of Compiled Forms of the Standard Version +or Modified Versions without the Source + +(5) You may Distribute Compiled forms of the Standard Version without +the Source, provided that you include complete instructions on how to +get the Source of the Standard Version. Such instructions must be +valid at the time of your distribution. If these instructions, at any +time while you are carrying out such distribution, become invalid, you +must provide new instructions on demand or cease further distribution. +If you provide valid instructions or cease distribution within thirty +days after you become aware that the instructions are invalid, then +you do not forfeit any of your rights under this license. + +(6) You may Distribute a Modified Version in Compiled form without +the Source, provided that you comply with Section 4 with respect to +the Source of the Modified Version. + + +Aggregating or Linking the Package + +(7) You may aggregate the Package (either the Standard Version or +Modified Version) with other packages and Distribute the resulting +aggregation provided that you do not charge a licensing fee for the +Package. Distributor Fees are permitted, and licensing fees for other +components in the aggregation are permitted. The terms of this license +apply to the use and Distribution of the Standard or Modified Versions +as included in the aggregation. + +(8) You are permitted to link Modified and Standard Versions with +other works, to embed the Package in a larger work of your own, or to +build stand-alone binary or bytecode versions of applications that +include the Package, and Distribute the result without restriction, +provided the result does not expose a direct interface to the Package. + + +Items That are Not Considered Part of a Modified Version + +(9) Works (including, but not limited to, modules and scripts) that +merely extend or make use of the Package, do not, by themselves, cause +the Package to be a Modified Version. In addition, such works are not +considered parts of the Package itself, and are not subject to the +terms of this license. + + +General Provisions + +(10) Any use, modification, and distribution of the Standard or +Modified Versions is governed by this Artistic License. By using, +modifying or distributing the Package, you accept this license. Do not +use, modify, or distribute the Package, if you do not accept this +license. + +(11) If your Modified Version has been derived from a Modified +Version made by someone other than you, you are nevertheless required +to ensure that your Modified Version complies with the requirements of +this license. + +(12) This license does not grant you the right to use any trademark, +service mark, tradename, or logo of the Copyright Holder. + +(13) This license includes the non-exclusive, worldwide, +free-of-charge patent license to make, have made, use, offer to sell, +sell, import and otherwise transfer the Package with respect to any +patent claims licensable by the Copyright Holder that are necessarily +infringed by the Package. If you institute patent litigation +(including a cross-claim or counterclaim) against any party alleging +that the Package constitutes direct or contributory patent +infringement, then this Artistic License to you shall terminate on the +date that such litigation is filed. + +(14) Disclaimer of Warranty: +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/public/engines/perl/LICENSE-Emscripten.txt b/public/engines/perl/LICENSE-Emscripten.txt new file mode 100644 index 0000000..a1fe6bf --- /dev/null +++ b/public/engines/perl/LICENSE-Emscripten.txt @@ -0,0 +1,101 @@ +Emscripten is available under 2 licenses, the MIT license and the +University of Illinois/NCSA Open Source License. + +Both are permissive open source licenses, with little if any +practical difference between them. + +The reason for offering both is that (1) the MIT license is +well-known, while (2) the University of Illinois/NCSA Open Source +License allows Emscripten's code to be integrated upstream into +LLVM, which uses that license, should the opportunity arise. + +The full text of both licenses follows. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. + +============================================================================== + +Copyright (c) 2010-2014 Emscripten authors, see AUTHORS file. +All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the +"Software"), to deal with the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimers. + + Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following disclaimers + in the documentation and/or other materials provided with the + distribution. + + Neither the names of Mozilla, + nor the names of its contributors may be used to endorse + or promote products derived from this Software without specific prior + written permission. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT HOLDERS BE LIABLE FOR +ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE SOFTWARE. + +============================================================================== + +This program uses portions of Node.js source code located in src/library_path.js, +in accordance with the terms of the MIT license. Node's license follows: + + """ + Copyright Joyent, Inc. and other Node contributors. All rights reserved. + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to + deal in the Software without restriction, including without limitation the + rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + sell copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + IN THE SOFTWARE. + """ + +The musl libc project is bundled in this repo, and it has the MIT license, see +system/lib/libc/musl/COPYRIGHT + +The third_party/ subdirectory contains code with other licenses. None of it is +used by default, but certain options use it (e.g., the optional closure compiler +flag will run closure compiler from third_party/). diff --git a/public/engines/perl/LICENSE-WebPerl-Artistic.txt b/public/engines/perl/LICENSE-WebPerl-Artistic.txt new file mode 100644 index 0000000..a37cee6 --- /dev/null +++ b/public/engines/perl/LICENSE-WebPerl-Artistic.txt @@ -0,0 +1,158 @@ +NAME + perlartistic - the Perl Artistic License + +SYNOPSIS + You can refer to this document in Pod via "L" + Or you can see this document by entering "perldoc perlartistic" + +DESCRIPTION + Perl is free software; you can redistribute it and/or modify it under + the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + This is "The Artistic License". It's here so that modules, programs, + etc., that want to declare this as their distribution license can link + to it. + + For the GNU General Public License, see perlgpl. + +The "Artistic License" + Preamble + The intent of this document is to state the conditions under which a + Package may be copied, such that the Copyright Holder maintains some + semblance of artistic control over the development of the package, while + giving the users of the package the right to use and distribute the + Package in a more-or-less customary fashion, plus the right to make + reasonable modifications. + + Definitions + "Package" + refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + + "Standard Version" + refers to such a Package if it has not been modified, or has been + modified in accordance with the wishes of the Copyright Holder as + specified below. + + "Copyright Holder" + is whoever is named in the copyright or copyrights for the package. + + "You" + is you, if you're thinking about copying or distributing this + Package. + + "Reasonable copying fee" + is whatever you can justify on the basis of media cost, duplication + charges, time of people involved, and so on. (You will not be + required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + + "Freely Available" + means that no fee is charged for the item itself, though there may + be fees involved in handling the item. It also means that recipients + of the item may redistribute it under the same conditions they + received it. + + Conditions + 1. You may make and give away verbatim copies of the source form of the + Standard Version of this Package without restriction, provided that + you duplicate all of the original copyright notices and associated + disclaimers. + + 2. You may apply bug fixes, portability fixes and other modifications + derived from the Public Domain or from the Copyright Holder. A + Package modified in such a way shall still be considered the + Standard Version. + + 3. You may otherwise modify your copy of this Package in any way, + provided that you insert a prominent notice in each changed file + stating how and when you changed that file, and provided that you do + at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make + them Freely Available, such as by posting said modifications to + Usenet or an equivalent medium, or placing the modifications on + a major archive site such as uunet.uu.net, or by allowing the + Copyright Holder to include your modifications in the Standard + Version of the Package. + + b) use the modified Package only within your corporation or + organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and + provide a separate manual page for each non-standard executable + that clearly documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + 4. You may distribute the programs of this Package in object code or + executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library + files, together with instructions (in the manual page or + equivalent) on where to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), + together with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + + 5. You may charge a reasonable copying fee for any distribution of this + Package. You may charge any fee you choose for support of this + Package. You may not charge a fee for this Package itself. However, + you may distribute this Package in aggregate with other (possibly + commercial) programs as part of a larger (possibly commercial) + software distribution provided that you do not advertise this + Package as a product of your own. You may embed this Package's + interpreter within an executable of yours (by linking); this shall + be construed as a mere form of aggregation, provided that the + complete Standard Version of the interpreter is so embedded. + + 6. The scripts and library files supplied as input to or produced as + output from the programs of this Package do not automatically fall + under the copyright of this Package, but belong to whoever generated + them, and may be sold commercially, and may be aggregated with this + Package. If such scripts or library files are aggregated with this + Package via the so-called "undump" or "unexec" methods of producing + a binary executable image, then distribution of such an image shall + neither be construed as a distribution of this Package nor shall it + fall under the restrictions of Paragraphs 3 and 4, provided that you + do not represent such an executable image as a Standard Version of + this Package. + + 7. C subroutines (or comparably compiled subroutines in other + languages) supplied by you and linked into this Package in order to + emulate subroutines and variables of the language defined by this + Package shall not be considered part of this Package, but are the + equivalent of input as in Paragraph 6, provided these subroutines do + not change the language in any way that would cause it to fail the + regression tests for the language. + + 8. Aggregation of this Package with a commercial distribution is always + permitted provided that the use of this Package is embedded; that + is, when no overt attempt is made to make this Package's interfaces + visible to the end user of the commercial distribution. Such use + shall not be construed as a distribution of this Package. + + 9. The name of the Copyright Holder may not be used to endorse or + promote products derived from this software without specific prior + written permission. + + 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED + WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF + MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End + diff --git a/public/engines/perl/LICENSE-WebPerl-GPL.txt b/public/engines/perl/LICENSE-WebPerl-GPL.txt new file mode 100644 index 0000000..d29d956 --- /dev/null +++ b/public/engines/perl/LICENSE-WebPerl-GPL.txt @@ -0,0 +1,281 @@ +NAME + perlgpl - the GNU General Public License, version 1 + +SYNOPSIS + You can refer to this document in Pod via "L" + Or you can see this document by entering "perldoc perlgpl" + +DESCRIPTION + Perl is free software; you can redistribute it and/or modify it under + the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or + + b) the "Artistic License" which comes with this Kit. + + This is the "GNU General Public License, version 1". It's here so that + modules, programs, etc., that want to declare this as their distribution + license can link to it. + + For the Perl Artistic License, see perlartistic. + +GNU GENERAL PUBLIC LICENSE + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users + at the mercy of those companies. By contrast, our General Public + License is intended to guarantee your freedom to share and change free + software--to make sure the software is free for all its users. The + General Public License applies to the Free Software Foundation's + software and to any other program whose authors commit to using it. + You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not + price. Specifically, the General Public License is designed to make + sure that you have the freedom to give away or sell copies of free + software, that you receive source code or can get it if you want it, + that you can change the software or use pieces of it in new free + programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid + anyone to deny you these rights or to ask you to surrender the rights. + These restrictions translate to certain responsibilities for you if you + distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether + gratis or for a fee, you must give the recipients all the rights that + you have. You must make sure that they, too, receive or can get the + source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, + and (2) offer you this license which gives you legal permission to + copy, distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain + that everyone understands that there is no warranty for this free + software. If the software is modified by someone else and passed on, + we want its recipients to know that what they have is not the original, + so that any problems introduced by others will not reflect on the + original authors' reputations. + + The precise terms and conditions for copying, distribution and + modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which + contains a notice placed by the copyright holder saying it may be + distributed under the terms of this General Public License. The + "Program", below, refers to any such program or work, and a "work based + on the Program" means either the Program or any work containing the + Program or a portion of it, either verbatim or with modifications. + Each licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's + source code as you receive it, in any medium, provided that you + conspicuously and appropriately publish on each copy an appropriate + copyright notice and disclaimer of warranty; keep intact all the + notices that refer to this General Public License and to the absence of + any warranty; and give any other recipients of the Program a copy of + this General Public License along with the Program. You may charge a + fee for the physical act of transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion + of it, and copy and distribute such modifications under the terms of + Paragraph 1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, + either with or without modifications, to be licensed at no charge + to all third parties under the terms of this General Public License + (except that you may choose to grant warranty protection to some or + all third parties, at your option). + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the simplest and most usual way, to print or + display an announcement including an appropriate copyright notice + and a notice that there is no warranty (or else, saying that you + provide a warranty) and that users may redistribute the program + under these conditions, and telling the user how to view a copy of + this General Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + + Mere aggregation of another independent work with the Program (or its + derivative) on a volume of a storage or distribution medium does not + bring the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or + derivative of it, under Paragraph 2) in object code or executable form + under the terms of Paragraphs 1 and 2 above provided that you also do + one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of + the corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + + Source code for a work means the preferred form of the work for making + modifications to it. For an executable file, complete source code + means all the source code for all modules it contains; but, as a + special exception, it need not include source code for modules which + are standard libraries that accompany the operating system on which the + executable file runs, or for standard header files or definitions files + that accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the + Program except as expressly provided under this General Public License. + Any attempt otherwise to copy, modify, sublicense, distribute or + transfer the Program is void, and will automatically terminate your + rights to use the Program under this License. However, parties who + have received copies, or rights to use copies, from you under this + General Public License will not have their licenses terminated so long + as such parties remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work + based on the Program) you indicate your acceptance of this license to + do so, and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the + Program), the recipient automatically receives a license from the + original licensor to copy, distribute or modify the Program subject to + these terms and conditions. You may not impose any further + restrictions on the recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new + versions of the General Public License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the Program + specifies a version number of the license which applies to it and "any + later version", you have the option of following the terms and + conditions either of that version or of any later version published by + the Free Software Foundation. If the Program does not specify a + version number of the license, you may choose any version ever + published by the Free Software Foundation. + + 8. If you wish to incorporate parts of the Program into other free + programs whose distribution conditions are different, write to the + author to ask for permission. For software which is copyrighted by the + Free Software Foundation, write to the Free Software Foundation; we + sometimes make exceptions for this. Our decision will be guided by the + two goals of preserving the free status of all derivatives of our free + software and of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO + WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. + EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR + OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, + EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS + WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF + ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN + WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY + AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU + FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR + CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE + PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING + RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A + FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF + SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH + DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest + possible use to humanity, the best way to achieve this is to make it + free software which everyone can redistribute and change under these + terms. + + To do so, attach the following notices to the program. It is safest + to attach them to the start of each source file to most effectively + convey the exclusion of warranty; and each file should have at least + the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 1, or (at + your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA + 02110-1301 USA + + + Also add information on how to contact you by electronic and paper + mail. + + If the program is interactive, make it output a short notice like this + when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type + 'show w'. This is free software, and you are welcome to + redistribute it under certain conditions; type 'show c' for + details. + + The hypothetical commands 'show w' and 'show c' should show the + appropriate parts of the General Public License. Of course, the + commands you use may be called something other than 'show w' and 'show + c'; they could even be mouse-clicks or menu items--whatever suits your + program. + + You should also get your employer (if you work as a programmer) or your + school, if any, to sign a "copyright disclaimer" for the program, if + necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program 'Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + + That's all there is to it! + diff --git a/public/engines/perl/NOTICE.txt b/public/engines/perl/NOTICE.txt new file mode 100644 index 0000000..084dae3 --- /dev/null +++ b/public/engines/perl/NOTICE.txt @@ -0,0 +1,68 @@ +Legacy WebPerl runtime notices +============================== + +This directory contains the unmodified WebPerl v0.09-beta prebuilt runtime, +released in 2019 and explicitly treated by regex-tools as legacy beta software. + +WebPerl +------- + +Project: https://github.com/haukex/webperl +Release: v0.09-beta +Commit: 6f2173d29a2c2e3536e1de75ff5d291ae96ab348 +Copyright (c) 2018 Hauke Daempfling, Leibniz Institute of Freshwater Ecology +and Inland Fisheries (IGB), Berlin, Germany. + +WebPerl is distributed under the same terms as Perl 5: either the GNU General +Public License version 1 or later, or the Artistic License supplied with Perl 5. +The complete upstream texts are included as LICENSE-WebPerl-GPL.txt and +LICENSE-WebPerl-Artistic.txt. + +Perl +---- + +The binary and data pack contain Perl v5.28.1 and its core library. Perl 5 is +distributed under the same GNU GPL / Artistic dual-license terms described +above. Exact upstream source is available from: + +https://github.com/Perl/perl5/tree/v5.28.1 + +Emscripten +---------- + +The generated loader and WebAssembly runtime were built by upstream WebPerl +with Emscripten 1.38.28. Emscripten is dual-licensed under the MIT and +University of Illinois/NCSA licenses. The upstream 1.38.28 license text, +including its bundled-code notices, is included as LICENSE-Emscripten.txt. + +Bundled CPAN additions +---------------------- + +The upstream prebuilt data pack also contains the modules selected by +WebPerl's pinned build: + +- Cpanel::JSON::XS 4.09 — same terms as Perl 5; +- Devel::StackTrace 2.03 — Artistic License 2.0; its upstream distribution + license is included as LICENSE-Devel-StackTrace-Artistic-2.0.txt; and +- Future 0.39 — same terms as Perl 5. + +The Devel::StackTrace license was reproduced byte-for-byte from +https://www.cpan.org/authors/id/D/DR/DROLSKY/Devel-StackTrace-2.03.tar.gz +(SHA-256 7618cd4ebe24e254c17085f4b418784ab503cb4cb3baf8f48a7be894e59ba848). + +regex-tools uses Cpanel::JSON::XS only as the fixed bridge's bounded JSON +codec. It does not load Devel::StackTrace, Future, or WebPerl's JavaScript +interop module on the normal engine path. Those files remain present because +emperl.data is the unmodified, checksummed upstream prebuilt pack. + +Security boundary +----------------- + +The upstream generated emperl.js has one JavaScript eval(code) call in the +optional WebPerl JavaScript-interoperability import. regex-tools neither loads +nor calls that Perl module. User values cross the fixed bridge only as +exact-key, byte-bounded JSON in MEMFS; the sole Perl evaluator invocation is +the constant RegexTools::run_request(). The bounded metadata response is JSON, +while successful replacement UTF-8 bytes use a separate fixed MEMFS binary +file with exact worker-side length and encoding verification. Perl's +runtime-regex eval mode and regex code assertions are disabled. diff --git a/public/engines/perl/SHA256SUMS b/public/engines/perl/SHA256SUMS new file mode 100644 index 0000000..c022506 --- /dev/null +++ b/public/engines/perl/SHA256SUMS @@ -0,0 +1,11 @@ +e16dd93533bb65e25fad00d06e88840d9b5fd6bb80d551d8866126c52d89e1de LICENSE-Devel-StackTrace-Artistic-2.0.txt +51aea7641f81d560eb039bc97ce35e2517e2656fe8731eb49ce6a18498eb22fe LICENSE-Emscripten.txt +435a788b2de9aaae9c640e7c0ab7b317b41323522e8641bcda000607892abf1f LICENSE-WebPerl-Artistic.txt +0166b8b8e96a6b153da26ece157ebbd9ffad5423670f611fae80fefacb6da7f5 LICENSE-WebPerl-GPL.txt +499559af54694d319697271433262a3324a976061f4537ed1c5210235f9eb348 NOTICE.txt +9529019418cf766a42cf2d25bd3fc97b47c9e689f5666cfc32dc11338d1b1e66 emperl.data +b60e3c04874c6ef5278001257b4c8a9f4c7e69ca3d6b268d9639723234844784 emperl.js +f1d49c4514c7332a57992c4a2444fd6a56ae3b5e6651b4fd484852a641e5e4ec emperl.wasm +c2967eeec6b3eadcd0be3df064797a5d8ce790e43542e9417092af196128dfa7 engine-metadata.json +0c42a7b2a72b886d967aadff0b1bb35017c247e5cad79ad85544fc3a91f17e5b perl-runtime.worker.js +880835d63b2319f72ae4be1db50e2cecda8ebd98b80dca810448c3a665dcc4d3 regex_tools_bridge.pl diff --git a/public/engines/perl/emperl.data b/public/engines/perl/emperl.data new file mode 100644 index 0000000..8db44a4 --- /dev/null +++ b/public/engines/perl/emperl.data @@ -0,0 +1,567811 @@ +use warnings; +use 5.028; +use Test::More; + +=head1 SYNOPSIS + +Tests for F, to be run in the browser. + +=head1 Author, Copyright, and License + +B<< WebPerl - L >> + +Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net) +at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB), +Berlin, Germany, L + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl 5 itself: either the GNU General Public +License as published by the Free Software Foundation (either version 1, +or, at your option, any later version), or the "Artistic License" which +comes with Perl 5. + +This program is distributed in the hope that it will be useful, but +B; without even the implied warranty of +B. +See the licenses for details. + +You should have received a copy of the licenses along with this program. +If not, see L. + +=cut + +# A couple of debugging aides: +#$WebPerl::TRACE = 1; +#js('Perl.trace = true'); +#$Carp::Verbose = 1; # or: +#use Devel::StackTrace (); +#$SIG{__DIE__} = sub { die join '', shift, map {"\t".$_->as_string."\n"} +# Devel::StackTrace->new(skip_frames=>2)->frames }; + +BEGIN { use_ok('WebPerl', qw/ js encode_json sub1 /) } + +subtest 'basic js() tests' => sub { + is js(undef), undef, 'undef'; + is js(q{ undefined }), undef, 'undefined'; + is js(q{ true }), !0, 'true'; + is js(q{ false }), !1, 'false'; + is js(q{ 5 }), 5, 'number 1'; + is js(q{ 3.14159 }), 3.14159, 'number 2'; + is js(q{ 3.14159e6 }), 3.14159e6, 'number 3'; + is js(q{ 3.14159e60 }), 3.14159e60, 'number 4'; + is js(q{ "" }), "", 'string 1'; + is js(q{ "foo" }), "foo", 'string 2'; + is js(qq{"\0\\0\N{U+E4}\\u00E4"}), "\0\0\N{U+E4}\N{U+E4}", 'nuls and unicode'; #" +}; + +subtest 'basic function tests' => sub { + my $func = js(q{ (function (x,y) { return "x"+x+"y"+y+"z" }) }); + isa_ok $func, 'WebPerl::JSObject'; + is $func->("a","b"), "xaybz", 'func call'; + is js('(function (d) {return d})')->("\0\N{U+E4}\x{2665}"), + "\0\N{U+E4}\x{2665}", 'unicode passed as arg & rv'; + + my $pl = $func->toperl; + is ref $pl, 'CODE', 'toperl gives code ref'; + is $pl->('i','j'), 'xiyjz', 'code ref works'; + + is js( '('.js([qw/foo bar quz/])->jscode.')[1]' ), "bar", 'basic jscode test'; + ok js( '('.js('document')->jscode.')===('.js('document')->jscode.')' ), 'jscode equality test'; + ok !js( '('.js('document')->jscode.')===('.js('window')->jscode.')' ), 'jscode inequality test'; +}; + +subtest 'basic array test' => sub { + my $arr = js(q{ testarray = [3,1,4,1,5,9]; (testarray) }); + isa_ok $arr, 'WebPerl::JSObject'; + is_deeply [@$arr], [3,1,4,1,5,9], 'array values'; + $arr->[4] = 'x'; + is js('testarray[4]'), 'x', 'setting successful'; + + my $ref = $arr->arrayref; + is_deeply $ref, [3,1,4,1,'x',9], 'arrayref values'; + is ref $ref, 'ARRAY', 'arrayref gives arrayref'; + isa_ok tied(@$ref), 'WebPerl::JSObject::TiedArray'; + $ref->[5] = 'y'; + is js('testarray[5]'), 'y', 'setting successful 2'; + + my $plain = $arr->toperl; + is_deeply $plain, [3,1,4,1,'x','y'], 'toperl values'; + is ref $plain, 'ARRAY', 'toperl gives arrayref'; + ok !tied(@$plain), 'toperl result isn\'t tied'; +}; + +subtest 'basic object test' => sub { + my $obj = js(q{ ({ hello: "world!", foo : function () { return "foobar!" } }) }); + isa_ok $obj, 'WebPerl::JSObject'; + is_deeply [sort keys %$obj], ['foo','hello'], 'keys on object'; + is $obj->{hello}, "world!", 'simple object value'; + isa_ok $obj->{foo}, 'WebPerl::JSObject'; + is $obj->foo, 'foobar!', 'method call'; +}; + +subtest 'encode_json' => sub { + my $json = encode_json( { Hello=>"World!" } ); + my $jo = js( "($json)" ); + isa_ok $jo, 'WebPerl::JSObject', 'json'; + is $jo->{Hello}, 'World!', 'json object key/value'; +}; + +subtest 'advanced function tests' => sub { + js(' (function (cb) { cb("yup") }) ') + ->( sub1 { + is shift, "yup", "calling between JS<->Perl"; + } ); + my $passthru = + js(q{ (function (cb) { var rv = cb({hello:"world"}); return rv } ) }) + ->(sub { return shift }); + isa_ok $passthru, 'WebPerl::JSObject', 'passthru worked 1'; + is $passthru->{hello}, 'world', 'passthru worked 2'; +}; + +done_testing; + +note "All tests passed!" if Test::More->builder->is_passing; + +# -*- buffer-read-only: t -*- +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by regen/warnings.pl. +# Any changes made here will be lost! + +package warnings; + +our $VERSION = "1.42"; + +# Verify that we're called correctly so that warnings will work. +# Can't use Carp, since Carp uses us! +# String regexps because constant folding = smaller optree = less memory vs regexp literal +# see also strict.pm. +die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2] + if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' ) + && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' ); + +our %Offsets = ( + # Warnings Categories added in Perl 5.008 + 'all' => 0, + 'closure' => 2, + 'deprecated' => 4, + 'exiting' => 6, + 'glob' => 8, + 'io' => 10, + 'closed' => 12, + 'exec' => 14, + 'layer' => 16, + 'newline' => 18, + 'pipe' => 20, + 'unopened' => 22, + 'misc' => 24, + 'numeric' => 26, + 'once' => 28, + 'overflow' => 30, + 'pack' => 32, + 'portable' => 34, + 'recursion' => 36, + 'redefine' => 38, + 'regexp' => 40, + 'severe' => 42, + 'debugging' => 44, + 'inplace' => 46, + 'internal' => 48, + 'malloc' => 50, + 'signal' => 52, + 'substr' => 54, + 'syntax' => 56, + 'ambiguous' => 58, + 'bareword' => 60, + 'digit' => 62, + 'parenthesis' => 64, + 'precedence' => 66, + 'printf' => 68, + 'prototype' => 70, + 'qw' => 72, + 'reserved' => 74, + 'semicolon' => 76, + 'taint' => 78, + 'threads' => 80, + 'uninitialized' => 82, + 'unpack' => 84, + 'untie' => 86, + 'utf8' => 88, + 'void' => 90, + + # Warnings Categories added in Perl 5.011 + 'imprecision' => 92, + 'illegalproto' => 94, + + # Warnings Categories added in Perl 5.013 + 'non_unicode' => 96, + 'nonchar' => 98, + 'surrogate' => 100, + + # Warnings Categories added in Perl 5.017 + 'experimental' => 102, + 'experimental::lexical_subs' => 104, + 'experimental::regex_sets' => 106, + 'experimental::smartmatch' => 108, + + # Warnings Categories added in Perl 5.019 + 'experimental::postderef' => 110, + 'experimental::signatures' => 112, + 'syscalls' => 114, + + # Warnings Categories added in Perl 5.021 + 'experimental::bitwise' => 116, + 'experimental::const_attr' => 118, + 'experimental::re_strict' => 120, + 'experimental::refaliasing' => 122, + 'experimental::win32_perlio' => 124, + 'locale' => 126, + 'missing' => 128, + 'redundant' => 130, + + # Warnings Categories added in Perl 5.025 + 'experimental::declared_refs' => 132, + + # Warnings Categories added in Perl 5.027 + 'experimental::alpha_assertions' => 134, + 'experimental::script_run' => 136, + 'shadow' => 138, +); + +our %Bits = ( + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..71] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x55\x51\x15\x50\x01", # [51..56,58..62,66..68] + 'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [67] + 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [58] + 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [59] + 'experimental::declared_refs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [66] + 'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [52] + 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [55] + 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [60] + 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [61] + 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [53] + 'experimental::script_run' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [68] + 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [56] + 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [54] + 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [62] + 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [47] + 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [46] + 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [5..11,57] + 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [63] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [64] + 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [48] + 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [49] + 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [65] + 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] + 'shadow' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [69] + 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] + 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [50] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40\x00\x00\x00\x00\x00\x00", # [28..38,47] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [57] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [41] + 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x15\x00\x00\x00\x00\x00", # [44,48..50] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [45] +); + +our %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..71] + 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29] + 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30] + 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6] + 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22] + 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31] + 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7] + 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'experimental' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xaa\xa2\x2a\xa0\x02", # [51..56,58..62,66..68] + 'experimental::alpha_assertions' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [67] + 'experimental::bitwise' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [58] + 'experimental::const_attr' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [59] + 'experimental::declared_refs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [66] + 'experimental::lexical_subs' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [52] + 'experimental::postderef' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [55] + 'experimental::re_strict' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [60] + 'experimental::refaliasing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [61] + 'experimental::regex_sets' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [53] + 'experimental::script_run' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [68] + 'experimental::signatures' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [56] + 'experimental::smartmatch' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [54] + 'experimental::win32_perlio' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [62] + 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4] + 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [47] + 'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [46] + 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [23] + 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [24] + 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [5..11,57] + 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8] + 'locale' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [63] + 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [25] + 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [12] + 'missing' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [64] + 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9] + 'non_unicode' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [48] + 'nonchar' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [49] + 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [13] + 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [14] + 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [15] + 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [16] + 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [32] + 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10] + 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [17] + 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [33] + 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [34] + 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [35] + 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [36] + 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [18] + 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [19] + 'redundant' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [65] + 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [20] + 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [37] + 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [38] + 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [21..25] + 'shadow' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [69] + 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [26] + 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [27] + 'surrogate' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [50] + 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80\x00\x00\x00\x00\x00\x00", # [28..38,47] + 'syscalls' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [57] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [39] + 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [40] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [41] + 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11] + 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [42] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [43] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x2a\x00\x00\x00\x00\x00", # [44,48..50] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [45] +); + +# These are used by various things, including our own tests +our $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"; +our $DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51\x55\x50\x01", # [2,4,22,23,25,52..56,58..63,66..68] +our $LAST_BIT = 140 ; +our $BYTES = 18 ; + +sub Croaker +{ + require Carp; # this initializes %CarpInternal + local $Carp::CarpInternal{'warnings'}; + delete $Carp::CarpInternal{'warnings'}; + Carp::croak(@_); +} + +sub _expand_bits { + my $bits = shift; + my $want_len = ($LAST_BIT + 7) >> 3; + my $len = length($bits); + if ($len != $want_len) { + if ($bits eq "") { + $bits = "\x00" x $want_len; + } elsif ($len > $want_len) { + substr $bits, $want_len, $len-$want_len, ""; + } else { + my $a = vec($bits, $Offsets{all} >> 1, 2); + $a |= $a << 2; + $a |= $a << 4; + $bits .= chr($a) x ($want_len - $len); + } + } + return $bits; +} + +sub _bits { + my $mask = shift ; + my $catmask ; + my $fatal = 0 ; + my $no_fatal = 0 ; + + $mask = _expand_bits($mask); + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + $fatal = 1; + $no_fatal = 0; + } + elsif ($word eq 'NONFATAL') { + $fatal = 0; + $no_fatal = 1; + } + elsif ($catmask = $Bits{$word}) { + $mask |= $catmask ; + $mask |= $DeadBits{$word} if $fatal ; + $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ; + } + else + { Croaker("Unknown warnings category '$word'")} + } + + return $mask ; +} + +sub bits +{ + # called from B::Deparse.pm + push @_, 'all' unless @_ ; + return _bits("", @_) ; +} + +sub import +{ + shift; + + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + # append 'all' when implied (empty import list or after a lone + # "FATAL" or "NONFATAL") + push @_, 'all' + if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL')); + + ${^WARNING_BITS} = _bits($mask, @_); +} + +sub unimport +{ + shift; + + my $catmask ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; + + # append 'all' when implied (empty import list or after a lone "FATAL") + push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL'; + + $mask = _expand_bits($mask); + foreach my $word ( @_ ) { + if ($word eq 'FATAL') { + next; + } + elsif ($catmask = $Bits{$word}) { + $mask = ~(~$mask | $catmask | $DeadBits{$word}); + } + else + { Croaker("Unknown warnings category '$word'")} + } + + ${^WARNING_BITS} = $mask ; +} + +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + +sub LEVEL () { 8 }; +sub MESSAGE () { 4 }; +sub FATAL () { 2 }; +sub NORMAL () { 1 }; + +sub __chk +{ + my $category ; + my $offset ; + my $isobj = 0 ; + my $wanted = shift; + my $has_message = $wanted & MESSAGE; + my $has_level = $wanted & LEVEL ; + + if ($has_level) { + if (@_ != ($has_message ? 3 : 2)) { + my $sub = (caller 1)[3]; + my $syntax = $has_message + ? "category, level, 'message'" + : 'category, level'; + Croaker("Usage: $sub($syntax)"); + } + } + elsif (not @_ == 1 || @_ == ($has_message ? 2 : 0)) { + my $sub = (caller 1)[3]; + my $syntax = $has_message ? "[category,] 'message'" : '[category]'; + Croaker("Usage: $sub($syntax)"); + } + + my $message = pop if $has_message; + + if (@_) { + # check the category supplied. + $category = shift ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; + $isobj = 1 ; + } + $offset = $Offsets{$category}; + Croaker("Unknown warnings category '$category'") + unless defined $offset; + } + else { + $category = (caller(1))[0] ; + $offset = $Offsets{$category}; + Croaker("package '$category' not registered for warnings") + unless defined $offset ; + } + + my $i; + + if ($isobj) { + my $pkg; + $i = 2; + while (do { { package DB; $pkg = (caller($i++))[0] } } ) { + last unless @DB::args && $DB::args[0] =~ /^$category=/ ; + } + $i -= 2 ; + } + elsif ($has_level) { + $i = 2 + shift; + } + else { + $i = _error_loc(); # see where Carp will allocate the error + } + + # Default to 0 if caller returns nothing. Default to $DEFAULT if it + # explicitly returns undef. + my(@callers_bitmask) = (caller($i))[9] ; + my $callers_bitmask = + @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; + length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all}; + + my @results; + foreach my $type (FATAL, NORMAL) { + next unless $wanted & $type; + + push @results, vec($callers_bitmask, $offset + $type - 1, 1); + } + + # &enabled and &fatal_enabled + return $results[0] unless $has_message; + + # &warnif, and the category is neither enabled as warning nor as fatal + return if ($wanted & (NORMAL | FATAL | MESSAGE)) + == (NORMAL | FATAL | MESSAGE) + && !($results[0] || $results[1]); + + # If we have an explicit level, bypass Carp. + if ($has_level and @callers_bitmask) { + # logic copied from util.c:mess_sv + my $stuff = " at " . join " line ", (caller $i)[1,2]; + $stuff .= sprintf ", <%s> %s %d", + *${^LAST_FH}{NAME}, + ($/ eq "\n" ? "line" : "chunk"), $. + if $. && ${^LAST_FH}; + die "$message$stuff.\n" if $results[0]; + return warn "$message$stuff.\n"; + } + + require Carp; + Carp::croak($message) if $results[0]; + # will always get here for &warn. will only get here for &warnif if the + # category is enabled + Carp::carp($message); +} + +sub _mkMask +{ + my ($bit) = @_; + my $mask = ""; + + vec($mask, $bit, 1) = 1; + return $mask; +} + +sub register_categories +{ + my @names = @_; + + for my $name (@names) { + if (! defined $Bits{$name}) { + $Offsets{$name} = $LAST_BIT; + $Bits{$name} = _mkMask($LAST_BIT++); + $DeadBits{$name} = _mkMask($LAST_BIT++); + if (length($Bits{$name}) > length($Bits{all})) { + $Bits{all} .= "\x55"; + $DeadBits{all} .= "\xaa"; + } + } + } +} + +sub _error_loc { + require Carp; + goto &Carp::short_error_loc; # don't introduce another stack frame +} + +sub enabled +{ + return __chk(NORMAL, @_); +} + +sub fatal_enabled +{ + return __chk(FATAL, @_); +} + +sub warn +{ + return __chk(FATAL | MESSAGE, @_); +} + +sub warnif +{ + return __chk(NORMAL | FATAL | MESSAGE, @_); +} + +sub enabled_at_level +{ + return __chk(NORMAL | LEVEL, @_); +} + +sub fatal_enabled_at_level +{ + return __chk(FATAL | LEVEL, @_); +} + +sub warn_at_level +{ + return __chk(FATAL | MESSAGE | LEVEL, @_); +} + +sub warnif_at_level +{ + return __chk(NORMAL | FATAL | MESSAGE | LEVEL, @_); +} + +# These are not part of any public interface, so we can delete them to save +# space. +delete @warnings::{qw(NORMAL FATAL MESSAGE LEVEL)}; + +1; +__END__ + +# ex: set ro: +package DBM_Filter ; + +use strict; +use warnings; +our $VERSION = '0.06'; + +package Tie::Hash ; + +use strict; +use warnings; + +use Carp; + + +our %LayerStack = (); +our %origDESTROY = (); + +our %Filters = map { $_, undef } qw( + Fetch_Key + Fetch_Value + Store_Key + Store_Value + ); + +our %Options = map { $_, 1 } qw( + fetch + store + ); + +#sub Filter_Enable +#{ +#} +# +#sub Filter_Disable +#{ +#} + +sub Filtered +{ + my $this = shift; + return defined $LayerStack{$this} ; +} + +sub Filter_Pop +{ + my $this = shift; + my $stack = $LayerStack{$this} || return undef ; + my $filter = pop @{ $stack }; + + # remove the filter hooks if this is the last filter to pop + if ( @{ $stack } == 0 ) { + $this->filter_store_key ( undef ); + $this->filter_store_value( undef ); + $this->filter_fetch_key ( undef ); + $this->filter_fetch_value( undef ); + delete $LayerStack{$this}; + } + + return $filter; +} + +sub Filter_Key_Push +{ + &_do_Filter_Push; +} + +sub Filter_Value_Push +{ + &_do_Filter_Push; +} + + +sub Filter_Push +{ + &_do_Filter_Push; +} + +sub _do_Filter_Push +{ + my $this = shift; + my %callbacks = (); + my $caller = (caller(1))[3]; + $caller =~ s/^.*:://; + + croak "$caller: no parameters present" unless @_ ; + + if ( ! $Options{lc $_[0]} ) { + my $class = shift; + my @params = @_; + + # if $class already contains "::", don't prefix "DBM_Filter::" + $class = "DBM_Filter::$class" unless $class =~ /::/; + + no strict 'refs'; + # does the "DBM_Filter::$class" exist? + if ( ! %{ "${class}::"} ) { + # Nope, so try to load it. + eval " require $class ; " ; + croak "$caller: Cannot Load DBM Filter '$class': $@" if $@; + } + + my $fetch = *{ "${class}::Fetch" }{CODE}; + my $store = *{ "${class}::Store" }{CODE}; + my $filter = *{ "${class}::Filter" }{CODE}; + use strict 'refs'; + + my $count = defined($filter) + defined($store) + defined($fetch) ; + + if ( $count == 0 ) + { croak "$caller: No methods (Filter, Fetch or Store) found in class '$class'" } + elsif ( $count == 1 && ! defined $filter) { + my $need = defined($fetch) ? 'Store' : 'Fetch'; + croak "$caller: Missing method '$need' in class '$class'" ; + } + elsif ( $count >= 2 && defined $filter) + { croak "$caller: Can't mix Filter with Store and Fetch in class '$class'" } + + if (defined $filter) { + my $callbacks = &{ $filter }(@params); + croak "$caller: '${class}::Filter' did not return a hash reference" + unless ref $callbacks && ref $callbacks eq 'HASH'; + %callbacks = %{ $callbacks } ; + } + else { + $callbacks{Fetch} = $fetch; + $callbacks{Store} = $store; + } + } + else { + croak "$caller: not even params" unless @_ % 2 == 0; + %callbacks = @_; + } + + my %filters = %Filters ; + my @got = (); + while (my ($k, $v) = each %callbacks ) + { + my $key = $k; + $k = lc $k; + if ($k eq 'fetch') { + push @got, 'Fetch'; + if ($caller eq 'Filter_Push') + { $filters{Fetch_Key} = $filters{Fetch_Value} = $v } + elsif ($caller eq 'Filter_Key_Push') + { $filters{Fetch_Key} = $v } + elsif ($caller eq 'Filter_Value_Push') + { $filters{Fetch_Value} = $v } + } + elsif ($k eq 'store') { + push @got, 'Store'; + if ($caller eq 'Filter_Push') + { $filters{Store_Key} = $filters{Store_Value} = $v } + elsif ($caller eq 'Filter_Key_Push') + { $filters{Store_Key} = $v } + elsif ($caller eq 'Filter_Value_Push') + { $filters{Store_Value} = $v } + } + else + { croak "$caller: Unknown key '$key'" } + + croak "$caller: value associated with key '$key' is not a code reference" + unless ref $v && ref $v eq 'CODE'; + } + + if ( @got != 2 ) { + push @got, 'neither' if @got == 0 ; + croak "$caller: expected both Store & Fetch - got @got"; + } + + # remember the class + push @{ $LayerStack{$this} }, \%filters ; + + my $str_this = "$this" ; # Avoid a closure with $this in the subs below + + $this->filter_store_key ( sub { store_hook($str_this, 'Store_Key') }); + $this->filter_store_value( sub { store_hook($str_this, 'Store_Value') }); + $this->filter_fetch_key ( sub { fetch_hook($str_this, 'Fetch_Key') }); + $this->filter_fetch_value( sub { fetch_hook($str_this, 'Fetch_Value') }); + + # Hijack the callers DESTROY method + $this =~ /^(.*)=/; + my $type = $1 ; + no strict 'refs'; + if ( *{ "${type}::DESTROY" }{CODE} ne \&MyDESTROY ) + { + $origDESTROY{$type} = *{ "${type}::DESTROY" }{CODE}; + no warnings 'redefine'; + *{ "${type}::DESTROY" } = \&MyDESTROY ; + } +} + +sub store_hook +{ + my $this = shift ; + my $type = shift ; + foreach my $layer (@{ $LayerStack{$this} }) + { + &{ $layer->{$type} }() if defined $layer->{$type} ; + } +} + +sub fetch_hook +{ + my $this = shift ; + my $type = shift ; + foreach my $layer (reverse @{ $LayerStack{$this} }) + { + &{ $layer->{$type} }() if defined $layer->{$type} ; + } +} + +sub MyDESTROY +{ + my $this = shift ; + delete $LayerStack{$this} ; + + # call real DESTROY + $this =~ /^(.*)=/; + &{ $origDESTROY{$1} }($this); +} + +1; + +__END__ + +# Generated from XSLoader_pm.PL (resolved %Config::Config value) +# This file is unique for every OS + +package XSLoader; + +$VERSION = "0.30"; # remember to update version in POD! + +#use strict; + +package DynaLoader; + +# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here. +# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB +boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) && + !defined(&dl_error); +package XSLoader; + +sub load { + package DynaLoader; + + my ($caller, $modlibname) = caller(); + my $module = $caller; + + if (@_) { + $module = $_[0]; + } else { + $_[0] = $module; + } + + # work with static linking too + my $boots = "$module\::bootstrap"; + goto &$boots if defined &$boots; + + goto \&XSLoader::bootstrap_inherit unless $module and defined &dl_load_file; + + my @modparts = split(/::/,$module); + my $modfname = $modparts[-1]; + my $modfname_orig = $modfname; # For .bs file search + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + $modfname = &DynaLoader::mod2fname(\@modparts) if defined &DynaLoader::mod2fname; + + my $modpname = join('/',@modparts); + my $c = () = split(/::/,$caller,-1); + $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename + # Does this look like a relative path? + if ($modlibname !~ m{^/}) { + # Someone may have a #line directive that changes the file name, or + # may be calling XSLoader::load from inside a string eval. We cer- + # tainly do not want to go loading some code that is not in @INC, + # as it could be untrusted. + # + # We could just fall back to DynaLoader here, but then the rest of + # this function would go untested in the perl core, since all @INC + # paths are relative during testing. That would be a time bomb + # waiting to happen, since bugs could be introduced into the code. + # + # So look through @INC to see if $modlibname is in it. A rela- + # tive $modlibname is not a common occurrence, so this block is + # not hot code. + FOUND: { + for (@INC) { + if ($_ eq $modlibname) { + last FOUND; + } + } + # Not found. Fall back to DynaLoader. + goto \&XSLoader::bootstrap_inherit; + } + } + my $file = "$modlibname/auto/$modpname/$modfname.none"; + +# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; + + # N.B. The .bs file does not following the naming convention used + # by mod2fname, so use the unedited version of the name. + + my $bs = "$modlibname/auto/$modpname/$modfname_orig.bs"; + + # This calls DynaLoader::bootstrap, which will load the .bs file if present + goto \&XSLoader::bootstrap_inherit if not -f $file or -s $bs; + + my $bootname = "boot_$module"; + $bootname =~ s/\W/_/g; + @DynaLoader::dl_require_symbols = ($bootname); + + my $boot_symbol_ref; + + # Many dynamic extension loading problems will appear to come from + # this section of code: XYZ failed at line 123 of DynaLoader.pm. + # Often these errors are actually occurring in the initialisation + # C code of the extension XS file. Perl reports the error as being + # in this perl code simply because this was the last perl code + # it executed. + + my $libref = dl_load_file($file, 0) or do { + require Carp; + Carp::croak("Can't load '$file' for module $module: " . dl_error()); + }; + push(@DynaLoader::dl_librefs,$libref); # record loaded object + + $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do { + require Carp; + Carp::croak("Can't find '$bootname' symbol in $file\n"); + }; + + push(@DynaLoader::dl_modules, $module); # record loaded module + + boot: + my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file); + + # See comment block above + push(@DynaLoader::dl_shared_objects, $file); # record files loaded + return &$xs(@_); +} + +sub bootstrap_inherit { + require DynaLoader; + goto \&DynaLoader::bootstrap_inherit; +} + +1; + + +__END__ + +package bigrat; + +use 5.010; +use strict; +use warnings; + +our $VERSION = '0.49'; + +use Exporter; +our @ISA = qw( bigint ); +our @EXPORT_OK = qw( PI e bpi bexp hex oct ); +our @EXPORT = qw( inf NaN ); + +use overload; +use bigint (); + +############################################################################## + +BEGIN { + *inf = \&bigint::inf; + *NaN = \&bigint::NaN; + *hex = \&bigint::hex; + *oct = \&bigint::oct; +} + +# These are all alike, and thus faked by AUTOLOAD + +my @faked = qw/round_mode accuracy precision div_scale/; +our ($AUTOLOAD, $_lite); # _lite for testsuite + +sub AUTOLOAD { + my $name = $AUTOLOAD; + + $name =~ s/.*:://; # split package + no strict 'refs'; + foreach my $n (@faked) { + if ($n eq $name) { + *{"bigrat::$name"} = + sub { + my $self = shift; + no strict 'refs'; + if (defined $_[0]) { + Math::BigInt->$name($_[0]); + Math::BigFloat->$name($_[0]); + return Math::BigRat->$name($_[0]); + } + return Math::BigInt->$name(); + }; + return &$name; + } + } + + # delayed load of Carp and avoid recursion + require Carp; + Carp::croak ("Can't call bigrat\-\>$name, not a valid method"); +} + +sub unimport { + $^H{bigrat} = undef; # no longer in effect + overload::remove_constant('binary', '', 'float', '', 'integer'); +} + +sub in_effect { + my $level = shift || 0; + my $hinthash = (caller($level))[10]; + $hinthash->{bigrat}; +} + +############################################################################# + +sub import { + my $self = shift; + + # see also bignum->import() for additional comments + + $^H{bigrat} = 1; # we are in effect + + # for newer Perls always override hex() and oct() with a lexical version: + if ($] > 5.009004) { + bigint::_override(); + } + # some defaults + my $lib = ''; + my $lib_kind = 'try'; + my $upgrade = 'Math::BigFloat'; + + my @import = (':constant'); # drive it w/ constant + my @a = @_; + my $l = scalar @_; + my $j = 0; + my ($a, $p); + my ($ver, $trace); # version? trace? + for (my $i = 0; $i < $l ; $i++, $j++) { + if ($_[$i] eq 'upgrade') { + # this causes upgrading + $upgrade = $_[$i + 1]; # or undef to disable + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + } + elsif ($_[$i] =~ /^(l|lib|try|only)$/) { + # this causes a different low lib to take care... + $lib_kind = $1; + $lib_kind = 'lib' if $lib_kind eq 'l'; + $lib = $_[$i + 1] || ''; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(a|accuracy)$/) { + $a = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(p|precision)$/) { + $p = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(v|version)$/) { + $ver = 1; + splice @a, $j, 1; + $j--; + } + elsif ($_[$i] =~ /^(t|trace)$/) { + $trace = 1; + splice @a, $j, 1; + $j--; + } + elsif ($_[$i] !~ /^(PI|e|bpi|bexp|hex|oct)\z/) { + die ("unknown option $_[$i]"); + } + } + my $class; + $_lite = 0; # using M::BI::L ? + if ($trace) { + require Math::BigInt::Trace; + $class = 'Math::BigInt::Trace'; + $upgrade = 'Math::BigFloat::Trace'; + } + else { + # see if we can find Math::BigInt::Lite + if (!defined $a && !defined $p) { # rounding won't work to well + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + if (eval { require Math::BigInt::Lite; 1 }) { + @import = (); # :constant in Lite, not MBI + Math::BigInt::Lite->import(':constant'); + $_lite = 1; # signal okay + } + } + require Math::BigInt if $_lite == 0; # not already loaded? + $class = 'Math::BigInt'; # regardless of MBIL or not + } + push @import, $lib_kind => $lib if $lib ne ''; + # Math::BigInt::Trace or plain Math::BigInt + $class->import(@import, upgrade => $upgrade); + + require Math::BigFloat; + Math::BigFloat->import(upgrade => 'Math::BigRat', ':constant'); + require Math::BigRat; + Math::BigRat->import(@import); + + bigrat->accuracy($a) if defined $a; + bigrat->precision($p) if defined $p; + if ($ver) { + print "bigrat\t\t\t v$VERSION\n"; + print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite; + print "Math::BigInt\t\t v$Math::BigInt::VERSION"; + my $config = Math::BigInt->config(); + print " lib => $config->{lib} v$config->{lib_version}\n"; + print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n"; + print "Math::BigRat\t\t v$Math::BigRat::VERSION\n"; + exit; + } + + # Take care of octal/hexadecimal constants + overload::constant binary => + sub { + bigint::_binary_constant(shift); + }; + + # if another big* was already loaded: + my ($package) = caller(); + + no strict 'refs'; + if (!defined *{"${package}::inf"}) { + $self->export_to_level(1, $self, @a); # export inf and NaN + } +} + +sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); } +sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); } + +sub bpi ($) { + local $Math::BigFloat::upgrade; + Math::BigFloat->bpi(@_); +} + +sub bexp ($$) { + local $Math::BigFloat::upgrade; + my $x = Math::BigFloat->new($_[0]); + $x->bexp($_[1]); +} + +1; + +__END__ + +package Fatal; + +# ABSTRACT: Replace functions with equivalents which succeed or die + +use 5.008; # 5.8.x needed for autodie +use Carp; +use strict; +use warnings; +use Tie::RefHash; # To cache subroutine refs +use Config; +use Scalar::Util qw(set_prototype); + +use autodie::Util qw( + fill_protos + install_subs + make_core_trampoline + on_end_of_compile_scope +); + +use constant PERL510 => ( $] >= 5.010 ); + +use constant LEXICAL_TAG => q{:lexical}; +use constant VOID_TAG => q{:void}; +use constant INSIST_TAG => q{!}; + +# Keys for %Cached_fatalised_sub (used in 3rd level) +use constant CACHE_AUTODIE_LEAK_GUARD => 0; +use constant CACHE_FATAL_WRAPPER => 1; +use constant CACHE_FATAL_VOID => 2; + + +use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments'; +use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope'; +use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument'; +use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG; +use constant ERROR_BADNAME => "Bad subroutine name for %s: %s"; +use constant ERROR_NOTSUB => "%s is not a Perl subroutine"; +use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine"; +use constant ERROR_NOHINTS => "No user hints defined for %s"; + +use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal"; + +use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()"; + +use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f"; + +use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect}; + +use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect}; + +use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x}; + +# Older versions of IPC::System::Simple don't support all the +# features we need. + +use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; + +our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version + +our $Debug ||= 0; + +# EWOULDBLOCK values for systems that don't supply their own. +# Even though this is defined with our, that's to help our +# test code. Please don't rely upon this variable existing in +# the future. + +our %_EWOULDBLOCK = ( + MSWin32 => 33, +); + +$Carp::CarpInternal{'Fatal'} = 1; +$Carp::CarpInternal{'autodie'} = 1; +$Carp::CarpInternal{'autodie::exception'} = 1; + +# the linux parisc port has separate EAGAIN and EWOULDBLOCK, +# and the kernel returns EAGAIN +my $try_EAGAIN = ($^O eq 'linux' and $Config{archname} =~ /hppa|parisc/) ? 1 : 0; + +# We have some tags that can be passed in for use with import. +# These are all assumed to be CORE:: + +my %TAGS = ( + ':io' => [qw(:dbm :file :filesys :ipc :socket + read seek sysread syswrite sysseek )], + ':dbm' => [qw(dbmopen dbmclose)], + ':file' => [qw(open close flock sysopen fcntl binmode + ioctl truncate)], + ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir + symlink rmdir readlink chmod chown utime)], + ':ipc' => [qw(:msg :semaphore :shm pipe kill)], + ':msg' => [qw(msgctl msgget msgrcv msgsnd)], + ':threads' => [qw(fork)], + ':semaphore'=>[qw(semctl semget semop)], + ':shm' => [qw(shmctl shmget shmread)], + ':system' => [qw(system exec)], + + # Can we use qw(getpeername getsockname)? What do they do on failure? + # TODO - Can socket return false? + ':socket' => [qw(accept bind connect getsockopt listen recv send + setsockopt shutdown socketpair)], + + # Our defaults don't include system(), because it depends upon + # an optional module, and it breaks the exotic form. + # + # This *may* change in the future. I'd love IPC::System::Simple + # to be a dependency rather than a recommendation, and hence for + # system() to be autodying by default. + + ':default' => [qw(:io :threads)], + + # Everything in v2.07 and before. This was :default less chmod and chown + ':v207' => [qw(:threads :dbm :socket read seek sysread + syswrite sysseek open close flock sysopen fcntl fileno + binmode ioctl truncate opendir closedir chdir link unlink + rename mkdir symlink rmdir readlink umask + :msg :semaphore :shm pipe)], + + # Chmod was added in 2.13 + ':v213' => [qw(:v207 chmod)], + + # chown, utime, kill were added in 2.14 + ':v214' => [qw(:v213 chown utime kill)], + + # umask was removed in 2.26 + ':v225' => [qw(:io :threads umask fileno)], + + # Version specific tags. These allow someone to specify + # use autodie qw(:1.994) and know exactly what they'll get. + + ':1.994' => [qw(:v207)], + ':1.995' => [qw(:v207)], + ':1.996' => [qw(:v207)], + ':1.997' => [qw(:v207)], + ':1.998' => [qw(:v207)], + ':1.999' => [qw(:v207)], + ':1.999_01' => [qw(:v207)], + ':2.00' => [qw(:v207)], + ':2.01' => [qw(:v207)], + ':2.02' => [qw(:v207)], + ':2.03' => [qw(:v207)], + ':2.04' => [qw(:v207)], + ':2.05' => [qw(:v207)], + ':2.06' => [qw(:v207)], + ':2.06_01' => [qw(:v207)], + ':2.07' => [qw(:v207)], # Last release without chmod + ':2.08' => [qw(:v213)], + ':2.09' => [qw(:v213)], + ':2.10' => [qw(:v213)], + ':2.11' => [qw(:v213)], + ':2.12' => [qw(:v213)], + ':2.13' => [qw(:v213)], # Last release without chown + ':2.14' => [qw(:v225)], + ':2.15' => [qw(:v225)], + ':2.16' => [qw(:v225)], + ':2.17' => [qw(:v225)], + ':2.18' => [qw(:v225)], + ':2.19' => [qw(:v225)], + ':2.20' => [qw(:v225)], + ':2.21' => [qw(:v225)], + ':2.22' => [qw(:v225)], + ':2.23' => [qw(:v225)], + ':2.24' => [qw(:v225)], + ':2.25' => [qw(:v225)], + ':2.26' => [qw(:default)], + ':2.27' => [qw(:default)], + ':2.28' => [qw(:default)], + ':2.29' => [qw(:default)], +); + + +{ + # Expand :all immediately by expanding and flattening all tags. + # _expand_tag is not really optimised for expanding the ":all" + # case (i.e. keys %TAGS, or values %TAGS for that matter), so we + # just do it here. + # + # NB: The %tag_cache/_expand_tag relies on $TAGS{':all'} being + # pre-expanded. + my %seen; + my @all = grep { + !/^:/ && !$seen{$_}++ + } map { @{$_} } values %TAGS; + $TAGS{':all'} = \@all; +} + +# This hash contains subroutines for which we should +# subroutine() // die() rather than subroutine() || die() + +my %Use_defined_or; + +# CORE::open returns undef on failure. It can legitimately return +# 0 on success, eg: open(my $fh, '-|') || exec(...); + +@Use_defined_or{qw( + CORE::fork + CORE::recv + CORE::send + CORE::open + CORE::fileno + CORE::read + CORE::readlink + CORE::sysread + CORE::syswrite + CORE::sysseek + CORE::umask +)} = (); + +# Some functions can return true because they changed *some* things, but +# not all of them. This is a list of offending functions, and how many +# items to subtract from @_ to determine the "success" value they return. + +my %Returns_num_things_changed = ( + 'CORE::chmod' => 1, + 'CORE::chown' => 2, + 'CORE::kill' => 1, # TODO: Could this return anything on negative args? + 'CORE::unlink' => 0, + 'CORE::utime' => 2, +); + +# Optional actions to take on the return value before returning it. + +my %Retval_action = ( + "CORE::open" => q{ + + # apply the open pragma from our caller + if( defined $retval && !( @_ >= 3 && $_[1] =~ /:/ )) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + # Decide if we're reading or writing and apply the appropriate encoding + # These keys are undocumented. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $encoding = $_[1] =~ /^\+?>/ ? $hints->{"open>"} : $hints->{"open<"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, + "CORE::sysopen" => q{ + + # apply the open pragma from our caller + if( defined $retval ) { + # Get the caller's hint hash + my $hints = (caller 0)[10]; + + require Fcntl; + + # Decide if we're reading or writing and apply the appropriate encoding. + # Match what PerlIO_context_layers() does. Read gets the read layer, + # everything else gets the write layer. + my $open_read_only = !($_[2] ^ Fcntl::O_RDONLY()); + my $encoding = $open_read_only ? $hints->{"open<"} : $hints->{"open>"}; + + # Apply the encoding, if any. + if( $encoding ) { + binmode $_[0], $encoding; + } + } + +}, +); + +my %reusable_builtins; + +# "Wait!" I hear you cry, "truncate() and chdir() are not reuseable! They can +# take file and directory handles, which are package depedent." +# +# You would be correct, except that prototype() returns signatures which don't +# allow for passing of globs, and nobody's complained about that. You can +# still use \*FILEHANDLE, but that results in a reference coming through, +# and it's already pointing to the filehandle in the caller's packge, so +# it's all okay. + +@reusable_builtins{qw( + CORE::fork + CORE::kill + CORE::truncate + CORE::chdir + CORE::link + CORE::unlink + CORE::rename + CORE::mkdir + CORE::symlink + CORE::rmdir + CORE::readlink + CORE::umask + CORE::chmod + CORE::chown + CORE::utime + CORE::msgctl + CORE::msgget + CORE::msgrcv + CORE::msgsnd + CORE::semctl + CORE::semget + CORE::semop + CORE::shmctl + CORE::shmget + CORE::shmread + CORE::exec + CORE::system +)} = (); + +# Cached_fatalised_sub caches the various versions of our +# fatalised subs as they're produced. This means we don't +# have to build our own replacement of CORE::open and friends +# for every single package that wants to use them. + +my %Cached_fatalised_sub = (); + +# Every time we're called with package scope, we record the subroutine +# (including package or CORE::) in %Package_Fatal. This allows us +# to detect illegal combinations of autodie and Fatal, and makes sure +# we don't accidently make a Fatal function autodying (which isn't +# very useful). + +my %Package_Fatal = (); + +# The first time we're called with a user-sub, we cache it here. +# In the case of a "no autodie ..." we put back the cached copy. + +my %Original_user_sub = (); + +# Is_fatalised_sub simply records a big map of fatalised subroutine +# refs. It means we can avoid repeating work, or fatalising something +# we've already processed. + +my %Is_fatalised_sub = (); +tie %Is_fatalised_sub, 'Tie::RefHash'; + +# Our trampoline cache allows us to cache trampolines which are used to +# bounce leaked wrapped core subroutines to their actual core counterparts. + +my %Trampoline_cache; + +# A cache mapping "CORE::" to their prototype. Turns out that if +# you "use autodie;" enough times, this pays off. +my %CORE_prototype_cache; + +# We use our package in a few hash-keys. Having it in a scalar is +# convenient. The "guard $PACKAGE" string is used as a key when +# setting up lexical guards. + +my $PACKAGE = __PACKAGE__; +my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie' + +# Here's where all the magic happens when someone write 'use Fatal' +# or 'use autodie'. + +sub import { + my $class = shift(@_); + my @original_args = @_; + my $void = 0; + my $lexical = 0; + my $insist_hints = 0; + + my ($pkg, $filename) = caller(); + + @_ or return; # 'use Fatal' is a no-op. + + # If we see the :lexical flag, then _all_ arguments are + # changed lexically + + if ($_[0] eq LEXICAL_TAG) { + $lexical = 1; + shift @_; + + # It is currently an implementation detail that autodie is + # implemented as "use Fatal qw(:lexical ...)". For backwards + # compatibility, we allow it - but not without a warning. + # NB: Optimise for autodie as it is quite possibly the most + # freq. consumer of this case. + if ($class ne 'autodie' and not $class->isa('autodie')) { + if ($class eq 'Fatal') { + warnings::warnif( + 'deprecated', + '[deprecated] The "use Fatal qw(:lexical ...)" ' + . 'should be replaced by "use autodie qw(...)". ' + . 'Seen' # warnif appends " at <...>" + ); + } else { + warnings::warnif( + 'deprecated', + "[deprecated] The class/Package $class is a " + . 'subclass of Fatal and used the :lexical. ' + . 'If $class provides lexical error checking ' + . 'it should extend autodie instead of using :lexical. ' + . 'Seen' # warnif appends " at <...>" + ); + } + # "Promote" the call to autodie from here on. This is + # already mostly the case (e.g. use Fatal qw(:lexical ...) + # would throw autodie::exceptions on error rather than the + # Fatal errors. + $class = 'autodie'; + # This requires that autodie is in fact loaded; otherwise + # the "$class->X()" method calls below will explode. + require autodie; + # TODO, when autodie and Fatal are cleanly separated, we + # should go a "goto &autodie::import" here instead. + } + + # If we see no arguments and :lexical, we assume they + # wanted ':default'. + + if (@_ == 0) { + push(@_, ':default'); + } + + # Don't allow :lexical with :void, it's needlessly confusing. + if ( grep { $_ eq VOID_TAG } @_ ) { + croak(ERROR_VOID_LEX); + } + } + + if ( grep { $_ eq LEXICAL_TAG } @_ ) { + # If we see the lexical tag as the non-first argument, complain. + croak(ERROR_LEX_FIRST); + } + + my @fatalise_these = @_; + + # These subs will get unloaded at the end of lexical scope. + my %unload_later; + # These subs are to be installed into callers namespace. + my %install_subs; + + # Use _translate_import_args to expand tags for us. It will + # pass-through unknown tags (i.e. we have to manually handle + # VOID_TAG). + # + # NB: _translate_import_args re-orders everything for us, so + # we don't have to worry about stuff like: + # + # :default :void :io + # + # That will (correctly) translated into + # + # expand(:defaults-without-io) :void :io + # + # by _translate_import_args. + for my $func ($class->_translate_import_args(@fatalise_these)) { + + if ($func eq VOID_TAG) { + + # When we see :void, set the void flag. + $void = 1; + + } elsif ($func eq INSIST_TAG) { + + $insist_hints = 1; + + } else { + + # Otherwise, fatalise it. + + # Check to see if there's an insist flag at the front. + # If so, remove it, and insist we have hints for this sub. + my $insist_this = $insist_hints; + + if (substr($func, 0, 1) eq '!') { + $func = substr($func, 1); + $insist_this = 1; + } + + # We're going to make a subroutine fatalistic. + # However if we're being invoked with 'use Fatal qw(x)' + # and we've already been called with 'no autodie qw(x)' + # in the same scope, we consider this to be an error. + # Mixing Fatal and autodie effects was considered to be + # needlessly confusing on p5p. + + my $sub = $func; + $sub = "${pkg}::$sub" unless $sub =~ /::/; + + # If we're being called as Fatal, and we've previously + # had a 'no X' in scope for the subroutine, then complain + # bitterly. + + if (! $lexical and $^H{$NO_PACKAGE}{$sub}) { + croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func)); + } + + # We're not being used in a confusing way, so make + # the sub fatal. Note that _make_fatal returns the + # old (original) version of the sub, or undef for + # built-ins. + + my $sub_ref = $class->_make_fatal( + $func, $pkg, $void, $lexical, $filename, + $insist_this, \%install_subs, + ); + + $Original_user_sub{$sub} ||= $sub_ref; + + # If we're making lexical changes, we need to arrange + # for them to be cleaned at the end of our scope, so + # record them here. + + $unload_later{$func} = $sub_ref if $lexical; + } + } + + install_subs($pkg, \%install_subs); + + if ($lexical) { + + # Dark magic to have autodie work under 5.8 + # Copied from namespace::clean, that copied it from + # autobox, that found it on an ancient scroll written + # in blood. + + # This magic bit causes %^H to be lexically scoped. + + $^H |= 0x020000; + + # Our package guard gets invoked when we leave our lexical + # scope. + + on_end_of_compile_scope(sub { + install_subs($pkg, \%unload_later); + }); + + # To allow others to determine when autodie was in scope, + # and with what arguments, we also set a %^H hint which + # is how we were called. + + # This feature should be considered EXPERIMENTAL, and + # may change without notice. Please e-mail pjf@cpan.org + # if you're actually using it. + + $^H{autodie} = "$PACKAGE @original_args"; + + } + + return; + +} + +sub unimport { + my $class = shift; + + # Calling "no Fatal" must start with ":lexical" + if ($_[0] ne LEXICAL_TAG) { + croak(sprintf(ERROR_NO_LEX,$class)); + } + + shift @_; # Remove :lexical + + my $pkg = (caller)[0]; + + # If we've been called with arguments, then the developer + # has explicitly stated 'no autodie qw(blah)', + # in which case, we disable Fatalistic behaviour for 'blah'. + + my @unimport_these = @_ ? @_ : ':all'; + my (%uninstall_subs, %reinstall_subs); + + for my $symbol ($class->_translate_import_args(@unimport_these)) { + + my $sub = $symbol; + $sub = "${pkg}::$sub" unless $sub =~ /::/; + + # If 'blah' was already enabled with Fatal (which has package + # scope) then, this is considered an error. + + if (exists $Package_Fatal{$sub}) { + croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol)); + } + + # Record 'no autodie qw($sub)' as being in effect. + # This is to catch conflicting semantics elsewhere + # (eg, mixing Fatal with no autodie) + + $^H{$NO_PACKAGE}{$sub} = 1; + # Record the current sub to be reinstalled at end of scope + # and then restore the original (can be undef for "CORE::" + # subs) + $reinstall_subs{$symbol} = \&$sub; + $uninstall_subs{$symbol} = $Original_user_sub{$sub}; + + } + + install_subs($pkg, \%uninstall_subs); + on_end_of_compile_scope(sub { + install_subs($pkg, \%reinstall_subs); + }); + + return; + +} + +sub _translate_import_args { + my ($class, @args) = @_; + my @result; + my %seen; + + if (@args < 2) { + # Optimize for this case, as it is fairly common. (e.g. use + # autodie; or use autodie qw(:all); both trigger this). + return unless @args; + + # Not a (known) tag, pass through. + return @args unless exists($TAGS{$args[0]}); + + # Strip "CORE::" from all elements in the list as import and + # unimport does not handle the "CORE::" prefix too well. + # + # NB: we use substr as it is faster than s/^CORE::// and + # it does not change the elements. + return map { substr($_, 6) } @{ $class->_expand_tag($args[0]) }; + } + + # We want to translate + # + # :default :void :io + # + # into (pseudo-ish): + # + # expanded(:threads) :void expanded(:io) + # + # We accomplish this by "reverse, expand + filter, reverse". + for my $a (reverse(@args)) { + if (exists $TAGS{$a}) { + my $expanded = $class->_expand_tag($a); + push(@result, + # Remove duplicates after ... + grep { !$seen{$_}++ } + # we have stripped CORE:: (see above) + map { substr($_, 6) } + # We take the elements in reverse order + # (as @result be reversed later). + reverse(@{$expanded})); + } else { + # pass through - no filtering here for tags. + # + # The reason for not filtering tags cases like: + # + # ":default :void :io :void :threads" + # + # As we have reversed args, we see this as: + # + # ":threads :void :io :void* :default*" + # + # (Entries marked with "*" will be filtered out completely). When + # reversed again, this will be: + # + # ":io :void :threads" + # + # But we would rather want it to be: + # + # ":void :io :threads" or ":void :io :void :threads" + # + + my $letter = substr($a, 0, 1); + if ($letter ne ':' && $a ne INSIST_TAG) { + next if $seen{$a}++; + if ($letter eq '!' and $seen{substr($a, 1)}++) { + my $name = substr($a, 1); + # People are being silly and doing: + # + # use autodie qw(!a a); + # + # Enjoy this little O(n) clean up... + @result = grep { $_ ne $name } @result; + } + } + push @result, $a; + } + } + # Reverse the result to restore the input order + return reverse(@result); +} + + +# NB: Perl::Critic's dump-autodie-tag-contents depends upon this +# continuing to work. + +{ + # We assume that $TAGS{':all'} is pre-expanded and just fill it in + # from the beginning. + my %tag_cache = ( + 'all' => [map { "CORE::$_" } @{$TAGS{':all'}}], + ); + + # Expand a given tag (e.g. ":default") into a listref containing + # all sub names covered by that tag. Each sub is returned as + # "CORE::" (i.e. "CORE::open" rather than "open"). + # + # NB: the listref must not be modified. + sub _expand_tag { + my ($class, $tag) = @_; + + if (my $cached = $tag_cache{$tag}) { + return $cached; + } + + if (not exists $TAGS{$tag}) { + croak "Invalid exception class $tag"; + } + + my @to_process = @{$TAGS{$tag}}; + + # If the tag is basically an alias of another tag (like e.g. ":2.11"), + # then just share the resulting reference with the original content (so + # we only pay for an extra reference for the alias memory-wise). + if (@to_process == 1 && substr($to_process[0], 0, 1) eq ':') { + # We could do this for "non-tags" as well, but that only occurs + # once at the time of writing (":threads" => ["fork"]), so + # probably not worth it. + my $expanded = $class->_expand_tag($to_process[0]); + $tag_cache{$tag} = $expanded; + return $expanded; + } + + my %seen = (); + my @taglist = (); + + for my $item (@to_process) { + # substr is more efficient than m/^:/ for stuff like this, + # at the price of being a bit more verbose/low-level. + if (substr($item, 0, 1) eq ':') { + # Use recursion here to ensure we expand a tag at most once. + + my $expanded = $class->_expand_tag($item); + push @taglist, grep { !$seen{$_}++ } @{$expanded}; + } else { + my $subname = "CORE::$item"; + push @taglist, $subname + unless $seen{$subname}++; + } + } + + $tag_cache{$tag} = \@taglist; + + return \@taglist; + + } + +} + +# This is a backwards compatible version of _write_invocation. It's +# recommended you don't use it. + +sub write_invocation { + my ($core, $call, $name, $void, @args) = @_; + + return Fatal->_write_invocation( + $core, $call, $name, $void, + 0, # Lexical flag + undef, # Sub, unused in legacy mode + undef, # Subref, unused in legacy mode. + @args + ); +} + +# This version of _write_invocation is used internally. It's not +# recommended you call it from external code, as the interface WILL +# change in the future. + +sub _write_invocation { + + my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_; + + if (@argvs == 1) { # No optional arguments + + my @argv = @{$argvs[0]}; + shift @argv; + + return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); + + } else { + my $else = "\t"; + my (@out, @argv, $n); + while (@argvs) { + @argv = @{shift @argvs}; + $n = shift @argv; + + my $condition = "\@_ == $n"; + + if (@argv and $argv[-1] =~ /[#@]_/) { + # This argv ends with '@' in the prototype, so it matches + # any number of args >= the number of expressions in the + # argv. + $condition = "\@_ >= $n"; + } + + push @out, "${else}if ($condition) {\n"; + + $else = "\t} els"; + + push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv); + } + push @out, qq[ + } + die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments"; + ]; + + return join '', @out; + } +} + + +# This is a slim interface to ensure backward compatibility with +# anyone doing very foolish things with old versions of Fatal. + +sub one_invocation { + my ($core, $call, $name, $void, @argv) = @_; + + return Fatal->_one_invocation( + $core, $call, $name, $void, + undef, # Sub. Unused in back-compat mode. + 1, # Back-compat flag + undef, # Subref, unused in back-compat mode. + @argv + ); + +} + +# This is the internal interface that generates code. +# NOTE: This interface WILL change in the future. Please do not +# call this subroutine directly. + +# TODO: Whatever's calling this code has already looked up hints. Pass +# them in, rather than look them up a second time. + +sub _one_invocation { + my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_; + + + # If someone is calling us directly (a child class perhaps?) then + # they could try to mix void without enabling backwards + # compatibility. We just don't support this at all, so we gripe + # about it rather than doing something unwise. + + if ($void and not $back_compat) { + Carp::confess("Internal error: :void mode not supported with $class"); + } + + # @argv only contains the results of the in-built prototype + # function, and is therefore safe to interpolate in the + # code generators below. + + # TODO - The following clobbers context, but that's what the + # old Fatal did. Do we care? + + if ($back_compat) { + + # Use Fatal qw(system) will never be supported. It generated + # a compile-time error with legacy Fatal, and there's no reason + # to support it when autodie does a better job. + + if ($call eq 'CORE::system') { + return q{ + croak("UNIMPLEMENTED: use Fatal qw(system) not supported."); + }; + } + + local $" = ', '; + + if ($void) { + return qq/return (defined wantarray)?$call(@argv): + $call(@argv) || Carp::croak("Can't $name(\@_)/ . + ($core ? ': $!' : ', \$! is \"$!\"') . '")' + } else { + return qq{return $call(@argv) || Carp::croak("Can't $name(\@_)} . + ($core ? ': $!' : ', \$! is \"$!\"') . '")'; + } + } + + # The name of our original function is: + # $call if the function is CORE + # $sub if our function is non-CORE + + # The reason for this is that $call is what we're actually + # calling. For our core functions, this is always + # CORE::something. However for user-defined subs, we're about to + # replace whatever it is that we're calling; as such, we actually + # calling a subroutine ref. + + my $human_sub_name = $core ? $call : $sub; + + # Should we be testing to see if our result is defined, or + # just true? + + my $use_defined_or; + + my $hints; # All user-sub hints, including list hints. + + if ( $core ) { + + # Core hints are built into autodie. + + $use_defined_or = exists ( $Use_defined_or{$call} ); + + } + else { + + # User sub hints are looked up using autodie::hints, + # since users may wish to add their own hints. + + require autodie::hints; + + $hints = autodie::hints->get_hints_for( $sref ); + + # We'll look up the sub's fullname. This means we + # get better reports of where it came from in our + # error messages, rather than what imported it. + + $human_sub_name = autodie::hints->sub_fullname( $sref ); + + } + + # Checks for special core subs. + + if ($call eq 'CORE::system') { + + # Leverage IPC::System::Simple if we're making an autodying + # system. + + local $" = ", "; + + # We need to stash $@ into $E, rather than using + # local $@ for the whole sub. If we don't then + # any exceptions from internal errors in autodie/Fatal + # will mysteriously disappear before propagating + # upwards. + + return qq{ + my \$retval; + my \$E; + + + { + local \$@; + + eval { + \$retval = IPC::System::Simple::system(@argv); + }; + + \$E = \$@; + } + + if (\$E) { + + # TODO - This can't be overridden in child + # classes! + + die autodie::exception::system->new( + function => q{CORE::system}, args => [ @argv ], + message => "\$E", errno => \$!, + ); + } + + return \$retval; + }; + + } + + local $" = ', '; + + # If we're going to throw an exception, here's the code to use. + my $die = qq{ + die $class->throw( + function => q{$human_sub_name}, args => [ @argv ], + pragma => q{$class}, errno => \$!, + context => \$context, return => \$retval, + eval_error => \$@ + ) + }; + + if ($call eq 'CORE::flock') { + + # flock needs special treatment. When it fails with + # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just + # means we couldn't get the lock right now. + + require POSIX; # For POSIX::EWOULDBLOCK + + local $@; # Don't blat anyone else's $@. + + # Ensure that our vendor supports EWOULDBLOCK. If they + # don't (eg, Windows), then we use known values for its + # equivalent on other systems. + + my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); } + || $_EWOULDBLOCK{$^O} + || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system."); + my $EAGAIN = $EWOULDBLOCK; + if ($try_EAGAIN) { + $EAGAIN = eval { POSIX::EAGAIN(); } + || _autocroak("Internal error - can't overload flock - EAGAIN not defined on this system."); + } + + require Fcntl; # For Fcntl::LOCK_NB + + return qq{ + + my \$context = wantarray() ? "list" : "scalar"; + + # Try to flock. If successful, return it immediately. + + my \$retval = $call(@argv); + return \$retval if \$retval; + + # If we failed, but we're using LOCK_NB and + # returned EWOULDBLOCK, it's not a real error. + + if (\$_[1] & Fcntl::LOCK_NB() and + (\$! == $EWOULDBLOCK or + ($try_EAGAIN and \$! == $EAGAIN ))) { + return \$retval; + } + + # Otherwise, we failed. Die noisily. + + $die; + + }; + } + + if (exists $Returns_num_things_changed{$call}) { + + # Some things return the number of things changed (like + # chown, kill, chmod, etc). We only consider these successful + # if *all* the things are changed. + + return qq[ + my \$num_things = \@_ - $Returns_num_things_changed{$call}; + my \$retval = $call(@argv); + + if (\$retval != \$num_things) { + + # We need \$context to throw an exception. + # It's *always* set to scalar, because that's how + # autodie calls chown() above. + + my \$context = "scalar"; + $die; + } + + return \$retval; + ]; + } + + # AFAIK everything that can be given an unopned filehandle + # will fail if it tries to use it, so we don't really need + # the 'unopened' warning class here. Especially since they + # then report the wrong line number. + + # Other warnings are disabled because they produce excessive + # complaints from smart-match hints under 5.10.1. + + my $code = qq[ + no warnings qw(unopened uninitialized numeric); + no if \$\] >= 5.017011, warnings => "experimental::smartmatch"; + + if (wantarray) { + my \@results = $call(@argv); + my \$retval = \\\@results; + my \$context = "list"; + + ]; + + my $retval_action = $Retval_action{$call} || ''; + + if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) { + + # NB: Subroutine hints are passed as a full list. + # This differs from the 5.10.0 smart-match behaviour, + # but means that context unaware subroutines can use + # the same hints in both list and scalar context. + + $code .= qq{ + if ( \$hints->{list}->(\@results) ) { $die }; + }; + } + elsif ( PERL510 and $hints ) { + $code .= qq{ + if ( \@results ~~ \$hints->{list} ) { $die }; + }; + } + elsif ( $hints ) { + croak sprintf(ERROR_58_HINTS, 'list', $sub); + } + else { + $code .= qq{ + # An empty list, or a single undef is failure + if (! \@results or (\@results == 1 and ! defined \$results[0])) { + $die; + } + } + } + + # Tidy up the end of our wantarray call. + + $code .= qq[ + return \@results; + } + ]; + + + # Otherwise, we're in scalar context. + # We're never in a void context, since we have to look + # at the result. + + $code .= qq{ + my \$retval = $call(@argv); + my \$context = "scalar"; + }; + + if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) { + + # We always call code refs directly, since that always + # works in 5.8.x, and always works in 5.10.1 + + return $code .= qq{ + if ( \$hints->{scalar}->(\$retval) ) { $die }; + $retval_action + return \$retval; + }; + + } + elsif (PERL510 and $hints) { + return $code . qq{ + + if ( \$retval ~~ \$hints->{scalar} ) { $die }; + $retval_action + return \$retval; + }; + } + elsif ( $hints ) { + croak sprintf(ERROR_58_HINTS, 'scalar', $sub); + } + + return $code . + ( $use_defined_or ? qq{ + + $die if not defined \$retval; + $retval_action + return \$retval; + + } : qq{ + + $retval_action + return \$retval || $die; + + } ) ; + +} + +# This returns the old copy of the sub, so we can +# put it back at end of scope. + +# TODO : Check to make sure prototypes are restored correctly. + +# TODO: Taking a huge list of arguments is awful. Rewriting to +# take a hash would be lovely. + +# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0 + +sub _make_fatal { + my($class, $sub, $pkg, $void, $lexical, $filename, $insist, $install_subs) = @_; + my($code, $sref, $proto, $core, $call, $hints, $cache, $cache_type); + my $ini = $sub; + my $name = $sub; + + + if (index($sub, '::') == -1) { + $sub = "${pkg}::$sub"; + if (substr($name, 0, 1) eq '&') { + $name = substr($name, 1); + } + } else { + $name =~ s/.*:://; + } + + + # Figure if we're using lexical or package semantics and + # twiddle the appropriate bits. + + if (not $lexical) { + $Package_Fatal{$sub} = 1; + } + + # TODO - We *should* be able to do skipping, since we know when + # we've lexicalised / unlexicalised a subroutine. + + + warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug; + croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/; + + if (defined(&$sub)) { # user subroutine + + # NOTE: Previously we would localise $@ at this point, so + # the following calls to eval {} wouldn't interfere with anything + # that's already in $@. Unfortunately, it would also stop + # any of our croaks from triggering(!), which is even worse. + + # This could be something that we've fatalised that + # was in core. + + # Store the current sub in case we need to restore it. + $sref = \&$sub; + + if ( $Package_Fatal{$sub} and exists($CORE_prototype_cache{"CORE::$name"})) { + + # Something we previously made Fatal that was core. + # This is safe to replace with an autodying to core + # version. + + $core = 1; + $call = "CORE::$name"; + $proto = $CORE_prototype_cache{$call}; + + # We return our $sref from this subroutine later + # on, indicating this subroutine should be placed + # back when we're finished. + + + + } else { + + # If this is something we've already fatalised or played with, + # then look-up the name of the original sub for the rest of + # our processing. + + if (exists($Is_fatalised_sub{$sref})) { + # $sub is one of our wrappers around a CORE sub or a + # user sub. Instead of wrapping our wrapper, lets just + # generate a new wrapper for the original sub. + # - NB: the current wrapper might be for a different class + # than the one we are generating now (e.g. some limited + # mixing between use Fatal + use autodie can occur). + # - Even for nested autodie, we need this as the leak guards + # differ. + my $s = $Is_fatalised_sub{$sref}; + if (defined($s)) { + # It is a wrapper for a user sub + $sub = $s; + } else { + # It is a wrapper for a CORE:: sub + $core = 1; + $call = "CORE::$name"; + $proto = $CORE_prototype_cache{$call}; + } + } + + # A regular user sub, or a user sub wrapping a + # core sub. + + if (!$core) { + # A non-CORE sub might have hints and such... + $proto = prototype($sref); + $call = '&$sref'; + require autodie::hints; + + $hints = autodie::hints->get_hints_for( $sref ); + + # If we've insisted on hints, but don't have them, then + # bail out! + + if ($insist and not $hints) { + croak(sprintf(ERROR_NOHINTS, $name)); + } + + # Otherwise, use the default hints if we don't have + # any. + + $hints ||= autodie::hints::DEFAULT_HINTS(); + } + + } + + } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) { + # Stray user subroutine + croak(sprintf(ERROR_NOTSUB,$sub)); + + } elsif ($name eq 'system') { + + # If we're fatalising system, then we need to load + # helper code. + + # The business with $E is to avoid clobbering our caller's + # $@, and to avoid $@ being localised when we croak. + + my $E; + + { + local $@; + + eval { + require IPC::System::Simple; # Only load it if we need it. + require autodie::exception::system; + }; + $E = $@; + } + + if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; } + + # Make sure we're using a recent version of ISS that actually + # support fatalised system. + if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) { + croak sprintf( + ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER, + $IPC::System::Simple::VERSION + ); + } + + $call = 'CORE::system'; + $core = 1; + + } elsif ($name eq 'exec') { + # Exec doesn't have a prototype. We don't care. This + # breaks the exotic form with lexical scope, and gives + # the regular form a "do or die" behavior as expected. + + $call = 'CORE::exec'; + $core = 1; + + } else { # CORE subroutine + $call = "CORE::$name"; + if (exists($CORE_prototype_cache{$call})) { + $proto = $CORE_prototype_cache{$call}; + } else { + my $E; + { + local $@; + $proto = eval { prototype $call }; + $E = $@; + } + croak(sprintf(ERROR_NOT_BUILT,$name)) if $E; + croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto; + $CORE_prototype_cache{$call} = $proto; + } + $core = 1; + } + + # TODO: This caching works, but I don't like using $void and + # $lexical as keys. In particular, I suspect our code may end up + # wrapping already wrapped code when autodie and Fatal are used + # together. + + # NB: We must use '$sub' (the name plus package) and not + # just '$name' (the short name) here. Failing to do so + # results code that's in the wrong package, and hence has + # access to the wrong package filehandles. + + $cache = $Cached_fatalised_sub{$class}{$sub}; + if ($lexical) { + $cache_type = CACHE_AUTODIE_LEAK_GUARD; + } else { + $cache_type = CACHE_FATAL_WRAPPER; + $cache_type = CACHE_FATAL_VOID if $void; + } + + if (my $subref = $cache->{$cache_type}) { + $install_subs->{$name} = $subref; + return $sref; + } + + # If our subroutine is reusable (ie, not package depdendent), + # then check to see if we've got a cached copy, and use that. + # See RT #46984. (Thanks to Niels Thykier for being awesome!) + + if ($core && exists $reusable_builtins{$call}) { + # For non-lexical subs, we can just use this cache directly + # - for lexical variants, we need a leak guard as well. + $code = $reusable_builtins{$call}{$lexical}; + if (!$lexical && defined($code)) { + $install_subs->{$name} = $code; + return $sref; + } + } + + if (!($lexical && $core) && !defined($code)) { + # No code available, generate it now. + my $wrapper_pkg = $pkg; + $wrapper_pkg = undef if (exists($reusable_builtins{$call})); + $code = $class->_compile_wrapper($wrapper_pkg, $core, $call, $name, + $void, $lexical, $sub, $sref, + $hints, $proto); + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + + # Now we need to wrap our fatalised sub inside an itty bitty + # closure, which can detect if we've leaked into another file. + # Luckily, we only need to do this for lexical (autodie) + # subs. Fatal subs can leak all they want, it's considered + # a "feature" (or at least backwards compatible). + + # TODO: Cache our leak guards! + + # TODO: This is pretty hairy code. A lot more tests would + # be really nice for this. + + my $installed_sub = $code; + + if ($lexical) { + $installed_sub = $class->_make_leak_guard($filename, $code, $sref, $call, + $pkg, $proto); + } + + $cache->{$cache_type} = $code; + + $install_subs->{$name} = $installed_sub; + + # Cache that we've now overridden this sub. If we get called + # again, we may need to find that find subroutine again (eg, for hints). + + $Is_fatalised_sub{$installed_sub} = $sref; + + return $sref; + +} + +# This subroutine exists primarily so that child classes can override +# it to point to their own exception class. Doing this is significantly +# less complex than overriding throw() + +sub exception_class { return "autodie::exception" }; + +{ + my %exception_class_for; + my %class_loaded; + + sub throw { + my ($class, @args) = @_; + + # Find our exception class if we need it. + my $exception_class = + $exception_class_for{$class} ||= $class->exception_class; + + if (not $class_loaded{$exception_class}) { + if ($exception_class =~ /[^\w:']/) { + confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons."; + } + + # Alas, Perl does turn barewords into modules unless they're + # actually barewords. As such, we're left doing a string eval + # to make sure we load our file correctly. + + my $E; + + { + local $@; # We can't clobber $@, it's wrong! + my $pm_file = $exception_class . ".pm"; + $pm_file =~ s{ (?: :: | ' ) }{/}gx; + eval { require $pm_file }; + $E = $@; # Save $E despite ending our local. + } + + # We need quotes around $@ to make sure it's stringified + # while still in scope. Without them, we run the risk of + # $@ having been cleared by us exiting the local() block. + + confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E; + + $class_loaded{$exception_class}++; + + } + + return $exception_class->new(@args); + } +} + +# Creates and returns a leak guard (with prototype if needed). +sub _make_leak_guard { + my ($class, $filename, $wrapped_sub, $orig_sub, $call, $pkg, $proto) = @_; + + # The leak guard is rather lengthly (in fact it makes up the most + # of _make_leak_guard). It is possible to split it into a large + # "generic" part and a small wrapper with call-specific + # information. This was done in v2.19 and profiling suggested + # that we ended up using a substantial amount of runtime in "goto" + # between the leak guard(s) and the final sub. Therefore, the two + # parts were merged into one to reduce the runtime overhead. + + my $leak_guard = sub { + my $caller_level = 0; + my $caller; + + while ( ($caller = (caller $caller_level)[1]) =~ m{^\(eval \d+\)$} ) { + + # If our filename is actually an eval, and we + # reach it, then go to our autodying code immediatately. + + last if ($caller eq $filename); + $caller_level++; + } + + # We're now out of the eval stack. + + if ($caller eq $filename) { + # No leak, call the wrapper. NB: In this case, it doesn't + # matter if it is a CORE sub or not. + if (!defined($wrapped_sub)) { + # CORE sub that we were too lazy to compile when we + # created this leak guard. + die "$call is not CORE::" + if substr($call, 0, 6) ne 'CORE::'; + + my $name = substr($call, 6); + my $sub = $name; + my $lexical = 1; + my $wrapper_pkg = $pkg; + my $code; + if (exists($reusable_builtins{$call})) { + $code = $reusable_builtins{$call}{$lexical}; + $wrapper_pkg = undef; + } + if (!defined($code)) { + $code = $class->_compile_wrapper($wrapper_pkg, + 1, # core + $call, + $name, + 0, # void + $lexical, + $sub, + undef, # subref (not used for core) + undef, # hints (not used for core) + $proto); + + if (!defined($wrapper_pkg)) { + # cache it so we don't recompile this part again + $reusable_builtins{$call}{$lexical} = $code; + } + } + # As $wrapped_sub is "closed over", updating its value will + # be "remembered" for the next call. + $wrapped_sub = $code; + } + goto $wrapped_sub; + } + + # We leaked, time to call the original function. + # - for non-core functions that will be $orig_sub + # - for CORE functions, $orig_sub may be a trampoline + goto $orig_sub if defined($orig_sub); + + # We are wrapping a CORE sub and we do not have a trampoline + # yet. + # + # If we've cached a trampoline, then use it. Usually only + # resuable subs will have cache hits, but non-reusuably ones + # can get it as well in (very) rare cases. It is mostly in + # cases where a package uses autodie multiple times and leaks + # from multiple places. Possibly something like: + # + # package Pkg::With::LeakyCode; + # sub a { + # use autodie; + # code_that_leaks(); + # } + # + # sub b { + # use autodie; + # more_leaky_code(); + # } + # + # Note that we use "Fatal" as package name for reusable subs + # because A) that allows us to trivially re-use the + # trampolines as well and B) because the reusable sub is + # compiled into "package Fatal" as well. + + $pkg = 'Fatal' if exists $reusable_builtins{$call}; + $orig_sub = $Trampoline_cache{$pkg}{$call}; + + if (not $orig_sub) { + # If we don't have a trampoline, we need to build it. + # + # We only generate trampolines when we need them, and + # we can cache them by subroutine + package. + # + # As $orig_sub is "closed over", updating its value will + # be "remembered" for the next call. + + $orig_sub = make_core_trampoline($call, $pkg, $proto); + + # We still cache it despite remembering it in $orig_sub as + # well. In particularly, we rely on this to avoid + # re-compiling the reusable trampolines. + $Trampoline_cache{$pkg}{$call} = $orig_sub; + } + + # Bounce to our trampoline, which takes us to our core sub. + goto $orig_sub; + }; # <-- end of leak guard + + # If there is a prototype on the original sub, copy it to the leak + # guard. + if (defined $proto) { + # The "\&" may appear to be redundant but set_prototype + # croaks when it is removed. + set_prototype(\&$leak_guard, $proto); + } + + return $leak_guard; +} + +sub _compile_wrapper { + my ($class, $wrapper_pkg, $core, $call, $name, $void, $lexical, $sub, $sref, $hints, $proto) = @_; + my $real_proto = ''; + my @protos; + my $code; + if (defined $proto) { + $real_proto = " ($proto)"; + } else { + $proto = '@'; + } + + @protos = fill_protos($proto); + $code = qq[ + sub$real_proto { + ]; + + if (!$lexical) { + $code .= q[ + local($", $!) = (', ', 0); + ]; + } + + # Don't have perl whine if exec fails, since we'll be handling + # the exception now. + $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec"; + + $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, + $sub, $sref, @protos); + $code .= "}\n"; + warn $code if $Debug; + + # I thought that changing package was a monumental waste of + # time for CORE subs, since they'll always be the same. However + # that's not the case, since they may refer to package-based + # filehandles (eg, with open). + # + # The %reusable_builtins hash defines ones we can aggressively + # cache as they never depend upon package-based symbols. + + my $E; + + { + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + local $@; + if (defined($wrapper_pkg)) { + $code = eval("package $wrapper_pkg; require Carp; $code"); ## no critic + } else { + $code = eval("require Carp; $code"); ## no critic + + } + $E = $@; + } + + if (not $code) { + my $true_name = $core ? $call : $sub; + croak("Internal error in autodie/Fatal processing $true_name: $E"); + } + return $code; +} + +# For some reason, dying while replacing our subs doesn't +# kill our calling program. It simply stops the loading of +# autodie and keeps going with everything else. The _autocroak +# sub allows us to die with a vengeance. It should *only* ever be +# used for serious internal errors, since the results of it can't +# be captured. + +sub _autocroak { + warn Carp::longmess(@_); + exit(255); # Ugh! +} + +1; + +__END__ + + +require 5.004; +package Test; + +use strict; + +use Carp; +our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, $ntest, $TestLevel); #public-is +our ($TESTOUT, $TESTERR, %Program_Lines, $told_about_diff, + $ONFAIL, %todo, %history, $planned, @FAILDETAIL); #private-ish + +# In case a test is run in a persistent environment. +sub _reset_globals { + %todo = (); + %history = (); + @FAILDETAIL = (); + $ntest = 1; + $TestLevel = 0; # how many extra stack frames to skip + $planned = 0; +} + +$VERSION = '1.31'; +require Exporter; +@ISA=('Exporter'); + +@EXPORT = qw(&plan &ok &skip); +@EXPORT_OK = qw($ntest $TESTOUT $TESTERR); + +$|=1; +$TESTOUT = *STDOUT{IO}; +$TESTERR = *STDERR{IO}; + +# Use of this variable is strongly discouraged. It is set mainly to +# help test coverage analyzers know which test is running. +$ENV{REGRESSION_TEST} = $0; + + + +sub plan { + croak "Test::plan(%args): odd number of arguments" if @_ & 1; + croak "Test::plan(): should not be called more than once" if $planned; + + local($\, $,); # guard against -l and other things that screw with + # print + + _reset_globals(); + + _read_program( (caller)[1] ); + + my $max=0; + while (@_) { + my ($k,$v) = splice(@_, 0, 2); + if ($k =~ /^test(s)?$/) { $max = $v; } + elsif ($k eq 'todo' or + $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } + elsif ($k eq 'onfail') { + ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; + $ONFAIL = $v; + } + else { carp "Test::plan(): skipping unrecognized directive '$k'" } + } + my @todo = sort { $a <=> $b } keys %todo; + if (@todo) { + print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; + } else { + print $TESTOUT "1..$max\n"; + } + ++$planned; + print $TESTOUT "# Running under perl version $] for $^O", + (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n"; + + print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n" + if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber(); + + print $TESTOUT "# MacPerl version $MacPerl::Version\n" + if defined $MacPerl::Version; + + printf $TESTOUT + "# Current time local: %s\n# Current time GMT: %s\n", + scalar(localtime($^T)), scalar(gmtime($^T)); + + print $TESTOUT "# Using Test.pm version $VERSION\n"; + + # Retval never used: + return undef; +} + +sub _read_program { + my($file) = shift; + return unless defined $file and length $file + and -e $file and -f _ and -r _; + open(SOURCEFILE, '<', $file) || return; + $Program_Lines{$file} = []; + close(SOURCEFILE); + + foreach my $x (@{$Program_Lines{$file}}) + { $x =~ tr/\cm\cj\n\r//d } + + unshift @{$Program_Lines{$file}}, ''; + return 1; +} + + +sub _to_value { + my ($v) = @_; + return ref $v eq 'CODE' ? $v->() : $v; +} + +sub _quote { + my $str = $_[0]; + return "" unless defined $str; + $str =~ s/\\/\\\\/g; + $str =~ s/"/\\"/g; + $str =~ s/\a/\\a/g; + $str =~ s/[\b]/\\b/g; + $str =~ s/\e/\\e/g; + $str =~ s/\f/\\f/g; + $str =~ s/\n/\\n/g; + $str =~ s/\r/\\r/g; + $str =~ s/\t/\\t/g; + if (defined $^V && $^V ge v5.6) { + $str =~ s/([[:cntrl:]])(?!\d)/sprintf('\\%o',ord($1))/eg; + $str =~ s/([[:^print:]])/sprintf('\\x%02X',ord($1))/eg; + $str =~ s/([[:^ascii:]])/sprintf('\\x{%X}',ord($1))/eg; + } + elsif (ord("A") == 65) { + $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; + $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; + $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg; + } + else { # Assuming EBCDIC on this ancient Perl + + # The controls except for one are 0-\077, so almost all controls on + # EBCDIC platforms will be expressed in octal, instead of just the C0 + # ones. + $str =~ s/([\0-\077])(?!\d)/sprintf('\\%o',ord($1))/eg; + $str =~ s/([\0-\077])/sprintf('\\x%02X',ord($1))/eg; + + $str =~ s/([^\0-\xFF])/sprintf('\\x{%X}',ord($1))/eg; + + # What remains to be escaped are the non-ASCII-range characters, + # including the one control that isn't in the 0-077 range. + # (We don't escape further any ASCII printables.) + $str =~ s<[^ !"\$\%#'()*+,\-./0123456789:;\<=\>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~]>eg; + } + #if( $_[1] ) { + # substr( $str , 218-3 ) = "..." + # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC}; + #} + return qq("$str"); +} + + + +# A past maintainer of this module said: +# <> +# + +sub ok ($;$$) { + croak "ok: plan before you test!" if !$planned; + + local($\,$,); # guard against -l and other things that screw with + # print + + my ($pkg,$file,$line) = caller($TestLevel); + my $repetition = ++$history{"$file:$line"}; + my $context = ("$file at line $line". + ($repetition > 1 ? " fail \#$repetition" : '')); + + # Are we comparing two values? + my $compare = 0; + + my $ok=0; + my $result = _to_value(shift); + my ($expected, $isregex, $regex); + if (@_ == 0) { + $ok = $result; + } else { + $compare = 1; + $expected = _to_value(shift); + if (!defined $expected) { + $ok = !defined $result; + } elsif (!defined $result) { + $ok = 0; + } elsif (ref($expected) eq 'Regexp') { + $ok = $result =~ /$expected/; + $regex = $expected; + } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or + (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { + $ok = $result =~ /$regex/; + } else { + $ok = $result eq $expected; + } + } + my $todo = $todo{$ntest}; + if ($todo and $ok) { + $context .= ' TODO?!' if $todo; + print $TESTOUT "ok $ntest # ($context)\n"; + } else { + # Issuing two seperate prints() causes problems on VMS. + if (!$ok) { + print $TESTOUT "not ok $ntest\n"; + } + else { + print $TESTOUT "ok $ntest\n"; + } + + $ok or _complain($result, $expected, + { + 'repetition' => $repetition, 'package' => $pkg, + 'result' => $result, 'todo' => $todo, + 'file' => $file, 'line' => $line, + 'context' => $context, 'compare' => $compare, + @_ ? ('diagnostic' => _to_value(shift)) : (), + }); + + } + ++ $ntest; + $ok; +} + + +sub _complain { + my($result, $expected, $detail) = @_; + $$detail{expected} = $expected if defined $expected; + + # Get the user's diagnostic, protecting against multi-line + # diagnostics. + my $diag = $$detail{diagnostic}; + $diag =~ s/\n/\n#/g if defined $diag; + + my $out = $$detail{todo} ? $TESTOUT : $TESTERR; + $$detail{context} .= ' *TODO*' if $$detail{todo}; + if (!$$detail{compare}) { + if (!$diag) { + print $out "# Failed test $ntest in $$detail{context}\n"; + } else { + print $out "# Failed test $ntest in $$detail{context}: $diag\n"; + } + } else { + my $prefix = "Test $ntest"; + + print $out "# $prefix got: " . _quote($result) . + " ($$detail{context})\n"; + $prefix = ' ' x (length($prefix) - 5); + my $expected_quoted = (defined $$detail{regex}) + ? 'qr{'.($$detail{regex}).'}' : _quote($expected); + + print $out "# $prefix Expected: $expected_quoted", + $diag ? " ($diag)" : (), "\n"; + + _diff_complain( $result, $expected, $detail, $prefix ) + if defined($expected) and 2 < ($expected =~ tr/\n//); + } + + if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) { + print $out + "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n" + if $Program_Lines{ $$detail{file} }[ $$detail{line} ] + =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative + + undef $Program_Lines{ $$detail{file} }[ $$detail{line} ]; + # So we won't repeat it. + } + + push @FAILDETAIL, $detail; + return; +} + + + +sub _diff_complain { + my($result, $expected, $detail, $prefix) = @_; + return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF}; + return _diff_complain_algdiff(@_) + if eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); + 1; + }; + + $told_about_diff++ or print $TESTERR <<"EOT"; +# $prefix (Install the Algorithm::Diff module to have differences in multiline +# $prefix output explained. You might also set the PERL_TEST_DIFF environment +# $prefix variable to run a diff program on the output.) +EOT + ; + return; +} + + + +sub _diff_complain_external { + my($result, $expected, $detail, $prefix) = @_; + my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?"; + + require File::Temp; + my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX"); + my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX"); + unless ($got_fh && $exp_fh) { + warn "Can't get tempfiles"; + return; + } + + print $got_fh $result; + print $exp_fh $expected; + if (close($got_fh) && close($exp_fh)) { + my $diff_cmd = "$diff $exp_filename $got_filename"; + print $TESTERR "#\n# $prefix $diff_cmd\n"; + if (open(DIFF, '-|', $diff_cmd)) { + local $_; + while () { + print $TESTERR "# $prefix $_"; + } + close(DIFF); + } + else { + warn "Can't run diff: $!"; + } + } else { + warn "Can't write to tempfiles: $!"; + } + unlink($got_filename); + unlink($exp_filename); + return; +} + + + +sub _diff_complain_algdiff { + my($result, $expected, $detail, $prefix) = @_; + + my @got = split(/^/, $result); + my @exp = split(/^/, $expected); + + my $diff_kind; + my @diff_lines; + + my $diff_flush = sub { + return unless $diff_kind; + + my $count_lines = @diff_lines; + my $s = $count_lines == 1 ? "" : "s"; + my $first_line = $diff_lines[0][0] + 1; + + print $TESTERR "# $prefix "; + if ($diff_kind eq "GOT") { + print $TESTERR "Got $count_lines extra line$s at line $first_line:\n"; + for my $i (@diff_lines) { + print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; + } + } elsif ($diff_kind eq "EXP") { + if ($count_lines > 1) { + my $last_line = $diff_lines[-1][0] + 1; + print $TESTERR "Lines $first_line-$last_line are"; + } + else { + print $TESTERR "Line $first_line is"; + } + print $TESTERR " missing:\n"; + for my $i (@diff_lines) { + print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; + } + } elsif ($diff_kind eq "CH") { + if ($count_lines > 1) { + my $last_line = $diff_lines[-1][0] + 1; + print $TESTERR "Lines $first_line-$last_line are"; + } + else { + print $TESTERR "Line $first_line is"; + } + print $TESTERR " changed:\n"; + for my $i (@diff_lines) { + print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; + print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; + } + } + + # reset + $diff_kind = undef; + @diff_lines = (); + }; + + my $diff_collect = sub { + my $kind = shift; + &$diff_flush() if $diff_kind && $diff_kind ne $kind; + $diff_kind = $kind; + push(@diff_lines, [@_]); + }; + + + Algorithm::Diff::traverse_balanced( + \@got, \@exp, + { + DISCARD_A => sub { &$diff_collect("GOT", @_) }, + DISCARD_B => sub { &$diff_collect("EXP", @_) }, + CHANGE => sub { &$diff_collect("CH", @_) }, + MATCH => sub { &$diff_flush() }, + }, + ); + &$diff_flush(); + + return; +} + + + + +#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~ + + + +sub skip ($;$$$) { + local($\, $,); # guard against -l and other things that screw with + # print + + my $whyskip = _to_value(shift); + if (!@_ or $whyskip) { + $whyskip = '' if $whyskip =~ m/^\d+$/; + $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old + # versions required the reason + # to start with 'skip' + # We print in one shot for VMSy reasons. + my $ok = "ok $ntest # skip"; + $ok .= " $whyskip" if length $whyskip; + $ok .= "\n"; + print $TESTOUT $ok; + ++ $ntest; + return 1; + } else { + # backwards compatibility (I think). skip() used to be + # called like ok(), which is weird. I haven't decided what to do with + # this yet. +# warn <(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; +} + +1; +__END__ + + +# "Your mistake was a hidden intention." +# -- /Oblique Strategies/, Brian Eno and Peter Schmidt +package NEXT; + +use Carp; +use strict; +use warnings; +use overload (); + +our $VERSION = '0.67_01'; + +sub NEXT::ELSEWHERE::ancestors +{ + my @inlist = shift; + my @outlist = (); + while (my $next = shift @inlist) { + push @outlist, $next; + no strict 'refs'; + unshift @inlist, @{"$outlist[-1]::ISA"}; + } + return @outlist; +} + +sub NEXT::ELSEWHERE::ordered_ancestors +{ + my @inlist = shift; + my @outlist = (); + while (my $next = shift @inlist) { + push @outlist, $next; + no strict 'refs'; + push @inlist, @{"$outlist[-1]::ISA"}; + } + return sort { $a->isa($b) ? -1 + : $b->isa($a) ? +1 + : 0 } @outlist; +} + +sub NEXT::ELSEWHERE::buildAUTOLOAD +{ + my $autoload_name = caller() . '::AUTOLOAD'; + + no strict 'refs'; + *{$autoload_name} = sub { + my ($self) = @_; + my $depth = 1; + until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ } + my $caller = (caller($depth))[3]; + my $wanted = $NEXT::AUTOLOAD || $autoload_name; + undef $NEXT::AUTOLOAD; + my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g }; + my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g }; + croak "Can't call $wanted from $caller" + unless $caller_method eq $wanted_method; + + my $key = ref $self && overload::Overloaded($self) + ? overload::StrVal($self) : $self; + + local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) = + ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN); + + unless ($NEXT::NEXT{$key,$wanted_method}) { + my @forebears = + NEXT::ELSEWHERE::ancestors ref $self || $self, + $wanted_class; + while (@forebears) { + last if shift @forebears eq $caller_class + } + no strict 'refs'; + # Use *{"..."} when first accessing the CODE slot, to make sure + # any typeglob stub is upgraded to a full typeglob. + @{$NEXT::NEXT{$key,$wanted_method}} = + map { + my $stash = \%{"${_}::"}; + ($stash->{$caller_method} && (*{"${_}::$caller_method"}{CODE})) + ? *{$stash->{$caller_method}}{CODE} + : () } @forebears + unless $wanted_method eq 'AUTOLOAD'; + @{$NEXT::NEXT{$key,$wanted_method}} = + map { + my $stash = \%{"${_}::"}; + ($stash->{AUTOLOAD} && (*{"${_}::AUTOLOAD"}{CODE})) + ? "${_}::AUTOLOAD" + : () } @forebears + unless @{$NEXT::NEXT{$key,$wanted_method}||[]}; + $NEXT::SEEN->{$key,*{$caller}{CODE}}++; + } + my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}}; + while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ } + && defined $call_method + && $NEXT::SEEN->{$key,$call_method}++) { + $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}}; + } + unless (defined $call_method) { + return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ }; + (local $Carp::CarpLevel)++; + croak qq(Can't locate object method "$wanted_method" ), + qq(via package "$caller_class"); + }; + return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE'; + no strict 'refs'; + do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// } + if $wanted_method eq 'AUTOLOAD'; + $$call_method = $caller_class."::NEXT::".$wanted_method; + return $call_method->(@_); + }; +} + +no strict 'vars'; +package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); +package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD(); + +package + EVERY; + +sub EVERY::ELSEWHERE::buildAUTOLOAD { + my $autoload_name = caller() . '::AUTOLOAD'; + + no strict 'refs'; + *{$autoload_name} = sub { + my ($self) = @_; + my $depth = 1; + until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ } + my $caller = (caller($depth))[3]; + my $wanted = $EVERY::AUTOLOAD || $autoload_name; + undef $EVERY::AUTOLOAD; + my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g }; + + my $key = ref($self) && overload::Overloaded($self) + ? overload::StrVal($self) : $self; + + local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} = + $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}; + + return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++; + + my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self, + $wanted_class; + @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ }; + no strict 'refs'; + my %seen; + my @every = map { my $sub = "${_}::$wanted_method"; + !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub + } @forebears + unless $wanted_method eq 'AUTOLOAD'; + + my $want = wantarray; + if (@every) { + if ($want) { + return map {($_, [$self->$_(@_[1..$#_])])} @every; + } + elsif (defined $want) { + return { map {($_, scalar($self->$_(@_[1..$#_])))} + @every + }; + } + else { + $self->$_(@_[1..$#_]) for @every; + return; + } + } + + @every = map { my $sub = "${_}::AUTOLOAD"; + !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD" + } @forebears; + if ($want) { + return map { $$_ = ref($self)."::EVERY::".$wanted_method; + ($_, [$self->$_(@_[1..$#_])]); + } @every; + } + elsif (defined $want) { + return { map { $$_ = ref($self)."::EVERY::".$wanted_method; + ($_, scalar($self->$_(@_[1..$#_]))) + } @every + }; + } + else { + for (@every) { + $$_ = ref($self)."::EVERY::".$wanted_method; + $self->$_(@_[1..$#_]); + } + return; + } + }; +} + +package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD(); +package + EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD(); + +1; + +__END__ + +# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- +# vim: ts=4 sts=4 sw=4: +use strict; +package CPAN; +$CPAN::VERSION = '2.20'; +$CPAN::VERSION =~ s/_//; + +# we need to run chdir all over and we would get at wrong libraries +# there +use File::Spec (); +BEGIN { + if (File::Spec->can("rel2abs")) { + for my $inc (@INC) { + $inc = File::Spec->rel2abs($inc) unless ref $inc; + } + } + $SIG{WINCH} = 'IGNORE' if exists $SIG{WINCH}; +} +use CPAN::Author; +use CPAN::HandleConfig; +use CPAN::Version; +use CPAN::Bundle; +use CPAN::CacheMgr; +use CPAN::Complete; +use CPAN::Debug; +use CPAN::Distribution; +use CPAN::Distrostatus; +use CPAN::FTP; +use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349 +use CPAN::InfoObj; +use CPAN::Module; +use CPAN::Prompt; +use CPAN::URL; +use CPAN::Queue; +use CPAN::Tarzip; +use CPAN::DeferredCode; +use CPAN::Shell; +use CPAN::LWP::UserAgent; +use CPAN::Exception::RecursiveDependency; +use CPAN::Exception::yaml_not_installed; +use CPAN::Exception::yaml_process_error; + +use Carp (); +use Config (); +use Cwd qw(chdir); +use DirHandle (); +use Exporter (); +use ExtUtils::MakeMaker qw(prompt); # for some unknown reason, + # 5.005_04 does not work without + # this +use File::Basename (); +use File::Copy (); +use File::Find; +use File::Path (); +use FileHandle (); +use Fcntl qw(:flock); +use Safe (); +use Sys::Hostname qw(hostname); +use Text::ParseWords (); +use Text::Wrap (); + +# protect against "called too early" +sub find_perl (); +sub anycwd (); +sub _uniq; + +no lib "."; + +require Mac::BuildTools if $^O eq 'MacOS'; +if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) { + $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING}; + my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$; + $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec; + # warn "# Note: Recursive call of CPAN.pm detected\n"; + my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec; + my %sleep = ( + 5 => 30, + 6 => 60, + 7 => 120, + ); + my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0); + my $verbose = @rec >= 4; + while (@rec) { + $w .= sprintf " which has been called by process %d", pop @rec; + } + if ($sleep) { + $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n"; + } + if ($verbose) { + warn $w; + } + local $| = 1; + while ($sleep > 0) { + printf "\r#%5d", --$sleep; + sleep 1; + } + print "\n"; +} +$ENV{PERL5_CPAN_IS_RUNNING}=$$; +$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735 + +END { $CPAN::End++; &cleanup; } + +$CPAN::Signal ||= 0; +$CPAN::Frontend ||= "CPAN::Shell"; +unless (@CPAN::Defaultsites) { + @CPAN::Defaultsites = map { + CPAN::URL->new(TEXT => $_, FROM => "DEF") + } + "http://www.perl.org/CPAN/", + "ftp://ftp.perl.org/pub/CPAN/"; +} +# $CPAN::iCwd (i for initial) +$CPAN::iCwd ||= CPAN::anycwd(); +$CPAN::Perl ||= CPAN::find_perl(); +$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?"; +$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf"; +$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml"; + +# our globals are getting a mess +use vars qw( + $AUTOLOAD + $Be_Silent + $CONFIG_DIRTY + $Defaultdocs + $Echo_readline + $Frontend + $GOTOSHELL + $HAS_USABLE + $Have_warned + $MAX_RECURSION + $META + $RUN_DEGRADED + $Signal + $SQLite + $Suppress_readline + $VERSION + $autoload_recursion + $term + @Defaultsites + @EXPORT + ); + +$MAX_RECURSION = 32; + +@CPAN::ISA = qw(CPAN::Debug Exporter); + +# note that these functions live in CPAN::Shell and get executed via +# AUTOLOAD when called directly +@EXPORT = qw( + autobundle + bundle + clean + cvs_import + expand + force + fforce + get + install + install_tested + is_tested + make + mkmyconfig + notest + perldoc + readme + recent + recompile + report + shell + smoke + test + upgrade + ); + +sub soft_chdir_with_alternatives ($); + +{ + $autoload_recursion ||= 0; + + #-> sub CPAN::AUTOLOAD ; + sub AUTOLOAD { ## no critic + $autoload_recursion++; + my($l) = $AUTOLOAD; + $l =~ s/.*:://; + if ($CPAN::Signal) { + warn "Refusing to autoload '$l' while signal pending"; + $autoload_recursion--; + return; + } + if ($autoload_recursion > 1) { + my $fullcommand = join " ", map { "'$_'" } $l, @_; + warn "Refusing to autoload $fullcommand in recursion\n"; + $autoload_recursion--; + return; + } + my(%export); + @export{@EXPORT} = ''; + CPAN::HandleConfig->load unless $CPAN::Config_loaded++; + if (exists $export{$l}) { + CPAN::Shell->$l(@_); + } else { + die(qq{Unknown CPAN command "$AUTOLOAD". }. + qq{Type ? for help.\n}); + } + $autoload_recursion--; + } +} + +{ + my $x = *SAVEOUT; # avoid warning + open($x,">&STDOUT") or die "dup failed"; + my $redir = 0; + sub _redirect(@) { + #die if $redir; + local $_; + push(@_,undef); + while(defined($_=shift)) { + if (s/^\s*>//){ + my ($m) = s/^>// ? ">" : ""; + s/\s+//; + $_=shift unless length; + die "no dest" unless defined; + open(STDOUT,">$m$_") or die "open:$_:$!\n"; + $redir=1; + } elsif ( s/^\s*\|\s*// ) { + my $pipe="| $_"; + while(defined($_[0])){ + $pipe .= ' ' . shift; + } + open(STDOUT,$pipe) or die "open:$pipe:$!\n"; + $redir=1; + } else { + push(@_,$_); + } + } + return @_; + } + sub _unredirect { + return unless $redir; + $redir = 0; + ## redirect: unredirect and propagate errors. explicit close to wait for pipe. + close(STDOUT); + open(STDOUT,">&SAVEOUT"); + die "$@" if "$@"; + ## redirect: done + } +} + +sub _uniq { + my(@list) = @_; + my %seen; + return grep { !$seen{$_}++ } @list; +} + +#-> sub CPAN::shell ; +sub shell { + my($self) = @_; + $Suppress_readline = ! -t STDIN unless defined $Suppress_readline; + CPAN::HandleConfig->load unless $CPAN::Config_loaded++; + + my $oprompt = shift || CPAN::Prompt->new; + my $prompt = $oprompt; + my $commandline = shift || ""; + $CPAN::CurrentCommandId ||= 1; + + local($^W) = 1; + unless ($Suppress_readline) { + require Term::ReadLine; + if (! $term + or + $term->ReadLine eq "Term::ReadLine::Stub" + ) { + $term = Term::ReadLine->new('CPAN Monitor'); + } + if ($term->ReadLine eq "Term::ReadLine::Gnu") { + my $attribs = $term->Attribs; + $attribs->{attempted_completion_function} = sub { + &CPAN::Complete::gnu_cpl; + } + } else { + $readline::rl_completion_function = + $readline::rl_completion_function = 'CPAN::Complete::cpl'; + } + if (my $histfile = $CPAN::Config->{'histfile'}) {{ + unless ($term->can("AddHistory")) { + $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n"); + last; + } + $META->readhist($term,$histfile); + }} + for ($CPAN::Config->{term_ornaments}) { # alias + local $Term::ReadLine::termcap_nowarn = 1; + $term->ornaments($_) if defined; + } + # $term->OUT is autoflushed anyway + my $odef = select STDERR; + $| = 1; + select STDOUT; + $| = 1; + select $odef; + } + + $META->checklock(); + my @cwd = grep { defined $_ and length $_ } + CPAN::anycwd(), + File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (), + File::Spec->rootdir(); + my $try_detect_readline; + $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term; + unless ($CPAN::Config->{inhibit_startup_message}) { + my $rl_avail = $Suppress_readline ? "suppressed" : + ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" : + "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)"; + $CPAN::Frontend->myprint( + sprintf qq{ +cpan shell -- CPAN exploration and modules installation (v%s) +Enter 'h' for help. + +}, + $CPAN::VERSION, + ) + } + my($continuation) = ""; + my $last_term_ornaments; + SHELLCOMMAND: while () { + if ($Suppress_readline) { + if ($Echo_readline) { + $|=1; + } + print $prompt; + last SHELLCOMMAND unless defined ($_ = <> ); + if ($Echo_readline) { + # backdoor: I could not find a way to record sessions + print $_; + } + chomp; + } else { + last SHELLCOMMAND unless + defined ($_ = $term->readline($prompt, $commandline)); + } + $_ = "$continuation$_" if $continuation; + s/^\s+//; + next SHELLCOMMAND if /^$/; + s/^\s*\?\s*/help /; + if (/^(?:q(?:uit)?|bye|exit)\s*$/i) { + last SHELLCOMMAND; + } elsif (s/\\$//s) { + chomp; + $continuation = $_; + $prompt = " > "; + } elsif (/^\!/) { + s/^\!//; + my($eval) = $_; + package + CPAN::Eval; # hide from the indexer + use strict; + use vars qw($import_done); + CPAN->import(':DEFAULT') unless $import_done++; + CPAN->debug("eval[$eval]") if $CPAN::DEBUG; + eval($eval); + warn $@ if $@; + $continuation = ""; + $prompt = $oprompt; + } elsif (/./) { + my(@line); + eval { @line = Text::ParseWords::shellwords($_) }; + warn($@), next SHELLCOMMAND if $@; + warn("Text::Parsewords could not parse the line [$_]"), + next SHELLCOMMAND unless @line; + $CPAN::META->debug("line[".join("|",@line)."]") if $CPAN::DEBUG; + my $command = shift @line; + eval { + local (*STDOUT)=*STDOUT; + @line = _redirect(@line); + CPAN::Shell->$command(@line) + }; + my $command_error = $@; + _unredirect; + my $reported_error; + if ($command_error) { + my $err = $command_error; + if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) { + $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err"); + $reported_error = ref $err; + } else { + # I'd prefer never to arrive here and make all errors exception objects + if ($err =~ /\S/) { + require Carp; + require Dumpvalue; + my $dv = Dumpvalue->new(tick => '"'); + Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err)); + } + } + } + if ($command =~ /^( + # classic commands + make + |test + |install + |clean + + # pragmas for classic commands + |ff?orce + |notest + + # compounds + |report + |smoke + |upgrade + )$/x) { + # only commands that tell us something about failed distros + # eval necessary for people without an urllist + eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);}; + if (my $err = $@) { + unless (ref $err and $reported_error eq ref $err) { + die $@; + } + } + } + soft_chdir_with_alternatives(\@cwd); + $CPAN::Frontend->myprint("\n"); + $continuation = ""; + $CPAN::CurrentCommandId++; + $prompt = $oprompt; + } + } continue { + $commandline = ""; # I do want to be able to pass a default to + # shell, but on the second command I see no + # use in that + $Signal=0; + CPAN::Queue->nullify_queue; + if ($try_detect_readline) { + if ($CPAN::META->has_inst("Term::ReadLine::Gnu") + || + $CPAN::META->has_inst("Term::ReadLine::Perl") + ) { + delete $INC{"Term/ReadLine.pm"}; + my $redef = 0; + local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef); + require Term::ReadLine; + $CPAN::Frontend->myprint("\n$redef subroutines in ". + "Term::ReadLine redefined\n"); + $GOTOSHELL = 1; + } + } + if ($term and $term->can("ornaments")) { + for ($CPAN::Config->{term_ornaments}) { # alias + if (defined $_) { + if (not defined $last_term_ornaments + or $_ != $last_term_ornaments + ) { + local $Term::ReadLine::termcap_nowarn = 1; + $term->ornaments($_); + $last_term_ornaments = $_; + } + } else { + undef $last_term_ornaments; + } + } + } + for my $class (qw(Module Distribution)) { + # again unsafe meta access? + for my $dm (sort keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) { + next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; + CPAN->debug("BUG: $class '$dm' was in command state, resetting"); + delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor}; + } + } + if ($GOTOSHELL) { + $GOTOSHELL = 0; # not too often + $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory"); + @_ = ($oprompt,""); + goto &shell; + } + } + soft_chdir_with_alternatives(\@cwd); +} + +#-> CPAN::soft_chdir_with_alternatives ; +sub soft_chdir_with_alternatives ($) { + my($cwd) = @_; + unless (@$cwd) { + my $root = File::Spec->rootdir(); + $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to! +Trying '$root' as temporary haven. +}); + push @$cwd, $root; + } + while () { + if (chdir $cwd->[0]) { + return; + } else { + if (@$cwd>1) { + $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $! +Trying to chdir to "$cwd->[1]" instead. +}); + shift @$cwd; + } else { + $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!}); + } + } + } +} + +sub _flock { + my($fh,$mode) = @_; + if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) { + return flock $fh, $mode; + } elsif (!$Have_warned->{"d_flock"}++) { + $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n"); + $CPAN::Frontend->mysleep(5); + return 1; + } else { + return 1; + } +} + +sub _yaml_module () { + my $yaml_module = $CPAN::Config->{yaml_module} || "YAML"; + if ( + $yaml_module ne "YAML" + && + !$CPAN::META->has_inst($yaml_module) + ) { + # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n"); + $yaml_module = "YAML"; + } + if ($yaml_module eq "YAML" + && + $CPAN::META->has_inst($yaml_module) + && + $YAML::VERSION < 0.60 + && + !$Have_warned->{"YAML"}++ + ) { + $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n". + "I'll continue but problems are *very* likely to happen.\n" + ); + $CPAN::Frontend->mysleep(5); + } + return $yaml_module; +} + +# CPAN::_yaml_loadfile +sub _yaml_loadfile { + my($self,$local_file) = @_; + return +[] unless -s $local_file; + my $yaml_module = _yaml_module; + if ($CPAN::META->has_inst($yaml_module)) { + # temporarily enable yaml code deserialisation + no strict 'refs'; + # 5.6.2 could not do the local() with the reference + # so we do it manually instead + my $old_loadcode = ${"$yaml_module\::LoadCode"}; + ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0; + + my ($code, @yaml); + if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) { + eval { @yaml = $code->($local_file); }; + if ($@) { + # this shall not be done by the frontend + die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); + } + } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) { + local *FH; + unless (open FH, $local_file) { + $CPAN::Frontend->mywarn("Could not open '$local_file': $!"); + return +[]; + } + local $/; + my $ystream = ; + eval { @yaml = $code->($ystream); }; + if ($@) { + # this shall not be done by the frontend + die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@); + } + } + ${"$yaml_module\::LoadCode"} = $old_loadcode; + return \@yaml; + } else { + # this shall not be done by the frontend + die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse"); + } + return +[]; +} + +# CPAN::_yaml_dumpfile +sub _yaml_dumpfile { + my($self,$local_file,@what) = @_; + my $yaml_module = _yaml_module; + if ($CPAN::META->has_inst($yaml_module)) { + my $code; + if (UNIVERSAL::isa($local_file, "FileHandle")) { + $code = UNIVERSAL::can($yaml_module, "Dump"); + eval { print $local_file $code->(@what) }; + } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) { + eval { $code->($local_file,@what); }; + } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) { + local *FH; + open FH, ">$local_file" or die "Could not open '$local_file': $!"; + print FH $code->(@what); + } + if ($@) { + die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@); + } + } else { + if (UNIVERSAL::isa($local_file, "FileHandle")) { + # I think this case does not justify a warning at all + } else { + die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump"); + } + } +} + +sub _init_sqlite () { + unless ($CPAN::META->has_inst("CPAN::SQLite")) { + $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n}) + unless $Have_warned->{"CPAN::SQLite"}++; + return; + } + require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17 + $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META); +} + +{ + my $negative_cache = {}; + sub _sqlite_running { + if ($negative_cache->{time} && time < $negative_cache->{time} + 60) { + # need to cache the result, otherwise too slow + return $negative_cache->{fact}; + } else { + $negative_cache = {}; # reset + } + my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite()); + return $ret if $ret; # fast anyway + $negative_cache->{time} = time; + return $negative_cache->{fact} = $ret; + } +} + +$META ||= CPAN->new; # In case we re-eval ourselves we need the || + +# from here on only subs. +################################################################################ + +sub _perl_fingerprint { + my($self,$other_fingerprint) = @_; + my $dll = eval {OS2::DLLname()}; + my $mtime_dll = 0; + if (defined $dll) { + $mtime_dll = (-f $dll ? (stat(_))[9] : '-1'); + } + my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1'); + my $this_fingerprint = { + '$^X' => CPAN::find_perl, + sitearchexp => $Config::Config{sitearchexp}, + 'mtime_$^X' => $mtime_perl, + 'mtime_dll' => $mtime_dll, + }; + if ($other_fingerprint) { + if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57 + $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9]; + } + # mandatory keys since 1.88_57 + for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) { + return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key}; + } + return 1; + } else { + return $this_fingerprint; + } +} + +sub suggest_myconfig () { + SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) { + $CPAN::Frontend->myprint("You don't seem to have a user ". + "configuration (MyConfig.pm) yet.\n"); + my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ". + "user configuration now? (Y/n)", + "yes"); + if($new =~ m{^y}i) { + CPAN::Shell->mkmyconfig(); + return &checklock; + } else { + $CPAN::Frontend->mydie("OK, giving up."); + } + } +} + +#-> sub CPAN::all_objects ; +sub all_objects { + my($mgr,$class) = @_; + CPAN::HandleConfig->load unless $CPAN::Config_loaded++; + CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG; + CPAN::Index->reload; + values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok +} + +# Called by shell, not in batch mode. In batch mode I see no risk in +# having many processes updating something as installations are +# continually checked at runtime. In shell mode I suspect it is +# unintentional to open more than one shell at a time + +#-> sub CPAN::checklock ; +sub checklock { + my($self) = @_; + my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock"); + if (-f $lockfile && -M _ > 0) { + my $fh = FileHandle->new($lockfile) or + $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!"); + my $otherpid = <$fh>; + my $otherhost = <$fh>; + $fh->close; + if (defined $otherpid && length $otherpid) { + chomp $otherpid; + } + if (defined $otherhost && length $otherhost) { + chomp $otherhost; + } + my $thishost = hostname(); + my $ask_if_degraded_wanted = 0; + if (defined $otherhost && defined $thishost && + $otherhost ne '' && $thishost ne '' && + $otherhost ne $thishost) { + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n". + "reports other host $otherhost and other ". + "process $otherpid.\n". + "Cannot proceed.\n")); + } elsif ($RUN_DEGRADED) { + $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n"); + } elsif (defined $otherpid && $otherpid) { + return if $$ == $otherpid; # should never happen + $CPAN::Frontend->mywarn( + qq{ +There seems to be running another CPAN process (pid $otherpid). Contacting... +}); + if (kill 0, $otherpid or $!{EPERM}) { + $CPAN::Frontend->mywarn(qq{Other job is running.\n}); + $ask_if_degraded_wanted = 1; + } elsif (-w $lockfile) { + my($ans) = + CPAN::Shell::colorable_makemaker_prompt + (qq{Other job not responding. Shall I overwrite }. + qq{the lockfile '$lockfile'? (Y/n)},"y"); + $CPAN::Frontend->myexit("Ok, bye\n") + unless $ans =~ /^y/i; + } else { + Carp::croak( + qq{Lockfile '$lockfile' not writable by you. }. + qq{Cannot proceed.\n}. + qq{ On UNIX try:\n}. + qq{ rm '$lockfile'\n}. + qq{ and then rerun us.\n} + ); + } + } elsif ($^O eq "MSWin32") { + $CPAN::Frontend->mywarn( + qq{ +There seems to be running another CPAN process according to '$lockfile'. +}); + $ask_if_degraded_wanted = 1; + } else { + $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ". + "'$lockfile', please remove. Cannot proceed.\n")); + } + if ($ask_if_degraded_wanted) { + my($ans) = + CPAN::Shell::colorable_makemaker_prompt + (qq{Shall I try to run in downgraded }. + qq{mode? (Y/n)},"y"); + if ($ans =~ /^y/i) { + $CPAN::Frontend->mywarn("Running in downgraded mode (experimental). +Please report if something unexpected happens\n"); + $RUN_DEGRADED = 1; + for ($CPAN::Config) { + # XXX + # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that? + $_->{commandnumber_in_prompt} = 0; # visibility + $_->{histfile} = ""; # who should win otherwise? + $_->{cache_metadata} = 0; # better would be a lock? + $_->{use_sqlite} = 0; # better would be a write lock! + $_->{auto_commit} = 0; # we are violent, do not persist + $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode + } + } else { + my $msg = "You may want to kill the other job and delete the lockfile."; + if (defined $otherpid) { + $msg .= " Something like: + kill $otherpid + rm $lockfile +"; + } + $CPAN::Frontend->mydie("\n$msg"); + } + } + } + my $dotcpan = $CPAN::Config->{cpan_home}; + eval { File::Path::mkpath($dotcpan);}; + if ($@) { + # A special case at least for Jarkko. + my $firsterror = $@; + my $seconderror; + my $symlinkcpan; + if (-l $dotcpan) { + $symlinkcpan = readlink $dotcpan; + die "readlink $dotcpan failed: $!" unless defined $symlinkcpan; + eval { File::Path::mkpath($symlinkcpan); }; + if ($@) { + $seconderror = $@; + } else { + $CPAN::Frontend->mywarn(qq{ +Working directory $symlinkcpan created. +}); + } + } + unless (-d $dotcpan) { + my $mess = qq{ +Your configuration suggests "$dotcpan" as your +CPAN.pm working directory. I could not create this directory due +to this error: $firsterror\n}; + $mess .= qq{ +As "$dotcpan" is a symlink to "$symlinkcpan", +I tried to create that, but I failed with this error: $seconderror +} if $seconderror; + $mess .= qq{ +Please make sure the directory exists and is writable. +}; + $CPAN::Frontend->mywarn($mess); + return suggest_myconfig; + } + } # $@ after eval mkpath $dotcpan + if (0) { # to test what happens when a race condition occurs + for (reverse 1..10) { + print $_, "\n"; + sleep 1; + } + } + # locking + if (!$RUN_DEGRADED && !$self->{LOCKFH}) { + my $fh; + unless ($fh = FileHandle->new("+>>$lockfile")) { + $CPAN::Frontend->mywarn(qq{ + +Your configuration suggests that CPAN.pm should use a working +directory of + $CPAN::Config->{cpan_home} +Unfortunately we could not create the lock file + $lockfile +due to '$!'. + +Please make sure that the configuration variable + \$CPAN::Config->{cpan_home} +points to a directory where you can write a .lock file. You can set +this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your +\@INC path; +}); + return suggest_myconfig; + } + my $sleep = 1; + while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) { + my $err = $! || "unknown error"; + if ($sleep>3) { + $CPAN::Frontend->mydie("Could not lock '$lockfile' with flock: $err; giving up\n"); + } + $CPAN::Frontend->mysleep($sleep+=0.1); + $CPAN::Frontend->mywarn("Could not lock '$lockfile' with flock: $err; retrying\n"); + } + + seek $fh, 0, 0; + truncate $fh, 0; + $fh->autoflush(1); + $fh->print($$, "\n"); + $fh->print(hostname(), "\n"); + $self->{LOCK} = $lockfile; + $self->{LOCKFH} = $fh; + } + $SIG{TERM} = sub { + my $sig = shift; + &cleanup; + $CPAN::Frontend->mydie("Got SIG$sig, leaving"); + }; + $SIG{INT} = sub { + # no blocks!!! + my $sig = shift; + &cleanup if $Signal; + die "Got yet another signal" if $Signal > 1; + $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal; + $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n"); + $Signal++; + }; + +# From: Larry Wall +# Subject: Re: deprecating SIGDIE +# To: perl5-porters@perl.org +# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT) +# +# The original intent of __DIE__ was only to allow you to substitute one +# kind of death for another on an application-wide basis without respect +# to whether you were in an eval or not. As a global backstop, it should +# not be used any more lightly (or any more heavily :-) than class +# UNIVERSAL. Any attempt to build a general exception model on it should +# be politely squashed. Any bug that causes every eval {} to have to be +# modified should be not so politely squashed. +# +# Those are my current opinions. It is also my opinion that polite +# arguments degenerate to personal arguments far too frequently, and that +# when they do, it's because both people wanted it to, or at least didn't +# sufficiently want it not to. +# +# Larry + + # global backstop to cleanup if we should really die + $SIG{__DIE__} = \&cleanup; + $self->debug("Signal handler set.") if $CPAN::DEBUG; +} + +#-> sub CPAN::DESTROY ; +sub DESTROY { + &cleanup; # need an eval? +} + +#-> sub CPAN::anycwd ; +sub anycwd () { + my $getcwd; + $getcwd = $CPAN::Config->{'getcwd'} || 'cwd'; + CPAN->$getcwd(); +} + +#-> sub CPAN::cwd ; +sub cwd {Cwd::cwd();} + +#-> sub CPAN::getcwd ; +sub getcwd {Cwd::getcwd();} + +#-> sub CPAN::fastcwd ; +sub fastcwd {Cwd::fastcwd();} + +#-> sub CPAN::getdcwd ; +sub getdcwd {Cwd::getdcwd();} + +#-> sub CPAN::backtickcwd ; +sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd} + +# Adapted from Probe::Perl +#-> sub CPAN::_perl_is_same +sub _perl_is_same { + my ($perl) = @_; + return MM->maybe_command($perl) + && `$perl -MConfig=myconfig -e print -e myconfig` eq Config->myconfig; +} + +# Adapted in part from Probe::Perl +#-> sub CPAN::find_perl ; +sub find_perl () { + if ( File::Spec->file_name_is_absolute($^X) ) { + return $^X; + } + else { + my $exe = $Config::Config{exe_ext}; + my @candidates = ( + File::Spec->catfile($CPAN::iCwd,$^X), + $Config::Config{'perlpath'}, + ); + for my $perl_name ($^X, 'perl', 'perl5', "perl$]") { + for my $path (File::Spec->path(), $Config::Config{'binexp'}) { + if ( defined($path) && length $path && -d $path ) { + my $perl = File::Spec->catfile($path,$perl_name); + push @candidates, $perl; + # try with extension if not provided already + if ($^O eq 'VMS') { + # VMS might have a file version at the end + push @candidates, $perl . $exe + unless $perl =~ m/$exe(;\d+)?$/i; + } elsif (defined $exe && length $exe) { + push @candidates, $perl . $exe + unless $perl =~ m/$exe$/i; + } + } + } + } + for my $perl ( @candidates ) { + if (MM->maybe_command($perl) && _perl_is_same($perl)) { + $^X = $perl; + return $perl; + } + } + } + return $^X; # default fall back +} + +#-> sub CPAN::exists ; +sub exists { + my($mgr,$class,$id) = @_; + CPAN::HandleConfig->load unless $CPAN::Config_loaded++; + CPAN::Index->reload; + ### Carp::croak "exists called without class argument" unless $class; + $id ||= ""; + $id =~ s/:+/::/g if $class eq "CPAN::Module"; + my $exists; + if (CPAN::_sqlite_running) { + $exists = (exists $META->{readonly}{$class}{$id} or + $CPAN::SQLite->set($class, $id)); + } else { + $exists = exists $META->{readonly}{$class}{$id}; + } + $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok +} + +#-> sub CPAN::delete ; +sub delete { + my($mgr,$class,$id) = @_; + delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok + delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok +} + +#-> sub CPAN::has_usable +# has_inst is sometimes too optimistic, we should replace it with this +# has_usable whenever a case is given +sub has_usable { + my($self,$mod,$message) = @_; + return 1 if $HAS_USABLE->{$mod}; + my $has_inst = $self->has_inst($mod,$message); + return unless $has_inst; + my $usable; + $usable = { + + # + # these subroutines die if they believe the installed version is unusable; + # + 'CPAN::Meta' => [ + sub { + require CPAN::Meta; + unless (CPAN::Version->vge(CPAN::Meta->VERSION, 2.110350)) { + for ("Will not use CPAN::Meta, need version 2.110350\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + + 'CPAN::Meta::Requirements' => [ + sub { + if (defined $CPAN::Meta::Requirements::VERSION + && CPAN::Version->vlt($CPAN::Meta::Requirements::VERSION, "2.120920") + ) { + delete $INC{"CPAN/Meta/Requirements.pm"}; + } + require CPAN::Meta::Requirements; + unless (CPAN::Version->vge(CPAN::Meta::Requirements->VERSION, 2.120920)) { + for ("Will not use CPAN::Meta::Requirements, need version 2.120920\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + + LWP => [ # we frequently had "Can't locate object + # method "new" via package "LWP::UserAgent" at + # (eval 69) line 2006 + sub {require LWP}, + sub {require LWP::UserAgent}, + sub {require HTTP::Request}, + sub {require URI::URL; + unless (CPAN::Version->vge(URI::URL::->VERSION,0.08)) { + for ("Will not use URI::URL, need 0.08\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + 'Net::FTP' => [ + sub { + my $var = $CPAN::Config->{ftp_proxy} || $ENV{ftp_proxy}; + if ($var and $var =~ /^http:/i) { + # rt #110833 + for ("Net::FTP cannot handle http proxy") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + sub {require Net::FTP}, + sub {require Net::Config}, + ], + 'HTTP::Tiny' => [ + sub { + require HTTP::Tiny; + unless (CPAN::Version->vge(HTTP::Tiny->VERSION, 0.005)) { + for ("Will not use HTTP::Tiny, need version 0.005\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + 'File::HomeDir' => [ + sub {require File::HomeDir; + unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) { + for ("Will not use File::HomeDir, need 0.52\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + 'Archive::Tar' => [ + sub {require Archive::Tar; + my $demand = "1.50"; + unless (CPAN::Version->vge(Archive::Tar::->VERSION, $demand)) { + my $atv = Archive::Tar->VERSION; + for ("You have Archive::Tar $atv, but $demand or later is recommended. Please upgrade.\n") { + $CPAN::Frontend->mywarn($_); + # don't die, because we may need + # Archive::Tar to upgrade + } + + } + }, + ], + 'File::Temp' => [ + # XXX we should probably delete from + # %INC too so we can load after we + # installed a new enough version -- + # I'm not sure. + sub {require File::Temp; + unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) { + for ("Will not use File::Temp, need 0.16\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ] + }; + if ($usable->{$mod}) { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + for my $c (0..$#{$usable->{$mod}}) { + my $code = $usable->{$mod}[$c]; + my $ret = eval { &$code() }; + $ret = "" unless defined $ret; + if ($@) { + # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]"; + return; + } + } + } + return $HAS_USABLE->{$mod} = 1; +} + +sub frontend { + shift; + $CPAN::Frontend = shift if @_; + $CPAN::Frontend; +} + +sub use_inst { + my ($self, $module) = @_; + + unless ($self->has_inst($module)) { + $self->frontend->mydie("$module not installed, cannot continue"); + } +} + +#-> sub CPAN::has_inst +sub has_inst { + my($self,$mod,$message) = @_; + Carp::croak("CPAN->has_inst() called without an argument") + unless defined $mod; + my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}}, + keys %{$CPAN::Config->{dontload_hash}||{}}, + @{$CPAN::Config->{dontload_list}||[]}; + if (defined $message && $message eq "no" # as far as I remember only used by Nox + || + $dont{$mod} + ) { + $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok + return 0; + } + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + my $file = $mod; + my $obj; + $file =~ s|::|/|g; + $file .= ".pm"; + if ($INC{$file}) { + # checking %INC is wrong, because $INC{LWP} may be true + # although $INC{"URI/URL.pm"} may have failed. But as + # I really want to say "blah loaded OK", I have to somehow + # cache results. + ### warn "$file in %INC"; #debug + return 1; + } elsif (eval { require $file }) { + # eval is good: if we haven't yet read the database it's + # perfect and if we have installed the module in the meantime, + # it tries again. The second require is only a NOOP returning + # 1 if we had success, otherwise it's retrying + + my $mtime = (stat $INC{$file})[9]; + # privileged files loaded by has_inst; Note: we use $mtime + # as a proxy for a checksum. + $CPAN::Shell::reload->{$file} = $mtime; + my $v = eval "\$$mod\::VERSION"; + $v = $v ? " (v$v)" : ""; + CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n"); + if ($mod eq "CPAN::WAIT") { + push @CPAN::Shell::ISA, 'CPAN::WAIT'; + } + return 1; + } elsif ($mod eq "Net::FTP") { + $CPAN::Frontend->mywarn(qq{ + Please, install Net::FTP as soon as possible. CPAN.pm installs it for you + if you just type + install Bundle::libnet + +}) unless $Have_warned->{"Net::FTP"}++; + $CPAN::Frontend->mysleep(3); + } elsif ($mod eq "Digest::SHA") { + if ($Have_warned->{"Digest::SHA"}++) { + $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }. + qq{because Digest::SHA not installed.\n}); + } else { + $CPAN::Frontend->mywarn(qq{ + CPAN: checksum security checks disabled because Digest::SHA not installed. + Please consider installing the Digest::SHA module. + +}); + $CPAN::Frontend->mysleep(2); + } + } elsif ($mod eq "Module::Signature") { + # NOT prefs_lookup, we are not a distro + my $check_sigs = $CPAN::Config->{check_sigs}; + if (not $check_sigs) { + # they do not want us:-( + } elsif (not $Have_warned->{"Module::Signature"}++) { + # No point in complaining unless the user can + # reasonably install and use it. + if (eval { require Crypt::OpenPGP; 1 } || + ( + defined $CPAN::Config->{'gpg'} + && + $CPAN::Config->{'gpg'} =~ /\S/ + ) + ) { + $CPAN::Frontend->mywarn(qq{ + CPAN: Module::Signature security checks disabled because Module::Signature + not installed. Please consider installing the Module::Signature module. + You may also need to be able to connect over the Internet to the public + key servers like pool.sks-keyservers.net or pgp.mit.edu. + +}); + $CPAN::Frontend->mysleep(2); + } + } + } else { + delete $INC{$file}; # if it inc'd LWP but failed during, say, URI + } + return 0; +} + +#-> sub CPAN::instance ; +sub instance { + my($mgr,$class,$id) = @_; + CPAN::Index->reload; + $id ||= ""; + # unsafe meta access, ok? + return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id}; + $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id); +} + +#-> sub CPAN::new ; +sub new { + bless {}, shift; +} + +#-> sub CPAN::_exit_messages ; +sub _exit_messages { + my ($self) = @_; + $self->{exit_messages} ||= []; +} + +#-> sub CPAN::cleanup ; +sub cleanup { + # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]"; + local $SIG{__DIE__} = ''; + my($message) = @_; + my $i = 0; + my $ineval = 0; + my($subroutine); + while ((undef,undef,undef,$subroutine) = caller(++$i)) { + $ineval = 1, last if + $subroutine eq '(eval)'; + } + return if $ineval && !$CPAN::End; + return unless defined $META->{LOCK}; + return unless -f $META->{LOCK}; + $META->savehist; + $META->{cachemgr} ||= CPAN::CacheMgr->new('atexit'); + close $META->{LOCKFH}; + unlink $META->{LOCK}; + # require Carp; + # Carp::cluck("DEBUGGING"); + if ( $CPAN::CONFIG_DIRTY ) { + $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n"); + } + $CPAN::Frontend->myprint("Lockfile removed.\n"); + for my $msg ( @{ $META->_exit_messages } ) { + $CPAN::Frontend->myprint($msg); + } +} + +#-> sub CPAN::readhist +sub readhist { + my($self,$term,$histfile) = @_; + my $histsize = $CPAN::Config->{'histsize'} || 100; + $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'})); + my($fh) = FileHandle->new; + open $fh, "<$histfile" or return; + local $/ = "\n"; + while (<$fh>) { + chomp; + $term->AddHistory($_); + } + close $fh; +} + +#-> sub CPAN::savehist +sub savehist { + my($self) = @_; + my($histfile,$histsize); + unless ($histfile = $CPAN::Config->{'histfile'}) { + $CPAN::Frontend->mywarn("No history written (no histfile specified).\n"); + return; + } + $histsize = $CPAN::Config->{'histsize'} || 100; + if ($CPAN::term) { + unless ($CPAN::term->can("GetHistory")) { + $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n"); + return; + } + } else { + return; + } + my @h = $CPAN::term->GetHistory; + splice @h, 0, @h-$histsize if @h>$histsize; + my($fh) = FileHandle->new; + open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!"); + local $\ = local $, = "\n"; + print $fh @h; + close $fh; +} + +#-> sub CPAN::is_tested +sub is_tested { + my($self,$what,$when) = @_; + unless ($what) { + Carp::cluck("DEBUG: empty what"); + return; + } + $self->{is_tested}{$what} = $when; +} + +#-> sub CPAN::reset_tested +# forget all distributions tested -- resets what gets included in PERL5LIB +sub reset_tested { + my ($self) = @_; + $self->{is_tested} = {}; +} + +#-> sub CPAN::is_installed +# unsets the is_tested flag: as soon as the thing is installed, it is +# not needed in set_perl5lib anymore +sub is_installed { + my($self,$what) = @_; + delete $self->{is_tested}{$what}; +} + +sub _list_sorted_descending_is_tested { + my($self) = @_; + my $foul = 0; + my @sorted = sort + { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) } + grep + { if ($foul){ 0 } elsif (-e) { 1 } else { $foul = $_; 0 } } + keys %{$self->{is_tested}}; + if ($foul) { + $CPAN::Frontend->mywarn("Lost build_dir detected ($foul), giving up all cached test results of currently running session.\n"); + for my $dbd (sort keys %{$self->{is_tested}}) { # distro-build-dir + SEARCH: for my $d (sort { $a->id cmp $b->id } $CPAN::META->all_objects("CPAN::Distribution")) { + if ($d->{build_dir} && $d->{build_dir} eq $dbd) { + $CPAN::Frontend->mywarn(sprintf "Flushing cache for %s\n", $d->pretty_id); + $d->fforce(""); + last SEARCH; + } + } + delete $self->{is_tested}{$dbd}; + } + return (); + } else { + return @sorted; + } +} + +#-> sub CPAN::set_perl5lib +# Notes on max environment variable length: +# - Win32 : XP or later, 8191; Win2000 or NT4, 2047 +{ +my $fh; +sub set_perl5lib { + my($self,$for) = @_; + unless ($for) { + (undef,undef,undef,$for) = caller(1); + $for =~ s/.*://; + } + $self->{is_tested} ||= {}; + return unless %{$self->{is_tested}}; + my $env = $ENV{PERL5LIB}; + $env = $ENV{PERLLIB} unless defined $env; + my @env; + push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env; + #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}}; + #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n"); + + my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested; + return if !@dirs; + + if (@dirs < 12) { + $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n"); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + } elsif (@dirs < 24 ) { + my @d = map {my $cp = $_; + $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/; + $cp + } @dirs; + $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ". + "%BUILDDIR%=$CPAN::Config->{build_dir} ". + "for '$for'\n" + ); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + } else { + my $cnt = keys %{$self->{is_tested}}; + $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ". + "$cnt build dirs to PERL5LIB; ". + "for '$for'\n" + ); + $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + } +}} + + +1; + + +__END__ + +package vmsish; + +our $VERSION = '1.04'; + + +my $IsVMS = $^O eq 'VMS'; + +sub bits { + my $bits = 0; + my $sememe; + foreach $sememe (@_) { + # Those hints are defined in vms/vmsish.h : + # HINT_M_VMSISH_STATUS and HINT_M_VMSISH_TIME + $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?'; + $bits |= 0x80000000, next if $sememe eq 'time'; + } + $bits; +} + +sub import { + return unless $IsVMS; + + shift; + $^H |= bits(@_ ? @_ : qw(status time)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit hushed)) { + $^H{'vmsish_exit'} = 1 if $sememe eq 'exit'; + vmsish::hushed(1) if $sememe eq 'hushed'; + } +} + +sub unimport { + return unless $IsVMS; + + shift; + $^H &= ~ bits(@_ ? @_ : qw(status time)); + my $sememe; + + foreach $sememe (@_ ? @_ : qw(exit hushed)) { + $^H{'vmsish_exit'} = 0 if $sememe eq 'exit'; + vmsish::hushed(0) if $sememe eq 'hushed'; + } +} + +1; +use 5.008; +package base; + +use strict 'vars'; +our $VERSION = '2.27'; +$VERSION =~ tr/_//d; + +# simplest way to avoid indexing of the package: no package statement +sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC } +# instance is blessed array of coderefs to be removed from @INC at scope exit +sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } + +# constant.pm is slow +sub SUCCESS () { 1 } + +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + + +my $Fattr = \%fields::attr; + +sub has_fields { + my($base) = shift; + my $fglob = ${"$base\::"}{FIELDS}; + return( ($fglob && 'GLOB' eq ref($fglob) && *$fglob{HASH}) ? 1 : 0 ); +} + +sub has_attr { + my($proto) = shift; + my($class) = ref $proto || $proto; + return exists $Fattr->{$class}; +} + +sub get_attr { + $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; + return $Fattr->{$_[0]}; +} + +if ($] < 5.009) { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + my $f = \%{$_[0].'::FIELDS'}; + + # should be centralized in fields? perhaps + # fields::mk_FIELDS_be_OK. Peh. As long as %{ $package . '::FIELDS' } + # is used here anyway, it doesn't matter. + bless $f, 'pseudohash' if (ref($f) ne 'pseudohash'); + + return $f; + } +} +else { + *get_fields = sub { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + return \%{$_[0].'::FIELDS'}; + } +} + +if ($] < 5.008) { + *_module_to_filename = sub { + (my $fn = $_[0]) =~ s!::!/!g; + $fn .= '.pm'; + return $fn; + } +} +else { + *_module_to_filename = sub { + (my $fn = $_[0]) =~ s!::!/!g; + $fn .= '.pm'; + utf8::encode($fn); + return $fn; + } +} + + +sub import { + my $class = shift; + + return SUCCESS unless @_; + + # List of base classes from which we will inherit %FIELDS. + my $fields_base; + + my $inheritor = caller(0); + + my @bases; + foreach my $base (@_) { + if ( $inheritor eq $base ) { + warn "Class '$inheritor' tried to inherit from itself\n"; + } + + next if grep $_->isa($base), ($inheritor, @bases); + + # Following blocks help isolate $SIG{__DIE__} and @INC changes + { + my $sigdie; + { + local $SIG{__DIE__}; + my $fn = _module_to_filename($base); + my $dot_hidden; + eval { + my $guard; + if ($INC[-1] eq '.' && %{"$base\::"}) { + # So: the package already exists => this an optional load + # And: there is a dot at the end of @INC => we want to hide it + # However: we only want to hide it during our *own* require() + # (i.e. without affecting nested require()s). + # So we add a hook to @INC whose job is to hide the dot, but which + # first checks checks the callstack depth, because within nested + # require()s the callstack is deeper. + # Since CORE::GLOBAL::require makes it unknowable in advance what + # the exact relevant callstack depth will be, we have to record it + # inside a hook. So we put another hook just for that at the front + # of @INC, where it's guaranteed to run -- immediately. + # The dot-hiding hook does its job by sitting directly in front of + # the dot and removing itself from @INC when reached. This causes + # the dot to move up one index in @INC, causing the loop inside + # pp_require() to skip it. + # Loaded coded may disturb this precise arrangement, but that's OK + # because the hook is inert by that time. It is only active during + # the top-level require(), when @INC is in our control. The only + # possible gotcha is if other hooks already in @INC modify @INC in + # some way during that initial require(). + # Note that this jiggery hookery works just fine recursively: if + # a module loaded via base.pm uses base.pm itself, there will be + # one pair of hooks in @INC per base::import call frame, but the + # pairs from different nestings do not interfere with each other. + my $lvl; + unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () }; + splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () }; + $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard'; + } + require $fn + }; + if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { + require Carp; + Carp::croak(<]*> (?:line|chunk) [0-9]+)?\.\n\z/s + || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/; + unless (%{"$base\::"}) { + require Carp; + local $" = " "; + Carp::croak(<[0] = @$battr; + + if( keys %$dfields ) { + warn <<"END"; +$derived is inheriting from $base but already has its own fields! +This will cause problems. Be sure you use base BEFORE declaring fields. +END + + } + + # Iterate through the base's fields adding all the non-private + # ones to the derived class. Hang on to the original attribute + # (Public, Private, etc...) and add Inherited. + # This is all too complicated to do efficiently with add_fields(). + while (my($k,$v) = each %$bfields) { + my $fno; + if ($fno = $dfields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited fields can't override existing fields"); + } + + if( $battr->[$v] & PRIVATE ) { + $dattr->[$v] = PRIVATE | INHERITED; + } + else { + $dattr->[$v] = INHERITED | $battr->[$v]; + $dfields->{$k} = $v; + } + } + + foreach my $idx (1..$#{$battr}) { + next if defined $dattr->[$idx]; + $dattr->[$idx] = $battr->[$idx] & INHERITED; + } +} + + +1; + +__END__ + +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2018 -- leonerd@leonerd.org.uk + +package Future; + +use strict; +use warnings; +no warnings 'recursion'; # Disable the "deep recursion" warning + +our $VERSION = '0.39'; + +use Carp qw(); # don't import croak +use Scalar::Util qw( weaken blessed reftype ); +use B qw( svref_2object ); +use Time::HiRes qw( gettimeofday tv_interval ); + +# we are not overloaded, but we want to check if other objects are +require overload; + +our @CARP_NOT = qw( Future::Utils ); + +use constant DEBUG => !!$ENV{PERL_FUTURE_DEBUG}; + +our $TIMES = DEBUG || $ENV{PERL_FUTURE_TIMES}; + + + + +# Callback flags +use constant { + CB_DONE => 1<<0, # Execute callback on done + CB_FAIL => 1<<1, # Execute callback on fail + CB_CANCEL => 1<<2, # Execute callback on cancellation + + CB_SELF => 1<<3, # Pass $self as first argument + CB_RESULT => 1<<4, # Pass result/failure as a list + + CB_SEQ_ONDONE => 1<<5, # Sequencing on success (->then) + CB_SEQ_ONFAIL => 1<<6, # Sequencing on failure (->else) + + CB_SEQ_IMDONE => 1<<7, # $code is in fact immediate ->done result + CB_SEQ_IMFAIL => 1<<8, # $code is in fact immediate ->fail result +}; + +use constant CB_ALWAYS => CB_DONE|CB_FAIL|CB_CANCEL; + +# Useful for identifying CODE references +sub CvNAME_FILE_LINE +{ + my ( $code ) = @_; + my $cv = svref_2object( $code ); + + my $name = join "::", $cv->STASH->NAME, $cv->GV->NAME; + return $name unless $cv->GV->NAME eq "__ANON__"; + + # $cv->GV->LINE isn't reliable, as outside of perl -d mode all anon CODE + # in the same file actually shares the same GV. :( + # Walk the optree looking for the first COP + my $cop = $cv->START; + $cop = $cop->next while $cop and ref $cop ne "B::COP" and ref $cop ne "B::NULL"; + + return $cv->GV->NAME if ref $cop eq "B::NULL"; + sprintf "%s(%s line %d)", $cv->GV->NAME, $cop->file, $cop->line; +} + +sub _callable +{ + my ( $cb ) = @_; + defined $cb and ( reftype($cb) eq 'CODE' || overload::Method($cb, '&{}') ); +} + +sub new +{ + my $proto = shift; + return bless { + ready => 0, + callbacks => [], # [] = [$type, ...] + ( DEBUG ? + ( do { my $at = Carp::shortmess( "constructed" ); + chomp $at; $at =~ s/\.$//; + constructed_at => $at } ) + : () ), + ( $TIMES ? + ( btime => [ gettimeofday ] ) + : () ), + }, ( ref $proto || $proto ); +} + +my $GLOBAL_END; +END { $GLOBAL_END = 1; } + +sub DESTROY_debug { + my $self = shift; + return if $GLOBAL_END; + return if $self->{ready} and ( $self->{reported} or !$self->{failure} ); + + my $lost_at = join " line ", (caller)[1,2]; + # We can't actually know the real line where the last reference was lost; + # a variable set to 'undef' or close of scope, because caller can't see it; + # the current op has already been updated. The best we can do is indicate + # 'near'. + + if( $self->{ready} and $self->{failure} ) { + warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " . + $self->{failure}[0] . "\n"; + } + elsif( !$self->{ready} ) { + warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n"; + } +} +*DESTROY = \&DESTROY_debug if DEBUG; + + +sub wrap +{ + my $class = shift; + my @values = @_; + + if( @values == 1 and blessed $values[0] and $values[0]->isa( __PACKAGE__ ) ) { + return $values[0]; + } + else { + return $class->done( @values ); + } +} + + +sub call +{ + my $class = shift; + my ( $code, @args ) = @_; + + my $f; + eval { $f = $code->( @args ); 1 } or $f = $class->fail( $@ ); + blessed $f and $f->isa( "Future" ) or $f = $class->fail( "Expected " . CvNAME_FILE_LINE($code) . " to return a Future" ); + + return $f; +} + +sub _shortmess +{ + my $at = Carp::shortmess( $_[0] ); + chomp $at; $at =~ s/\.$//; + return $at; +} + +sub _mark_ready +{ + my $self = shift; + $self->{ready} = 1; + $self->{ready_at} = _shortmess $_[0] if DEBUG; + + if( $TIMES ) { + $self->{rtime} = [ gettimeofday ]; + } + + delete $self->{on_cancel}; + my $callbacks = delete $self->{callbacks} or return; + + my $cancelled = $self->{cancelled}; + my $fail = defined $self->{failure}; + my $done = !$fail && !$cancelled; + + my @result = $done ? $self->get : + $fail ? $self->failure : + (); + + foreach my $cb ( @$callbacks ) { + my ( $flags, $code ) = @$cb; + my $is_future = blessed( $code ) && $code->isa( "Future" ); + + next if $done and not( $flags & CB_DONE ); + next if $fail and not( $flags & CB_FAIL ); + next if $cancelled and not( $flags & CB_CANCEL ); + + $self->{reported} = 1 if $fail; + + if( $is_future ) { + $done ? $code->done( @result ) : + $fail ? $code->fail( @result ) : + $code->cancel; + } + elsif( $flags & (CB_SEQ_ONDONE|CB_SEQ_ONFAIL) ) { + my ( undef, undef, $fseq ) = @$cb; + if( !$fseq ) { # weaken()ed; it might be gone now + # This warning should always be printed, even not in DEBUG mode. + # It's always an indication of a bug + Carp::carp +(DEBUG ? "${\$self->__selfstr} ($self->{constructed_at})" + : "${\$self->__selfstr} $self" ) . + " lost a sequence Future"; + next; + } + + my $f2; + if( $done and $flags & CB_SEQ_ONDONE or + $fail and $flags & CB_SEQ_ONFAIL ) { + + if( $flags & CB_SEQ_IMDONE ) { + $fseq->done( @$code ); + next; + } + elsif( $flags & CB_SEQ_IMFAIL ) { + $fseq->fail( @$code ); + next; + } + + my @args = ( + ( $flags & CB_SELF ? $self : () ), + ( $flags & CB_RESULT ? @result : () ), + ); + + unless( eval { $f2 = $code->( @args ); 1 } ) { + $fseq->fail( $@ ); + next; + } + + unless( blessed $f2 and $f2->isa( "Future" ) ) { + $fseq->fail( "Expected " . CvNAME_FILE_LINE($code) . " to return a Future" ); + next; + } + + $fseq->on_cancel( $f2 ); + } + else { + $f2 = $self; + } + + if( $f2->is_ready ) { + $f2->on_ready( $fseq ) if !$f2->{cancelled}; + } + else { + push @{ $f2->{callbacks} }, [ CB_DONE|CB_FAIL, $fseq ]; + weaken( $f2->{callbacks}[-1][1] ); + } + } + else { + $code->( + ( $flags & CB_SELF ? $self : () ), + ( $flags & CB_RESULT ? @result : () ), + ); + } + } +} + + + + +sub is_ready +{ + my $self = shift; + return $self->{ready}; +} + + +sub is_done +{ + my $self = shift; + return $self->{ready} && !$self->{failure} && !$self->{cancelled}; +} + + +sub is_failed +{ + my $self = shift; + return $self->{ready} && !!$self->{failure}; # boolify +} + + +sub is_cancelled +{ + my $self = shift; + return $self->{cancelled}; +} + + +sub state +{ + my $self = shift; + return !$self->{ready} ? "pending" : + DEBUG ? $self->{ready_at} : + $self->{failure} ? "failed" : + $self->{cancelled} ? "cancelled" : + "done"; +} + + + +sub done +{ + my $self = shift; + + if( ref $self ) { + $self->{cancelled} and return $self; + $self->{ready} and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->done"; + $self->{subs} and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->done"; + $self->{result} = [ @_ ]; + $self->_mark_ready( "done" ); + } + else { + $self = $self->new; + $self->{ready} = 1; + $self->{ready_at} = _shortmess "done" if DEBUG; + $self->{result} = [ @_ ]; + } + + return $self; +} + +my $warned_done_cb; +sub done_cb +{ + my $self = shift; + $warned_done_cb or + $warned_done_cb++, warnings::warnif( deprecated => "Future->done_cb is now deprecated; use ->curry::done or sub {...}" ); + return sub { $self->done( @_ ) }; +} + + +sub fail +{ + my $self = shift; + my ( $exception, @details ) = @_; + + $_[0] or Carp::croak "$self ->fail requires an exception that is true"; + + if( ref $self ) { + $self->{cancelled} and return $self; + $self->{ready} and Carp::croak "${\$self->__selfstr} is already ".$self->state." and cannot be ->fail'ed"; + $self->{subs} and Carp::croak "${\$self->__selfstr} is not a leaf Future, cannot be ->fail'ed"; + $self->{failure} = [ $exception, @details ]; + $self->_mark_ready( "failed" ); + } + else { + $self = $self->new; + $self->{ready} = 1; + $self->{ready_at} = _shortmess "failed" if DEBUG; + $self->{failure} = [ $exception, @details ]; + } + + return $self; +} + +my $warned_fail_cb; +sub fail_cb +{ + my $self = shift; + $warned_fail_cb or + $warned_fail_cb++, warnings::warnif( deprecated => "Future->fail_cb is now deprecated; use ->curry::fail or sub {...}" ); + return sub { $self->fail( @_ ) }; +} + + +sub die :method +{ + my $self = shift; + my ( $exception, @details ) = @_; + + if( !ref $exception and $exception !~ m/\n$/ ) { + $exception .= sprintf " at %s line %d\n", (caller)[1,2]; + } + + $self->fail( $exception, @details ); +} + + +sub on_cancel +{ + my $self = shift; + my ( $code ) = @_; + + my $is_future = blessed( $code ) && $code->isa( "Future" ); + $is_future or _callable( $code ) or + Carp::croak "Expected \$code to be callable or a Future in ->on_cancel"; + + $self->{ready} and return $self; + + push @{ $self->{on_cancel} }, $code; + + return $self; +} + + + +sub on_ready +{ + my $self = shift; + my ( $code ) = @_; + + my $is_future = blessed( $code ) && $code->isa( "Future" ); + $is_future or _callable( $code ) or + Carp::croak "Expected \$code to be callable or a Future in ->on_ready"; + + if( $self->{ready} ) { + my $fail = defined $self->{failure}; + my $done = !$fail && !$self->{cancelled}; + + $self->{reported} = 1 if $fail; + + $is_future ? ( $done ? $code->done( $self->get ) : + $fail ? $code->fail( $self->failure ) : + $code->cancel ) + : $code->( $self ); + } + else { + push @{ $self->{callbacks} }, [ CB_ALWAYS|CB_SELF, $self->wrap_cb( on_ready => $code ) ]; + } + + return $self; +} + + +sub await +{ + my $self = shift; + Carp::croak "$self is not yet complete and does not provide ->await"; +} + +sub get +{ + my $self = shift; + until( $self->{ready} ) { $self->await } + if( $self->{failure} ) { + $self->{reported} = 1; + my $exception = $self->{failure}->[0]; + !ref $exception && $exception =~ m/\n$/ ? CORE::die $exception : Carp::croak $exception; + } + $self->{cancelled} and Carp::croak "${\$self->__selfstr} was cancelled"; + return $self->{result}->[0] unless wantarray; + return @{ $self->{result} }; +} + + +sub unwrap +{ + shift; # $class + my @values = @_; + + if( @values == 1 and blessed $values[0] and $values[0]->isa( __PACKAGE__ ) ) { + return $values[0]->get; + } + else { + return $values[0] if !wantarray; + return @values; + } +} + + +sub on_done +{ + my $self = shift; + my ( $code ) = @_; + + my $is_future = blessed( $code ) && $code->isa( "Future" ); + $is_future or _callable( $code ) or + Carp::croak "Expected \$code to be callable or a Future in ->on_done"; + + if( $self->{ready} ) { + return $self if $self->{failure} or $self->{cancelled}; + + $is_future ? $code->done( $self->get ) + : $code->( $self->get ); + } + else { + push @{ $self->{callbacks} }, [ CB_DONE|CB_RESULT, $self->wrap_cb( on_done => $code ) ]; + } + + return $self; +} + + +sub failure +{ + my $self = shift; + until( $self->{ready} ) { $self->await } + return unless $self->{failure}; + $self->{reported} = 1; + return $self->{failure}->[0] if !wantarray; + return @{ $self->{failure} }; +} + + +sub on_fail +{ + my $self = shift; + my ( $code ) = @_; + + my $is_future = blessed( $code ) && $code->isa( "Future" ); + $is_future or _callable( $code ) or + Carp::croak "Expected \$code to be callable or a Future in ->on_fail"; + + if( $self->{ready} ) { + return $self if not $self->{failure}; + $self->{reported} = 1; + + $is_future ? $code->fail( $self->failure ) + : $code->( $self->failure ); + } + else { + push @{ $self->{callbacks} }, [ CB_FAIL|CB_RESULT, $self->wrap_cb( on_fail => $code ) ]; + } + + return $self; +} + + +sub cancel +{ + my $self = shift; + + return $self if $self->{ready}; + + $self->{cancelled}++; + foreach my $code ( reverse @{ $self->{on_cancel} || [] } ) { + my $is_future = blessed( $code ) && $code->isa( "Future" ); + $is_future ? $code->cancel + : $code->( $self ); + } + $self->_mark_ready( "cancel" ); + + return $self; +} + +my $warned_cancel_cb; +sub cancel_cb +{ + my $self = shift; + $warned_cancel_cb or + $warned_cancel_cb++, warnings::warnif( deprecated => "Future->cancel_cb is now deprecated; use ->curry::cancel or sub {...}" ); + return sub { $self->cancel }; +} + + +sub _sequence +{ + my $f1 = shift; + my ( $code, $flags ) = @_; + + # For later, we might want to know where we were called from + my $func = (caller 1)[3]; + $func =~ s/^.*:://; + + $flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL) or _callable( $code ) or + Carp::croak "Expected \$code to be callable in ->$func"; + + if( !defined wantarray ) { + Carp::carp "Calling ->$func in void context"; + } + + if( $f1->is_ready ) { + # Take a shortcut + return $f1 if $f1->is_done and not( $flags & CB_SEQ_ONDONE ) or + $f1->failure and not( $flags & CB_SEQ_ONFAIL ); + + if( $flags & CB_SEQ_IMDONE ) { + return Future->done( @$code ); + } + elsif( $flags & CB_SEQ_IMFAIL ) { + return Future->fail( @$code ); + } + + my @args = ( + ( $flags & CB_SELF ? $f1 : () ), + ( $flags & CB_RESULT ? $f1->is_done ? $f1->get : + $f1->failure ? $f1->failure : + () : () ), + ); + + my $fseq; + unless( eval { $fseq = $code->( @args ); 1 } ) { + return Future->fail( $@ ); + } + + unless( blessed $fseq and $fseq->isa( "Future" ) ) { + return Future->fail( "Expected " . CvNAME_FILE_LINE($code) . " to return a Future" ); + } + + return $fseq; + } + + my $fseq = $f1->new; + $fseq->on_cancel( $f1 ); + + # TODO: if anyone cares about the op name, we might have to synthesize it + # from $flags + $code = $f1->wrap_cb( sequence => $code ) unless $flags & (CB_SEQ_IMDONE|CB_SEQ_IMFAIL); + + push @{ $f1->{callbacks} }, [ CB_DONE|CB_FAIL|$flags, $code, $fseq ]; + weaken( $f1->{callbacks}[-1][2] ); + + return $fseq; +} + + +my $make_donecatchfail_sub = sub { + my ( $with_f, $done_code, $fail_code, @catch_list ) = @_; + + my $func = (caller 1)[3]; + $func =~ s/^.*:://; + + !$done_code or _callable( $done_code ) or + Carp::croak "Expected \$done_code to be callable in ->$func"; + !$fail_code or _callable( $fail_code ) or + Carp::croak "Expected \$fail_code to be callable in ->$func"; + + my %catch_handlers = @catch_list; + _callable( $catch_handlers{$_} ) or + Carp::croak "Expected catch handler for '$_' to be callable in ->$func" + for keys %catch_handlers; + + sub { + my $self = shift; + my @maybe_self = $with_f ? ( $self ) : (); + + if( !$self->{failure} ) { + return $self unless $done_code; + return $done_code->( @maybe_self, $self->get ); + } + else { + my $name = $self->{failure}[1]; + if( defined $name and $catch_handlers{$name} ) { + return $catch_handlers{$name}->( @maybe_self, $self->failure ); + } + return $self unless $fail_code; + return $fail_code->( @maybe_self, $self->failure ); + } + }; +}; + +sub then +{ + my $self = shift; + my $done_code = shift; + my $fail_code = ( @_ % 2 ) ? pop : undef; + my @catch_list = @_; + + if( $done_code and !@catch_list and !$fail_code ) { + return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_RESULT ); + } + + # Complex + return $self->_sequence( $make_donecatchfail_sub->( + 0, $done_code, $fail_code, @catch_list, + ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + +sub else +{ + my $self = shift; + my ( $fail_code ) = @_; + + return $self->_sequence( $fail_code, CB_SEQ_ONFAIL|CB_RESULT ); +} + + +sub catch +{ + my $self = shift; + my $fail_code = ( @_ % 2 ) ? pop : undef; + my @catch_list = @_; + + return $self->_sequence( $make_donecatchfail_sub->( + 0, undef, $fail_code, @catch_list, + ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + + +sub transform +{ + my $self = shift; + my %args = @_; + + my $xfrm_done = $args{done}; + my $xfrm_fail = $args{fail}; + + return $self->_sequence( sub { + my $self = shift; + if( !$self->{failure} ) { + return $self unless $xfrm_done; + my @result = $xfrm_done->( $self->get ); + return $self->new->done( @result ); + } + else { + return $self unless $xfrm_fail; + my @failure = $xfrm_fail->( $self->failure ); + return $self->new->fail( @failure ); + } + }, CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + + +sub then_with_f +{ + my $self = shift; + my $done_code = shift; + my $fail_code = ( @_ % 2 ) ? pop : undef; + my @catch_list = @_; + + if( $done_code and !@catch_list and !$fail_code ) { + return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_SELF|CB_RESULT ); + } + + return $self->_sequence( $make_donecatchfail_sub->( + 1, $done_code, $fail_code, @catch_list, + ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + + +sub then_done +{ + my $self = shift; + my ( @result ) = @_; + return $self->_sequence( \@result, CB_SEQ_ONDONE|CB_SEQ_IMDONE ); +} + +sub then_fail +{ + my $self = shift; + my ( @failure ) = @_; + return $self->_sequence( \@failure, CB_SEQ_ONDONE|CB_SEQ_IMFAIL ); +} + + +sub else_with_f +{ + my $self = shift; + my ( $fail_code ) = @_; + + return $self->_sequence( $fail_code, CB_SEQ_ONFAIL|CB_SELF|CB_RESULT ); +} + + +sub else_done +{ + my $self = shift; + my ( @result ) = @_; + return $self->_sequence( \@result, CB_SEQ_ONFAIL|CB_SEQ_IMDONE ); +} + +sub else_fail +{ + my $self = shift; + my ( @failure ) = @_; + return $self->_sequence( \@failure, CB_SEQ_ONFAIL|CB_SEQ_IMFAIL ); +} + + +sub catch_with_f +{ + my $self = shift; + my $fail_code = ( @_ % 2 ) ? pop : undef; + my @catch_list = @_; + + return $self->_sequence( $make_donecatchfail_sub->( + 1, undef, $fail_code, @catch_list, + ), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + + +sub followed_by +{ + my $self = shift; + my ( $code ) = @_; + + return $self->_sequence( $code, CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF ); +} + + +sub without_cancel +{ + my $self = shift; + my $new = $self->new; + + $self->on_ready( sub { + my $self = shift; + if( $self->failure ) { + $new->fail( $self->failure ); + } + else { + $new->done( $self->get ); + } + }); + + $new->{orig} = $self; # just to strongref it - RT122920 + $new->on_ready( sub { undef $_[0]->{orig} } ); + + return $new; +} + + +sub retain +{ + my $self = shift; + return $self->on_ready( sub { undef $self } ); +} + + +sub _new_convergent +{ + shift; # ignore this class + my ( $subs ) = @_; + + foreach my $sub ( @$subs ) { + blessed $sub and $sub->isa( "Future" ) or Carp::croak "Expected a Future, got $sub"; + } + + # Find the best prototype. Ideally anything derived if we can find one. + my $self; + ref($_) eq "Future" or $self = $_->new, last for @$subs; + + # No derived ones; just have to be a basic class then + $self ||= Future->new; + + $self->{subs} = $subs; + + # This might be called by a DESTROY during global destruction so it should + # be as defensive as possible (see RT88967) + $self->on_cancel( sub { + foreach my $sub ( @$subs ) { + $sub->cancel if $sub and !$sub->{ready}; + } + } ); + + return $self; +} + + +sub wait_all +{ + my $class = shift; + my @subs = @_; + + unless( @subs ) { + my $self = $class->done; + $self->{subs} = []; + return $self; + } + + my $self = Future->_new_convergent( \@subs ); + + my $pending = 0; + $_->{ready} or $pending++ for @subs; + + # Look for immediate ready + if( !$pending ) { + $self->{result} = [ @subs ]; + $self->_mark_ready( "wait_all" ); + return $self; + } + + weaken( my $weakself = $self ); + my $sub_on_ready = sub { + return unless my $self = $weakself; + + $pending--; + $pending and return; + + $self->{result} = [ @subs ]; + $self->_mark_ready( "wait_all" ); + }; + + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->on_ready( $sub_on_ready ); + } + + return $self; +} + + +sub wait_any +{ + my $class = shift; + my @subs = @_; + + unless( @subs ) { + my $self = $class->fail( "Cannot ->wait_any with no subfutures" ); + $self->{subs} = []; + return $self; + } + + my $self = Future->_new_convergent( \@subs ); + + # Look for immediate ready + my $immediate_ready; + foreach my $sub ( @subs ) { + $sub->{ready} and $immediate_ready = $sub, last; + } + + if( $immediate_ready ) { + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->cancel; + } + + if( $immediate_ready->{failure} ) { + $self->{failure} = [ $immediate_ready->failure ]; + } + else { + $self->{result} = [ $immediate_ready->get ]; + } + $self->_mark_ready( "wait_any" ); + return $self; + } + + my $pending = 0; + + weaken( my $weakself = $self ); + my $sub_on_ready = sub { + return unless my $self = $weakself; + return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel + + return if --$pending and $_[0]->{cancelled}; + + if( $_[0]->{cancelled} ) { + $self->{failure} = [ "All component futures were cancelled" ]; + } + elsif( $_[0]->{failure} ) { + $self->{failure} = [ $_[0]->failure ]; + } + else { + $self->{result} = [ $_[0]->get ]; + } + + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->cancel; + } + + $self->_mark_ready( "wait_any" ); + }; + + foreach my $sub ( @subs ) { + # No need to test $sub->{ready} since we know none of them are + $sub->on_ready( $sub_on_ready ); + $pending++; + } + + return $self; +} + + +sub needs_all +{ + my $class = shift; + my @subs = @_; + + unless( @subs ) { + my $self = $class->done; + $self->{subs} = []; + return $self; + } + + my $self = Future->_new_convergent( \@subs ); + + # Look for immediate fail + my $immediate_fail; + foreach my $sub ( @subs ) { + $sub->{ready} and $sub->{failure} and $immediate_fail = $sub, last; + } + + if( $immediate_fail ) { + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->cancel; + } + + $self->{failure} = [ $immediate_fail->failure ]; + $self->_mark_ready( "needs_all" ); + return $self; + } + + my $pending = 0; + $_->{ready} or $pending++ for @subs; + + # Look for immediate done + if( !$pending ) { + $self->{result} = [ map { $_->get } @subs ]; + $self->_mark_ready( "needs_all" ); + return $self; + } + + weaken( my $weakself = $self ); + my $sub_on_ready = sub { + return unless my $self = $weakself; + return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel + + if( $_[0]->{cancelled} ) { + $self->{failure} = [ "A component future was cancelled" ]; + foreach my $sub ( @subs ) { + $sub->cancel if !$sub->{ready}; + } + $self->_mark_ready( "needs_all" ); + } + elsif( my @failure = $_[0]->failure ) { + $self->{failure} = \@failure; + foreach my $sub ( @subs ) { + $sub->cancel if !$sub->{ready}; + } + $self->_mark_ready( "needs_all" ); + } + else { + $pending--; + $pending and return; + + $self->{result} = [ map { $_->get } @subs ]; + $self->_mark_ready( "needs_all" ); + } + }; + + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->on_ready( $sub_on_ready ); + } + + return $self; +} + + +sub needs_any +{ + my $class = shift; + my @subs = @_; + + unless( @subs ) { + my $self = $class->fail( "Cannot ->needs_any with no subfutures" ); + $self->{subs} = []; + return $self; + } + + my $self = Future->_new_convergent( \@subs ); + + # Look for immediate done + my $immediate_done; + my $pending = 0; + foreach my $sub ( @subs ) { + $sub->{ready} and !$sub->{failure} and $immediate_done = $sub, last; + $sub->{ready} or $pending++; + } + + if( $immediate_done ) { + foreach my $sub ( @subs ) { + $sub->{ready} ? $sub->{reported} = 1 : $sub->cancel; + } + + $self->{result} = [ $immediate_done->get ]; + $self->_mark_ready( "needs_any" ); + return $self; + } + + # Look for immediate fail + my $immediate_fail = 1; + foreach my $sub ( @subs ) { + $sub->{ready} or $immediate_fail = 0, last; + } + + if( $immediate_fail ) { + $_->{reported} = 1 for @subs; + # For consistency we'll pick the last one for the failure + $self->{failure} = [ $subs[-1]->{failure} ]; + $self->_mark_ready( "needs_any" ); + return $self; + } + + weaken( my $weakself = $self ); + my $sub_on_ready = sub { + return unless my $self = $weakself; + return if $self->{result} or $self->{failure}; # don't recurse on child ->cancel + + return if --$pending and $_[0]->{cancelled}; + + if( $_[0]->{cancelled} ) { + $self->{failure} = [ "All component futures were cancelled" ]; + $self->_mark_ready( "needs_any" ); + } + elsif( my @failure = $_[0]->failure ) { + $pending and return; + + $self->{failure} = \@failure; + $self->_mark_ready( "needs_any" ); + } + else { + $self->{result} = [ $_[0]->get ]; + foreach my $sub ( @subs ) { + $sub->cancel if !$sub->{ready}; + } + $self->_mark_ready( "needs_any" ); + } + }; + + foreach my $sub ( @subs ) { + $sub->{ready} or $sub->on_ready( $sub_on_ready ); + } + + return $self; +} + + + +sub pending_futures +{ + my $self = shift; + $self->{subs} or Carp::croak "Cannot call ->pending_futures on a non-convergent Future"; + return grep { not $_->{ready} } @{ $self->{subs} }; +} + +sub ready_futures +{ + my $self = shift; + $self->{subs} or Carp::croak "Cannot call ->ready_futures on a non-convergent Future"; + return grep { $_->{ready} } @{ $self->{subs} }; +} + +sub done_futures +{ + my $self = shift; + $self->{subs} or Carp::croak "Cannot call ->done_futures on a non-convergent Future"; + return grep { $_->{ready} and not $_->{failure} and not $_->{cancelled} } @{ $self->{subs} }; +} + +sub failed_futures +{ + my $self = shift; + $self->{subs} or Carp::croak "Cannot call ->failed_futures on a non-convergent Future"; + return grep { $_->{ready} and $_->{failure} } @{ $self->{subs} }; +} + +sub cancelled_futures +{ + my $self = shift; + $self->{subs} or Carp::croak "Cannot call ->cancelled_futures on a non-convergent Future"; + return grep { $_->{ready} and $_->{cancelled} } @{ $self->{subs} }; +} + + +sub set_label +{ + my $self = shift; + ( $self->{label} ) = @_; + return $self; +} + +sub label +{ + my $self = shift; + return $self->{label}; +} + +sub __selfstr +{ + my $self = shift; + return "$self" unless defined $self->{label}; + return "$self (\"$self->{label}\")"; +} + + +sub btime +{ + my $self = shift; + return $self->{btime}; +} + +sub rtime +{ + my $self = shift; + return $self->{rtime}; +} + + +sub elapsed +{ + my $self = shift; + return undef unless defined $self->{btime} and defined $self->{rtime}; + return $self->{elapsed} ||= tv_interval( $self->{btime}, $self->{rtime} ); +} + + +sub wrap_cb +{ + my $self = shift; + my ( $op, $cb ) = @_; + return $cb; +} + + + + + + +0x55AA; +package bytes; + +sub length (_) { + BEGIN { bytes::import() } + return CORE::length($_[0]); +} + +sub substr ($$;$$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::substr($_[0], $_[1]) : + @_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) : + CORE::substr($_[0], $_[1], $_[2], $_[3]) ; +} + +sub ord (_) { + BEGIN { bytes::import() } + return CORE::ord($_[0]); +} + +sub chr (_) { + BEGIN { bytes::import() } + return CORE::chr($_[0]); +} + +sub index ($$;$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::index($_[0], $_[1]) : + CORE::index($_[0], $_[1], $_[2]) ; +} + +sub rindex ($$;$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::rindex($_[0], $_[1]) : + CORE::rindex($_[0], $_[1], $_[2]) ; +} + +1; +package constant; +use 5.008; +use strict; +use warnings::register; + +our $VERSION = '1.33'; +our %declared; + +#======================================================================= + +# Some names are evil choices. +my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD }; +$keywords{UNITCHECK}++ if $] > 5.009; + +my %forced_into_main = map +($_, 1), + qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG }; + +my %forbidden = (%keywords, %forced_into_main); + +my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/; +my $tolerable = qr/^[A-Za-z_]\w*\z/; +my $boolean = qr/^[01]?\z/; + +BEGIN { + # We'd like to do use constant _CAN_PCS => $] > 5.009002 + # but that's a bit tricky before we load the constant module :-) + # By doing this, we save several run time checks for *every* call + # to import. + my $const = $] > 5.009002; + my $downgrade = $] < 5.015004; # && $] >= 5.008 + my $constarray = exists &_make_const; + if ($const) { + Internals::SvREADONLY($const, 1); + Internals::SvREADONLY($downgrade, 1); + $constant::{_CAN_PCS} = \$const; + $constant::{_DOWNGRADE} = \$downgrade; + $constant::{_CAN_PCS_FOR_ARRAY} = \$constarray; + } + else { + no strict 'refs'; + *{"_CAN_PCS"} = sub () {$const}; + *{"_DOWNGRADE"} = sub () { $downgrade }; + *{"_CAN_PCS_FOR_ARRAY"} = sub () { $constarray }; + } +} + +#======================================================================= +# import() - import symbols into user's namespace +# +# What we actually do is define a function in the caller's namespace +# which returns the value. The function we create will normally +# be inlined as a constant, thereby avoiding further sub calling +# overhead. +#======================================================================= +sub import { + my $class = shift; + return unless @_; # Ignore 'use constant;' + my $constants; + my $multiple = ref $_[0]; + my $caller = caller; + my $flush_mro; + my $symtab; + + if (_CAN_PCS) { + no strict 'refs'; + $symtab = \%{$caller . '::'}; + }; + + if ( $multiple ) { + if (ref $_[0] ne 'HASH') { + require Carp; + Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'"); + } + $constants = shift; + } else { + unless (defined $_[0]) { + require Carp; + Carp::croak("Can't use undef as constant name"); + } + $constants->{+shift} = undef; + } + + foreach my $name ( keys %$constants ) { + my $pkg; + my $symtab = $symtab; + my $orig_name = $name; + if ($name =~ s/(.*)(?:::|')(?=.)//s) { + $pkg = $1; + if (_CAN_PCS && $pkg ne $caller) { + no strict 'refs'; + $symtab = \%{$pkg . '::'}; + } + } + else { + $pkg = $caller; + } + + # Normal constant name + if ($name =~ $normal_constant_name and !$forbidden{$name}) { + # Everything is okay + + # Name forced into main, but we're not in main. Fatal. + } elsif ($forced_into_main{$name} and $pkg ne 'main') { + require Carp; + Carp::croak("Constant name '$name' is forced into main::"); + + # Starts with double underscore. Fatal. + } elsif ($name =~ /^__/) { + require Carp; + Carp::croak("Constant name '$name' begins with '__'"); + + # Maybe the name is tolerable + } elsif ($name =~ $tolerable) { + # Then we'll warn only if you've asked for warnings + if (warnings::enabled()) { + if ($keywords{$name}) { + warnings::warn("Constant name '$name' is a Perl keyword"); + } elsif ($forced_into_main{$name}) { + warnings::warn("Constant name '$name' is " . + "forced into package main::"); + } + } + + # Looks like a boolean + # use constant FRED == fred; + } elsif ($name =~ $boolean) { + require Carp; + if (@_) { + Carp::croak("Constant name '$name' is invalid"); + } else { + Carp::croak("Constant name looks like boolean value"); + } + + } else { + # Must have bad characters + require Carp; + Carp::croak("Constant name '$name' has invalid characters"); + } + + { + no strict 'refs'; + my $full_name = "${pkg}::$name"; + $declared{$full_name}++; + if ($multiple || @_ == 1) { + my $scalar = $multiple ? $constants->{$orig_name} : $_[0]; + + if (_DOWNGRADE) { # for 5.8 to 5.14 + # Work around perl bug #31991: Sub names (actually glob + # names in general) ignore the UTF8 flag. So we have to + # turn it off to get the "right" symbol table entry. + utf8::is_utf8 $name and utf8::encode $name; + } + + # The constant serves to optimise this entire block out on + # 5.8 and earlier. + if (_CAN_PCS) { + # Use a reference as a proxy for a constant subroutine. + # If this is not a glob yet, it saves space. If it is + # a glob, we must still create it this way to get the + # right internal flags set, as constants are distinct + # from subroutines created with sub(){...}. + # The check in Perl_ck_rvconst knows that inlinable + # constants from cv_const_sv are read only. So we have to: + Internals::SvREADONLY($scalar, 1); + if (!exists $symtab->{$name}) { + $symtab->{$name} = \$scalar; + ++$flush_mro->{$pkg}; + } + else { + local $constant::{_dummy} = \$scalar; + *$full_name = \&{"_dummy"}; + } + } else { + *$full_name = sub () { $scalar }; + } + } elsif (@_) { + my @list = @_; + if (_CAN_PCS_FOR_ARRAY) { + _make_const($list[$_]) for 0..$#list; + _make_const(@list); + if (!exists $symtab->{$name}) { + $symtab->{$name} = \@list; + $flush_mro->{$pkg}++; + } + else { + local $constant::{_dummy} = \@list; + *$full_name = \&{"_dummy"}; + } + } + else { *$full_name = sub () { @list }; } + } else { + *$full_name = sub () { }; + } + } + } + # Flush the cache exactly once if we make any direct symbol table changes. + if (_CAN_PCS && $flush_mro) { + mro::method_changed_in($_) for keys %$flush_mro; + } +} + +1; + +__END__ + +package AutoLoader; + +use strict; +use 5.006_001; + +our($VERSION, $AUTOLOAD); + +my $is_dosish; +my $is_epoc; +my $is_vms; +my $is_macos; + +BEGIN { + $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare'; + $is_epoc = $^O eq 'epoc'; + $is_vms = $^O eq 'VMS'; + $is_macos = $^O eq 'MacOS'; + $VERSION = '5.74'; +} + +AUTOLOAD { + my $sub = $AUTOLOAD; + autoload_sub($sub); + goto &$sub; +} + +sub autoload_sub { + my $sub = shift; + + my $filename = AutoLoader::find_filename( $sub ); + + my $save = $@; + local $!; # Do not munge the value. + eval { local $SIG{__DIE__}; require $filename }; + if ($@) { + if (substr($sub,-9) eq '::DESTROY') { + no strict 'refs'; + *$sub = sub {}; + $@ = undef; + } elsif ($@ =~ /^Can't locate/) { + # The load might just have failed because the filename was too + # long for some old SVR3 systems which treat long names as errors. + # If we can successfully truncate a long name then it's worth a go. + # There is a slight risk that we could pick up the wrong file here + # but autosplit should have warned about that when splitting. + if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){ + eval { local $SIG{__DIE__}; require $filename }; + } + } + if ($@){ + $@ =~ s/ at .*\n//; + my $error = $@; + require Carp; + Carp::croak($error); + } + } + $@ = $save; + + return 1; +} + +sub find_filename { + my $sub = shift; + my $filename; + # Braces used to preserve $1 et al. + { + # Try to find the autoloaded file from the package-qualified + # name of the sub. e.g., if the sub needed is + # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is + # something like '/usr/lib/perl5/Getopt/Long.pm', and the + # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is + # 'lib/Getopt/Long.pm', and we want to require + # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib'). + # In this case, we simple prepend the 'auto/' and let the + # C take care of the searching for us. + + my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/); + $pkg =~ s#::#/#g; + if (defined($filename = $INC{"$pkg.pm"})) { + if ($is_macos) { + $pkg =~ tr#/#:#; + $filename = undef + unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s; + } else { + $filename = undef + unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s; + } + + # if the file exists, then make sure that it is a + # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al', + # or './lib/auto/foo/bar.al'. This avoids C searching + # (and failing) to find the 'lib/auto/foo/bar.al' because it + # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib'). + + if (defined $filename and -r $filename) { + unless ($filename =~ m|^/|s) { + if ($is_dosish) { + unless ($filename =~ m{^([a-z]:)?[\\/]}is) { + if ($^O ne 'NetWare') { + $filename = "./$filename"; + } else { + $filename = "$filename"; + } + } + } + elsif ($is_epoc) { + unless ($filename =~ m{^([a-z?]:)?[\\/]}is) { + $filename = "./$filename"; + } + } + elsif ($is_vms) { + # XXX todo by VMSmiths + $filename = "./$filename"; + } + elsif (!$is_macos) { + $filename = "./$filename"; + } + } + } + else { + $filename = undef; + } + } + unless (defined $filename) { + # let C do the searching + $filename = "auto/$sub.al"; + $filename =~ s#::#/#g; + } + } + return $filename; +} + +sub import { + my $pkg = shift; + my $callpkg = caller; + + # + # Export symbols, but not by accident of inheritance. + # + + if ($pkg eq 'AutoLoader') { + if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) { + no strict 'refs'; + *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD; + } + } + + # + # Try to find the autosplit index file. Eg., if the call package + # is POSIX, then $INC{POSIX.pm} is something like + # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in + # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that. + # + # However, if @INC is a relative path, this might not work. If, + # for example, @INC = ('lib'), then + # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require + # 'auto/POSIX/autosplit.ix' (without the leading 'lib'). + # + + (my $calldir = $callpkg) =~ s#::#/#g; + my $path = $INC{$calldir . '.pm'}; + if (defined($path)) { + # Try absolute path name, but only eval it if the + # transformation from module path to autosplit.ix path + # succeeded! + my $replaced_okay; + if ($is_macos) { + (my $malldir = $calldir) =~ tr#/#:#; + $replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s); + } else { + $replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#); + } + + eval { require $path; } if $replaced_okay; + # If that failed, try relative path with normal @INC searching. + if (!$replaced_okay or $@) { + $path ="auto/$calldir/autosplit.ix"; + eval { require $path; }; + } + if ($@) { + my $error = $@; + require Carp; + Carp::carp($error); + } + } +} + +sub unimport { + my $callpkg = caller; + + no strict 'refs'; + + for my $exported (qw( AUTOLOAD )) { + my $symname = $callpkg . '::' . $exported; + undef *{ $symname } if \&{ $symname } == \&{ $exported }; + *{ $symname } = \&{ $symname }; + } +} + +1; + +__END__ + +require 5.014; # For more reliable $@ after eval +package dumpvar; + +# Needed for PrettyPrinter only: + +# require 5.001; # Well, it coredumps anyway undef DB in 5.000 (not now) + +# translate control chars to ^X - Randal Schwartz +# Modifications to print types by Peter Gordon v1.0 + +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + +# Won't dump symbol tables and contents of debugged files by default + +$winsize = 80 unless defined $winsize; + +sub ASCII { return ord('A') == 65; } + + +# Defaults + +# $globPrint = 1; +$printUndef = 1 unless defined $printUndef; +$tick = "auto" unless defined $tick; +$unctrl = 'quote' unless defined $unctrl; +$subdump = 1; +$dumpReused = 0 unless defined $dumpReused; +$bareStringify = 1 unless defined $bareStringify; + +my $APC = chr utf8::unicode_to_native(0x9F); +my $backslash_c_question = (ASCII) ? '\177' : $APC; + +sub main::dumpValue { + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + (print &stringify($_[0]), "\n"), return unless ref $_[0]; + push @_, -1 if @_ == 1; + dumpvar::unwrap($_[0], 0, $_[1]); +} + +# This one is good for variable names: + +sub unctrl { + for (my($dummy) = shift) { + local($v) ; + + return \$_ if ref \$_ eq "GLOB"; + s/([\000-\037])/ '^' . chr(utf8::unicode_to_native(ord($1)^64))/eg; + s/ $backslash_c_question /^?/xg; + return $_; + } +} + +sub uniescape { + join("", + map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) } + unpack("W*", $_[0])); +} + +sub stringify { + my $string; + if (eval { $string = _stringify(@_); 1 }) { + return $string; + } + + return "<< value could not be dumped: $@ >>"; +} + +sub _stringify { + (my $__, local $noticks) = @_; + for ($__) { + local($v) ; + my $tick = $tick; + + return 'undef' unless defined $_ or not $printUndef; + return $_ . "" if ref \$_ eq 'GLOB'; + $_ = &{'overload::StrVal'}($_) + if $bareStringify and ref $_ + and %overload:: and defined &{'overload::StrVal'}; + + if ($tick eq 'auto') { + if (/[^[:^cntrl:]\n]/u) { # All controls but \n get '"' + $tick = '"'; + } else { + $tick = "'"; + } + } + if ($tick eq "'") { + s/([\'\\])/\\$1/g; + } elsif ($unctrl eq 'unctrl') { + s/([\"\\])/\\$1/g ; + $_ = &unctrl($_); + # uniescape? + s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg + if $quoteHighBit; + } elsif ($unctrl eq 'quote') { + s/([\"\\\$\@])/\\$1/g if $tick eq '"'; + s/\e/\\e/g; + s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg; + } + $_ = uniescape($_); + s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $quoteHighBit; + return ($noticks || /^\d+(\.\d*)?\Z/) + ? $_ + : $tick . $_ . $tick; + } +} + +# Ensure a resulting \ is escaped to be \\ +sub _escaped_ord { + my $chr = shift; + if ($chr eq $backslash_c_question) { + $chr = '?'; + } + else { + $chr = chr(utf8::unicode_to_native(ord($chr)^64)); + $chr =~ s{\\}{\\\\}g; + } + return $chr; +} + +sub ShortArray { + my $tArrayDepth = $#{$_[0]} ; + $tArrayDepth = $#{$_[0]} < $arrayDepth-1 ? $#{$_[0]} : $arrayDepth-1 + unless $arrayDepth eq '' ; + my $shortmore = ""; + $shortmore = " ..." if $tArrayDepth < $#{$_[0]} ; + if (!grep(ref $_, @{$_[0]})) { + $short = "0..$#{$_[0]} '" . + join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore"; + return $short if length $short <= $compactDump; + } + undef; +} + +sub DumpElem { + my $short = &stringify($_[0], ref $_[0]); + if ($veryCompact && ref $_[0] + && (ref $_[0] eq 'ARRAY' and !grep(ref $_, @{$_[0]}) )) { + my $end = "0..$#{$v} '" . + join("' '", @{$_[0]}[0..$tArrayDepth]) . "'$shortmore"; + } elsif ($veryCompact && ref $_[0] + && (ref $_[0] eq 'HASH') and !grep(ref $_, values %{$_[0]})) { + my $end = 1; + $short = $sp . "0..$#{$v} '" . + join("' '", @{$v}[0..$tArrayDepth]) . "'$shortmore"; + } else { + print "$short\n"; + unwrap($_[0],$_[1],$_[2]) if ref $_[0]; + } +} + +sub unwrap { + return if $DB::signal; + local($v) = shift ; + local($s) = shift ; # extra no of spaces + local($m) = shift ; # maximum recursion depth + return if $m == 0; + local(%v,@v,$sp,$value,$key,@sortKeys,$more,$shortmore,$short) ; + local($tHashDepth,$tArrayDepth) ; + + $sp = " " x $s ; + $s += 3 ; + + eval { + # Check for reused addresses + if (ref $v) { + my $val = $v; + $val = &{'overload::StrVal'}($v) + if %overload:: and defined &{'overload::StrVal'}; + # Match type and address. + # Unblessed references will look like TYPE(0x...) + # Blessed references will look like Class=TYPE(0x...) + $val =~ s/^.*=//; # suppress the Class part, just keep TYPE(0x...) + ($item_type, $address) = + $val =~ /([^\(]+) # Keep stuff that's + # not an open paren + \( # Skip open paren + (0x[0-9a-f]+) # Save the address + \) # Skip close paren + $/x; # Should be at end now + + if (!$dumpReused && defined $address) { + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}-> REUSED_ADDRESS\n" ; + return ; + } + } + } elsif (ref \$v eq 'GLOB') { + # This is a raw glob. Special handling for that. + $address = "$v" . ""; # To avoid a bug with globs + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}*DUMPED_GLOB*\n" ; + return ; + } + } + + if (ref $v eq 'Regexp') { + # Reformat the regexp to look the standard way. + my $re = "$v"; + $re =~ s,/,\\/,g; + print "$sp-> qr/$re/\n"; + return; + } + + if ( $item_type eq 'HASH' ) { + # Hash ref or hash-based object. + my @sortKeys = sort keys(%$v) ; + undef $more ; + $tHashDepth = $#sortKeys ; + $tHashDepth = $#sortKeys < $hashDepth-1 ? $#sortKeys : $hashDepth-1 + unless $hashDepth eq '' ; + $more = "....\n" if $tHashDepth < $#sortKeys ; + $shortmore = ""; + $shortmore = ", ..." if $tHashDepth < $#sortKeys ; + $#sortKeys = $tHashDepth ; + if ($compactDump && !grep(ref $_, values %{$v})) { + #$short = $sp . + # (join ', ', +# Next row core dumps during require from DB on 5.000, even with map {"_"} + # map {&stringify($_) . " => " . &stringify($v->{$_})} + # @sortKeys) . "'$shortmore"; + $short = $sp; + my @keys; + for (@sortKeys) { + push @keys, &stringify($_) . " => " . &stringify($v->{$_}); + } + $short .= join ', ', @keys; + $short .= $shortmore; + (print "$short\n"), return if length $short <= $compactDump; + } + for $key (@sortKeys) { + return if $DB::signal; + $value = $ {$v}{$key} ; + print "$sp", &stringify($key), " => "; + DumpElem $value, $s, $m-1; + } + print "$sp empty hash\n" unless @sortKeys; + print "$sp$more" if defined $more ; + } elsif ( $item_type eq 'ARRAY' ) { + # Array ref or array-based object. Also: undef. + # See how big the array is. + $tArrayDepth = $#{$v} ; + undef $more ; + # Bigger than the max? + $tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1 + if defined $arrayDepth && $arrayDepth ne ''; + # Yep. Don't show it all. + $more = "....\n" if $tArrayDepth < $#{$v} ; + $shortmore = ""; + $shortmore = " ..." if $tArrayDepth < $#{$v} ; + + if ($compactDump && !grep(ref $_, @{$v})) { + if ($#$v >= 0) { + $short = $sp . "0..$#{$v} " . + join(" ", + map {exists $v->[$_] ? stringify $v->[$_] : "empty"} (0..$tArrayDepth) + ) . "$shortmore"; + } else { + $short = $sp . "empty array"; + } + (print "$short\n"), return if length $short <= $compactDump; + } + #if ($compactDump && $short = ShortArray($v)) { + # print "$short\n"; + # return; + #} + for $num (0 .. $tArrayDepth) { + return if $DB::signal; + print "$sp$num "; + if (exists $v->[$num]) { + if (defined $v->[$num]) { + DumpElem $v->[$num], $s, $m-1; + } + else { + print "undef\n"; + } + } else { + print "empty slot\n"; + } + } + print "$sp empty array\n" unless @$v; + print "$sp$more" if defined $more ; + } elsif ( $item_type eq 'SCALAR' ) { + unless (defined $$v) { + print "$sp-> undef\n"; + return; + } + print "$sp-> "; + DumpElem $$v, $s, $m-1; + } elsif ( $item_type eq 'REF' ) { + print "$sp-> $$v\n"; + return unless defined $$v; + unwrap($$v, $s+3, $m-1); + } elsif ( $item_type eq 'CODE' ) { + # Code object or reference. + print "$sp-> "; + dumpsub (0, $v); + } elsif ( $item_type eq 'GLOB' ) { + # Glob object or reference. + print "$sp-> ",&stringify($$v,1),"\n"; + if ($globPrint) { + $s += 3; + dumpglob($s, "{$$v}", $$v, 1, $m-1); + } elsif (defined ($fileno = eval {fileno($v)})) { + print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); + } + } elsif (ref \$v eq 'GLOB') { + # Raw glob (again?) + if ($globPrint) { + dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint; + } elsif (defined ($fileno = eval {fileno(\$v)})) { + print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); + } + } + }; + if ($@) { + print( (' ' x $s) . "<< value could not be dumped: $@ >>\n"); + } + + return; +} + +sub matchlex { + (my $var = $_[0]) =~ s/.//; + $var eq $_[1] or + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval { $var =~ /$2$3/ }); +} + +sub matchvar { + $_[0] eq $_[1] or + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); +} + +sub compactDump { + $compactDump = shift if @_; + $compactDump = 6*80-1 if $compactDump and $compactDump < 2; + $compactDump; +} + +sub veryCompact { + $veryCompact = shift if @_; + compactDump(1) if !$compactDump and $veryCompact; + $veryCompact; +} + +sub unctrlSet { + if (@_) { + my $in = shift; + if ($in eq 'unctrl' or $in eq 'quote') { + $unctrl = $in; + } else { + print "Unknown value for 'unctrl'.\n"; + } + } + $unctrl; +} + +sub quote { + if (@_ and $_[0] eq '"') { + $tick = '"'; + $unctrl = 'quote'; + } elsif (@_ and $_[0] eq 'auto') { + $tick = 'auto'; + $unctrl = 'quote'; + } elsif (@_) { # Need to set + $tick = "'"; + $unctrl = 'unctrl'; + } + $tick; +} + +sub dumpglob { + return if $DB::signal; + my ($off,$key, $val, $all, $m) = @_; + local(*entry) = $val; + my $fileno; + if (($key !~ /^_ fileno($fileno)\n" ); + } + if ($all) { + if (defined &entry) { + dumpsub($off, $key); + } + } +} + +sub dumplex { + return if $DB::signal; + my ($key, $val, $m, @vars) = @_; + return if @vars && !grep( matchlex($key, $_), @vars ); + local %address; + my $off = 0; # It reads better this way + my $fileno; + if (UNIVERSAL::isa($val,'ARRAY')) { + print( (' ' x $off) . "$key = (\n" ); + unwrap($val,3+$off,$m) ; + print( (' ' x $off) . ")\n" ); + } + elsif (UNIVERSAL::isa($val,'HASH')) { + print( (' ' x $off) . "$key = (\n" ); + unwrap($val,3+$off,$m) ; + print( (' ' x $off) . ")\n" ); + } + elsif (UNIVERSAL::isa($val,'IO')) { + print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" ); + } + # No lexical subroutines yet... + # elsif (UNIVERSAL::isa($val,'CODE')) { + # dumpsub($off, $$val); + # } + else { + print( (' ' x $off) . &unctrl($key), " = " ); + DumpElem $$val, 3+$off, $m; + } +} + +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + +sub dumpsub { + my ($off,$sub) = @_; + my $ini = $sub; + my $s; + $sub = $1 if $sub =~ /^\{\*(.*)\}$/; + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = CvGV_name_or_bust($subref)) && $DB::sub{$s}) + || ($subdump && ($s = findsubs("$subref")) && $DB::sub{$s}); + $place = '???' unless defined $place; + $s = $sub unless defined $s; + print( (' ' x $off) . "&$s in $place\n" ); +} + +sub findsubs { + return undef unless %DB::sub; + my ($addr, $name, $loc); + while (($name, $loc) = each %DB::sub) { + $addr = \&$name; + $subs{"$addr"} = $name; + } + $subdump = 0; + $subs{ shift() }; +} + +sub main::dumpvar { + my ($package,$m,@vars) = @_; + local(%address,$key,$val,$^W); + $package .= "::" unless $package =~ /::$/; + *stab = *{"main::"}; + while ($package =~ /(\w+?::)/g){ + *stab = $ {stab}{$1}; + } + local $TotalStrings = 0; + local $Strings = 0; + local $CompleteTotal = 0; + while (($key,$val) = each(%stab)) { + return if $DB::signal; + next if @vars && !grep( matchvar($key, $_), @vars ); + if ($usageOnly) { + globUsage(\$val, $key) + if ($package ne 'dumpvar' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; + } else { + dumpglob(0,$key, $val, 0, $m); + } + } + if ($usageOnly) { + print "String space: $TotalStrings bytes in $Strings strings.\n"; + $CompleteTotal += $TotalStrings; + print "Grand total = $CompleteTotal bytes (1 level deep) + overhead.\n"; + } +} + +sub scalarUsage { + my $size = length($_[0]); + $TotalStrings += $size; + $Strings++; + $size; +} + +sub arrayUsage { # array ref, name + my $size = 0; + map {$size += scalarUsage($_)} @{$_[0]}; + my $len = @{$_[0]}; + print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), + " (data: $size bytes)\n" + if defined $_[1]; + $CompleteTotal += $size; + $size; +} + +sub hashUsage { # hash ref, name + my @keys = keys %{$_[0]}; + my @values = values %{$_[0]}; + my $keys = arrayUsage \@keys; + my $values = arrayUsage \@values; + my $len = @keys; + my $total = $keys + $values; + print "\%$_[1] = $len item", ($len > 1 ? "s" : ""), + " (keys: $keys; values: $values; total: $total bytes)\n" + if defined $_[1]; + $total; +} + +sub globUsage { # glob ref, name + local *name = *{$_[0]}; + $total = 0; + $total += scalarUsage $name if defined $name; + $total += arrayUsage \@name, $_[1] if @name; + $total += hashUsage \%name, $_[1] if %name and $_[1] ne "main::" + and $_[1] ne "DB::"; #and !($package eq "dumpvar" and $key eq "stab")); + $total; +} + +sub packageUsage { + my ($package,@vars) = @_; + $package .= "::" unless $package =~ /::$/; + local *stab = *{"main::"}; + while ($package =~ /(\w+?::)/g){ + *stab = $ {stab}{$1}; + } + local $TotalStrings = 0; + local $CompleteTotal = 0; + my ($key,$val); + while (($key,$val) = each(%stab)) { + next if @vars && !grep($key eq $_,@vars); + globUsage \$val, $key unless $package eq 'dumpvar' and $key eq 'stab'; + } + print "String space: $TotalStrings.\n"; + $CompleteTotal += $TotalStrings; + print "\nGrand total = $CompleteTotal bytes\n"; +} + +1; + +package deprecate; +use strict; +use warnings; +our $VERSION = 0.03; + +# our %Config can ignore %Config::Config, e.g. for testing +our %Config; +unless (%Config) { require Config; *Config = \%Config::Config; } + +# This isn't a public API. It's internal to code maintained by the perl-porters +# If you would like it to be a public API, please send a patch with +# documentation and tests. Until then, it may change without warning. +sub __loaded_from_core { + my ($package, $file, $expect_leaf) = @_; + + foreach my $pair ([qw(sitearchexp archlibexp)], + [qw(sitelibexp privlibexp)]) { + my ($site, $priv) = @Config{@$pair}; + if ($^O eq 'VMS') { + for my $d ($site, $priv) { $d = VMS::Filespec::unixify($d) }; + } + # Just in case anyone managed to configure with trailing /s + s!/*$!!g foreach $site, $priv; + + next if $site eq $priv; + if (uc("$priv/$expect_leaf") eq uc($file)) { + return 1; + } + } + return 0; +} + +sub import { + my ($package, $file) = caller; + + my $expect_leaf = "$package.pm"; + $expect_leaf =~ s!::!/!g; + + if (__loaded_from_core($package, $file, $expect_leaf)) { + my $call_depth=1; + my @caller; + while (@caller = caller $call_depth++) { + last if $caller[7] # use/require + and $caller[6] eq $expect_leaf; # the package file + } + unless (@caller) { + require Carp; + Carp::cluck(<<"EOM"); +Can't find use/require $expect_leaf in caller stack +EOM + return; + } + + # This is fragile, because it + # is directly poking in the internals of warnings.pm + my ($call_file, $call_line, $callers_bitmask) = @caller[1,2,9]; + + if (defined $callers_bitmask + && (vec($callers_bitmask, $warnings::Offsets{deprecated}, 1) + || vec($callers_bitmask, $warnings::Offsets{all}, 1))) { + warn <<"EOM"; +$package will be removed from the Perl core distribution in the next major release. Please install it from CPAN. It is being used at $call_file, line $call_line. +EOM + } + } +} + +1; + +__END__ + +package AutoSplit; + +use Exporter (); +use Config qw(%Config); +use File::Basename (); +use File::Path qw(mkpath); +use File::Spec::Functions qw(curdir catfile catdir); +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, + $CheckForAutoloader, $CheckModTime); + +$VERSION = "1.06"; +@ISA = qw(Exporter); +@EXPORT = qw(&autosplit &autosplit_lib_modules); +@EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime); + + +# for portability warn about names longer than $maxlen +$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3 +$Verbose = 1; # 0=none, 1=minimal, 2=list .al files +$Keep = 0; +$CheckForAutoloader = 1; +$CheckModTime = 1; + +my $IndexFile = "autosplit.ix"; # file also serves as timestamp +my $maxflen = 255; +$maxflen = 14 if $Config{'d_flexfnam'} ne 'define'; +if (defined (&Dos::UseLFN)) { + $maxflen = Dos::UseLFN() ? 255 : 11; +} +my $Is_VMS = ($^O eq 'VMS'); + +# allow checking for valid ': attrlist' attachments. +# extra jugglery required to support both 5.8 and 5.9/5.10 features +# (support for 5.8 required for cross-compiling environments) + +my $attr_list = + $] >= 5.009005 ? + eval <<'__QR__' + qr{ + \s* : \s* + (?: + # one attribute + (?> # no backtrack + (?! \d) \w+ + (? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? + ) + (?: \s* : \s* | \s+ (?! :) ) + )* + }x +__QR__ + : + do { + # In pre-5.9.5 world we have to do dirty tricks. + # (we use 'our' rather than 'my' here, due to the rather complex and buggy + # behaviour of lexicals with qr// and (??{$lex}) ) + our $trick1; # yes, cannot our and assign at the same time. + $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x; + our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x; + qr{ \s* : \s* (?: $trick2 )* }x; + }; + +sub autosplit{ + my($file, $autodir, $keep, $ckal, $ckmt) = @_; + # $file - the perl source file to be split (after __END__) + # $autodir - the ".../auto" dir below which to write split subs + # Handle optional flags: + $keep = $Keep unless defined $keep; + $ckal = $CheckForAutoloader unless defined $ckal; + $ckmt = $CheckModTime unless defined $ckmt; + autosplit_file($file, $autodir, $keep, $ckal, $ckmt); +} + +sub carp{ + require Carp; + goto &Carp::carp; +} + +# This function is used during perl building/installation +# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ... + +sub autosplit_lib_modules { + my(@modules) = @_; # list of Module names + local $_; # Avoid clobber. + while (defined($_ = shift @modules)) { + while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ + $_ = catfile($1, $2); + } + s|\\|/|g; # bug in ksh OS/2 + s#^lib/##s; # incase specified as lib/*.pm + my($lib) = catfile(curdir(), "lib"); + if ($Is_VMS) { # may need to convert VMS-style filespecs + $lib =~ s#^\[\]#.\/#; + } + s#^$lib\W+##s; # incase specified as ./lib/*.pm + if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs + my ($dir,$name) = (/(.*])(.*)/s); + $dir =~ s/.*lib[\.\]]//s; + $dir =~ s#[\.\]]#/#g; + $_ = $dir . $name; + } + autosplit_file(catfile($lib, $_), catfile($lib, "auto"), + $Keep, $CheckForAutoloader, $CheckModTime); + } + 0; +} + + +# private functions + +my $self_mod_time = (stat __FILE__)[9]; + +sub autosplit_file { + my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) + = @_; + my(@outfiles); + local($_); + local($/) = "\n"; + + # where to write output files + $autodir ||= catfile(curdir(), "lib", "auto"); + if ($Is_VMS) { + ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; + $filename = VMS::Filespec::unixify($filename); # may have dirs + } + unless (-d $autodir){ + mkpath($autodir,0,0755); + # We should never need to create the auto dir + # here. installperl (or similar) should have done + # it. Expecting it to exist is a valuable sanity check against + # autosplitting into some random directory by mistake. + print "Warning: AutoSplit had to create top-level " . + "$autodir unexpectedly.\n"; + } + + # allow just a package name to be used + $filename .= ".pm" unless ($filename =~ m/\.pm\z/); + + open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n"; + my($pm_mod_time) = (stat($filename))[9]; + my($autoloader_seen) = 0; + my($in_pod) = 0; + my($def_package,$last_package,$this_package,$fnr); + while (<$in>) { + # Skip pod text. + $fnr++; + $in_pod = 1 if /^=\w/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + next if /^\s*#/; + + # record last package name seen + $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/); + ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/; + ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/; + last if /^__END__/; + } + if ($check_for_autoloader && !$autoloader_seen){ + print "AutoSplit skipped $filename: no AutoLoader used\n" + if ($Verbose>=2); + return 0; + } + $_ or die "Can't find __END__ in $filename\n"; + + $def_package or die "Can't find 'package Name;' in $filename\n"; + + my($modpname) = _modpname($def_package); + + # this _has_ to match so we have a reasonable timestamp file + die "Package $def_package ($modpname.pm) does not ". + "match filename $filename" + unless ($filename =~ m/\Q$modpname.pm\E$/ or + ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or + $Is_VMS && $filename =~ m/$modpname.pm/i); + + my($al_idx_file) = catfile($autodir, $modpname, $IndexFile); + + if ($check_mod_time){ + my($al_ts_time) = (stat("$al_idx_file"))[9] || 1; + if ($al_ts_time >= $pm_mod_time and + $al_ts_time >= $self_mod_time){ + print "AutoSplit skipped ($al_idx_file newer than $filename)\n" + if ($Verbose >= 2); + return undef; # one undef, not a list + } + } + + my($modnamedir) = catdir($autodir, $modpname); + print "AutoSplitting $filename ($modnamedir)\n" + if $Verbose; + + unless (-d $modnamedir){ + mkpath($modnamedir,0,0777); + } + + # We must try to deal with some SVR3 systems with a limit of 14 + # characters for file names. Sadly we *cannot* simply truncate all + # file names to 14 characters on these systems because we *must* + # create filenames which exactly match the names used by AutoLoader.pm. + # This is a problem because some systems silently truncate the file + # names while others treat long file names as an error. + + my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames + + my(@subnames, $subname, %proto, %package); + my @cache = (); + my $caching = 1; + $last_package = ''; + my $out; + while (<$in>) { + $fnr++; + $in_pod = 1 if /^=\w/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); + # the following (tempting) old coding gives big troubles if a + # cut is forgotten at EOF: + # next if /^=\w/ .. /^=cut/; + if (/^package\s+([\w:]+)\s*;/) { + $this_package = $def_package = $1; + } + + if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) { + print $out "# end of $last_package\::$subname\n1;\n" + if $last_package; + $subname = $1; + my $proto = $2 || ''; + if ($subname =~ s/(.*):://){ + $this_package = $1; + } else { + $this_package = $def_package; + } + my $fq_subname = "$this_package\::$subname"; + $package{$fq_subname} = $this_package; + $proto{$fq_subname} = $proto; + push(@subnames, $fq_subname); + my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); + $modpname = _modpname($this_package); + my($modnamedir) = catdir($autodir, $modpname); + mkpath($modnamedir,0,0777); + my($lpath) = catfile($modnamedir, "$lname.al"); + my($spath) = catfile($modnamedir, "$sname.al"); + my $path; + + if (!$Is83 and open($out, ">$lpath")){ + $path=$lpath; + print " writing $lpath\n" if ($Verbose>=2); + } else { + open($out, ">$spath") or die "Can't create $spath: $!\n"; + $path=$spath; + print " writing $spath (with truncated name)\n" + if ($Verbose>=1); + } + push(@outfiles, $path); + my $lineno = $fnr - @cache; + print $out < lc($_) } @outfiles; + } else { + @outfiles{@outfiles} = @outfiles; + } + my(%outdirs,@outdirs); + for (@outfiles) { + $outdirs{File::Basename::dirname($_)}||=1; + } + for my $dir (keys %outdirs) { + opendir(my $outdir,$dir); + foreach (sort readdir($outdir)){ + next unless /\.al\z/; + my($file) = catfile($dir, $_); + $file = lc $file if $Is83 or $Is_VMS; + next if $outfiles{$file}; + print " deleting $file\n" if ($Verbose>=2); + my($deleted,$thistime); # catch all versions on VMS + do { $deleted += ($thistime = unlink $file) } while ($thistime); + carp ("Unable to delete $file: $!") unless $deleted; + } + closedir($outdir); + } + } + + open(my $ts,">$al_idx_file") or + carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!"); + print $ts "# Index created by AutoSplit for $filename\n"; + print $ts "# (file acts as timestamp)\n"; + $last_package = ''; + for my $fqs (@subnames) { + my($subname) = $fqs; + $subname =~ s/.*:://; + print $ts "package $package{$fqs};\n" + unless $last_package eq $package{$fqs}; + print $ts "sub $subname $proto{$fqs};\n"; + $last_package = $package{$fqs}; + } + print $ts "1;\n"; + close($ts); + + _check_unique($filename, $Maxlen, 1, @outfiles); + + @outfiles; +} + +sub _modpname ($) { + my($package) = @_; + my $modpname = $package; + if ($^O eq 'MSWin32') { + $modpname =~ s#::#\\#g; + } else { + my @modpnames = (); + while ($modpname =~ m#(.*?[^:])::([^:].*)#) { + push @modpnames, $1; + $modpname = $2; + } + $modpname = catfile(@modpnames, $modpname); + } + if ($Is_VMS) { + $modpname = VMS::Filespec::unixify($modpname); # may have dirs + } + $modpname; +} + +sub _check_unique { + my($filename, $maxlen, $warn, @outfiles) = @_; + my(%notuniq) = (); + my(%shorts) = (); + my(@toolong) = grep( + length(File::Basename::basename($_)) + > $maxlen, + @outfiles + ); + + foreach (@toolong){ + my($dir) = File::Basename::dirname($_); + my($file) = File::Basename::basename($_); + my($trunc) = substr($file,0,$maxlen); + $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc}; + $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ? + "$shorts{$dir}{$trunc}, $file" : $file; + } + if (%notuniq && $warn){ + print "$filename: some names are not unique when " . + "truncated to $maxlen characters:\n"; + foreach my $dir (sort keys %notuniq){ + print " directory $dir:\n"; + foreach my $trunc (sort keys %{$notuniq{$dir}}) { + print " $shorts{$dir}{$trunc} truncate to $trunc\n"; + } + } + } +} + +1; +__END__ + +# test functions so AutoSplit.pm can be applied to itself: +sub test1 ($) { "test 1\n"; } +sub test2 ($$) { "test 2\n"; } +sub test3 ($$$) { "test 3\n"; } +sub testtesttesttest4_1 { "test 4\n"; } +sub testtesttesttest4_2 { "duplicate test 4\n"; } +sub Just::Another::test5 { "another test 5\n"; } +sub test6 { return join ":", __FILE__,__LINE__; } +package Yet::Another::AutoSplit; +sub testtesttesttest4_1 ($) { "another test 4\n"; } +sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; } +package Yet::More::Attributes; +sub test_a1 ($) : locked :locked { 1; } +sub test_a2 : locked { 1; } +package diagnostics; + + +use strict; +use 5.009001; +use Carp; +$Carp::Internal{__PACKAGE__.""}++; + +our $VERSION = '1.36'; +our $DEBUG; +our $VERBOSE; +our $PRETTY; +our $TRACEONLY = 0; +our $WARNTRACE = 0; + +use Config; +use Text::Tabs 'expand'; +my $privlib = $Config{privlibexp}; +if ($^O eq 'VMS') { + require VMS::Filespec; + $privlib = VMS::Filespec::unixify($privlib); +} +my @trypod = ( + "$privlib/pod/perldiag.pod", + "$privlib/pods/perldiag.pod", + ); +# handy for development testing of new warnings etc +unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod"; +(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0]; + +$DEBUG ||= 0; + +local $| = 1; +local $_; +local $.; + +my $standalone; +my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7); + +CONFIG: { + our $opt_p = our $opt_d = our $opt_v = our $opt_f = ''; + + unless (caller) { + $standalone++; + require Getopt::Std; + Getopt::Std::getopts('pdvf:') + or die "Usage: $0 [-v] [-p] [-f splainpod]"; + $PODFILE = $opt_f if $opt_f; + $DEBUG = 2 if $opt_d; + $VERBOSE = $opt_v; + $PRETTY = $opt_p; + } + + if (open(POD_DIAG, '<', $PODFILE)) { + warn "Happy happy podfile from real $PODFILE\n" if $DEBUG; + last CONFIG; + } + + if (caller) { + INCPATH: { + for my $file ( (map { "$_/".__PACKAGE__.".pm" } @INC), $0) { + warn "Checking $file\n" if $DEBUG; + if (open(POD_DIAG, '<', $file)) { + while () { + next unless + /^__END__\s*# wish diag dbase were more accessible/; + print STDERR "podfile is $file\n" if $DEBUG; + last INCPATH; + } + } + } + } + } else { + print STDERR "podfile is \n" if $DEBUG; + *POD_DIAG = *main::DATA; + } +} +if (eof(POD_DIAG)) { + die "couldn't find diagnostic data in $PODFILE @INC $0"; +} + + +%HTML_2_Troff = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A\\*'", # capital A, acute accent + # etc + +); + +%HTML_2_Latin_1 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1" # capital A, acute accent + + # etc +); + +%HTML_2_ASCII_7 = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "A" # capital A, acute accent + # etc +); + +our %HTML_Escapes; +*HTML_Escapes = do { + if ($standalone) { + $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7; + } else { + \%HTML_2_Latin_1; + } +}; + +*THITHER = $standalone ? *STDOUT : *STDERR; + +my %transfmt = (); +my $transmo = <) { + + sub _split_pod_link { + $_[0] =~ m'(?:([^|]*)\|)?([^/]*)(?:/("?)(.*)\3)?'s; + ($1,$2,$4); + } + + unescape(); + if ($PRETTY) { + sub noop { return $_[0] } # spensive for a noop + sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; } + sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; } + s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges; + s/[IF]<(.*?)>/italic($1)/ges; + s/L<(.*?)>/ + my($text,$page,$sect) = _split_pod_link($1); + defined $text + ? $text + : defined $sect + ? italic($sect) . ' in ' . italic($page) + : italic($page) + /ges; + s/S<(.*?)>/ + $1 + /ges; + } else { + s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs; + s/[IF]<(.*?)>/$1/gs; + s/L<(.*?)>/ + my($text,$page,$sect) = _split_pod_link($1); + defined $text + ? $text + : defined $sect + ? qq '"$sect" in $page' + : $page + /ges; + s/S<(.*?)>/ + $1 + /ges; + } + unless (/^=/) { + if (defined $header) { + if ( $header eq 'DESCRIPTION' && + ( /Optional warnings are enabled/ + || /Some of these messages are generic./ + ) ) + { + next; + } + $_ = expand $_; + s/^/ /gm; + $msg{$header} .= $_; + for my $h(@headers) { $msg{$h} .= $_ } + ++$seen_body; + undef $for_item; + } + next; + } + + # If we have not come across the body of the description yet, then + # the previous header needs to share the same description. + if ($seen_body) { + @headers = (); + } + else { + push @headers, $header if defined $header; + } + + if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) { + + if ( s/=head1\sDESCRIPTION//) { + $msg{$header = 'DESCRIPTION'} = ''; + undef $for_item; + } + elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) { + $for_item = $1; + } + elsif( /^=over\b/ ) { + $over_level++; + } + elsif( /^=back\b/ ) { # Stop processing body here + $over_level--; + if ($over_level == 0) { + undef $header; + undef $for_item; + $seen_body = 0; + next; + } + } + next; + } + + if( $for_item ) { $header = $for_item; undef $for_item } + else { + $header = $1; + + $header =~ s/\n/ /gs; # Allow multi-line headers + } + + # strip formatting directives from =item line + $header =~ s/[A-Z]<(.*?)>/$1/g; + + # Since we strip "(\.\s*)\n" when we search a warning, strip it here as well + $header =~ s/(\.\s*)?$//; + + my @toks = split( /(%l?[dxX]|%[ucp]|%(?:\.\d+)?[fs])/, $header ); + if (@toks > 1) { + my $conlen = 0; + for my $i (0..$#toks){ + if( $i % 2 ){ + if( $toks[$i] eq '%c' ){ + $toks[$i] = '.'; + } elsif( $toks[$i] =~ /^%(?:d|u)$/ ){ + $toks[$i] = '\d+'; + } elsif( $toks[$i] =~ '^%(?:s|.*f)$' ){ + $toks[$i] = $i == $#toks ? '.*' : '.*?'; + } elsif( $toks[$i] =~ '%.(\d+)s' ){ + $toks[$i] = ".{$1}"; + } elsif( $toks[$i] =~ '^%l*([pxX])$' ){ + $toks[$i] = $1 eq 'X' ? '[\dA-F]+' : '[\da-f]+'; + } + } elsif( length( $toks[$i] ) ){ + $toks[$i] = quotemeta $toks[$i]; + $conlen += length( $toks[$i] ); + } + } + my $lhs = join( '', @toks ); + $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match + $transfmt{$header}{pat} = + " s^\\s*$lhs\\s*\Q$header\Es\n\t&& return 1;\n"; + $transfmt{$header}{len} = $conlen; + } else { + my $lhs = "\Q$header\E"; + $lhs =~ s/(\\\s)+/\\s+/g; # Replace lit space with multi-space match + $transfmt{$header}{pat} = + " s^\\s*$lhs\\s*\Q$header\E\n\t && return 1;\n"; + $transfmt{$header}{len} = length( $header ); + } + + print STDERR __PACKAGE__.": Duplicate entry: \"$header\"\n" + if $msg{$header}; + + $msg{$header} = ''; + $seen_body = 0; + } + + + close POD_DIAG unless *main::DATA eq *POD_DIAG; + + die "No diagnostics?" unless %msg; + + # Apply patterns in order of decreasing sum of lengths of fixed parts + # Seems the best way of hitting the right one. + for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} } + keys %transfmt ){ + $transmo .= $transfmt{$hdr}{pat}; + } + $transmo .= " return 0;\n}\n"; + print STDERR $transmo if $DEBUG; + eval $transmo; + die $@ if $@; +} + +if ($standalone) { + if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" } + while (defined (my $error = <>)) { + splainthis($error) || print THITHER $error; + } + exit; +} + +my $olddie; +my $oldwarn; + +sub import { + shift; + $^W = 1; # yup, clobbered the global variable; + # tough, if you want diags, you want diags. + return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap); + + for (@_) { + + /^-d(ebug)?$/ && do { + $DEBUG++; + next; + }; + + /^-v(erbose)?$/ && do { + $VERBOSE++; + next; + }; + + /^-p(retty)?$/ && do { + print STDERR "$0: I'm afraid it's too late for prettiness.\n"; + $PRETTY++; + next; + }; + # matches trace and traceonly for legacy doc mixup reasons + /^-t(race(only)?)?$/ && do { + $TRACEONLY++; + next; + }; + /^-w(arntrace)?$/ && do { + $WARNTRACE++; + next; + }; + + warn "Unknown flag: $_"; + } + + $oldwarn = $SIG{__WARN__}; + $olddie = $SIG{__DIE__}; + $SIG{__WARN__} = \&warn_trap; + $SIG{__DIE__} = \&death_trap; +} + +sub enable { &import } + +sub disable { + shift; + return unless $SIG{__WARN__} eq \&warn_trap; + $SIG{__WARN__} = $oldwarn || ''; + $SIG{__DIE__} = $olddie || ''; +} + +sub warn_trap { + my $warning = $_[0]; + if (caller eq __PACKAGE__ or !splainthis($warning)) { + if ($WARNTRACE) { + print STDERR Carp::longmess($warning); + } else { + print STDERR $warning; + } + } + goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap; +}; + +sub death_trap { + my $exception = $_[0]; + + # See if we are coming from anywhere within an eval. If so we don't + # want to explain the exception because it's going to get caught. + my $in_eval = 0; + my $i = 0; + while (my $caller = (caller($i++))[3]) { + if ($caller eq '(eval)') { + $in_eval = 1; + last; + } + } + + splainthis($exception) unless $in_eval; + if (caller eq __PACKAGE__) { + print STDERR "INTERNAL EXCEPTION: $exception"; + } + &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap; + + return if $in_eval; + + # We don't want to unset these if we're coming from an eval because + # then we've turned off diagnostics. + + # Switch off our die/warn handlers so we don't wind up in our own + # traps. + $SIG{__DIE__} = $SIG{__WARN__} = ''; + + $exception =~ s/\n(?=.)/\n\t/gas; + + die Carp::longmess("__diagnostics__") + =~ s/^__diagnostics__.*?line \d+\.?\n/ + "Uncaught exception from user code:\n\t$exception" + /re; + # up we go; where we stop, nobody knows, but i think we die now + # but i'm deeply afraid of the &$olddie guy reraising and us getting + # into an indirect recursion loop +}; + +my %exact_duplicate; +my %old_diag; +my $count; +my $wantspace; +sub splainthis { + return 0 if $TRACEONLY; + for (my $tmp = shift) { + local $\; + local $!; + ### &finish_compilation unless %msg; + s/(\.\s*)?\n+$//; + my $orig = $_; + # return unless defined; + + # get rid of the where-are-we-in-input part + s/, <.*?> (?:line|chunk).*$//; + + # Discard 1st " at line " and all text beyond + # but be aware of messages containing " at this-or-that" + my $real = 0; + my @secs = split( / at / ); + return unless @secs; + $_ = $secs[0]; + for my $i ( 1..$#secs ){ + if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){ + $real = 1; + last; + } else { + $_ .= ' at ' . $secs[$i]; + } + } + + # remove parenthesis occurring at the end of some messages + s/^\((.*)\)$/$1/; + + if ($exact_duplicate{$orig}++) { + return &transmo; + } else { + return 0 unless &transmo; + } + + my $short = shorten($orig); + if ($old_diag{$_}) { + autodescribe(); + print THITHER "$short (#$old_diag{$_})\n"; + $wantspace = 1; + } elsif (!$msg{$_} && $orig =~ /\n./s) { + # A multiline message, like "Attempt to reload / + # Compilation failed" + my $found; + for (split /^/, $orig) { + splainthis($_) and $found = 1; + } + return $found; + } else { + autodescribe(); + $old_diag{$_} = ++$count; + print THITHER "\n" if $wantspace; + $wantspace = 0; + print THITHER "$short (#$old_diag{$_})\n"; + if ($msg{$_}) { + print THITHER $msg{$_}; + } else { + if (0 and $standalone) { + print THITHER " **** Error #$old_diag{$_} ", + ($real ? "is" : "appears to be"), + " an unknown diagnostic message.\n\n"; + } + return 0; + } + } + return 1; + } +} + +sub autodescribe { + if ($VERBOSE and not $count) { + print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"), + "\n$msg{DESCRIPTION}\n"; + } +} + +sub unescape { + s { + E< + ( [A-Za-z]+ ) + > + } { + do { + exists $HTML_Escapes{$1} + ? do { $HTML_Escapes{$1} } + : do { + warn "Unknown escape: E<$1> in $_"; + "E<$1>"; + } + } + }egx; +} + +sub shorten { + my $line = $_[0]; + if (length($line) > 79 and index($line, "\n") == -1) { + my $space_place = rindex($line, ' ', 79); + if ($space_place != -1) { + substr($line, $space_place, 1) = "\n\t"; + } + } + return $line; +} + + +1 unless $standalone; # or it'll complain about itself +__END__ # wish diag dbase were more accessible +package ok; +our $VERSION = '1.302133'; + +use strict; +use Test::More (); + +sub import { + shift; + + if (@_) { + goto &Test::More::pass if $_[0] eq 'ok'; + goto &Test::More::use_ok; + } + + # No argument list - croak as if we are prototyped like use_ok() + my (undef, $file, $line) = caller(); + ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; +} + + +__END__ + +package Safe; + +use 5.003_11; +use Scalar::Util qw(reftype refaddr); + +$Safe::VERSION = "2.40"; + +# *** Don't declare any lexicals above this point *** +# +# This function should return a closure which contains an eval that can't +# see any lexicals in scope (apart from __ExPr__ which is unavoidable) + +sub lexless_anon_sub { + # $_[0] is package; + # $_[1] is strict flag; + my $__ExPr__ = $_[2]; # must be a lexical to create the closure that + # can be used to pass the value into the safe + # world + + # Create anon sub ref in root of compartment. + # Uses a closure (on $__ExPr__) to pass in the code to be executed. + # (eval on one line to keep line numbers as expected by caller) + eval sprintf + 'package %s; %s sub { @_=(); eval q[local *SIG; my $__ExPr__;] . $__ExPr__; }', + $_[0], $_[1] ? 'use strict;' : ''; +} + +use strict; +use Carp; +BEGIN { eval q{ + use Carp::Heavy; +} } + +use B (); +BEGIN { + no strict 'refs'; + if (defined &B::sub_generation) { + *sub_generation = \&B::sub_generation; + } + else { + # fake sub generation changing for perls < 5.8.9 + my $sg; *sub_generation = sub { ++$sg }; + } +} + +use Opcode 1.01, qw( + opset opset_to_ops opmask_add + empty_opset full_opset invert_opset verify_opset + opdesc opcodes opmask define_optag opset_to_hex +); + +*ops_to_opset = \&opset; # Temporary alias for old Penguins + +# Regular expressions and other unicode-aware code may need to call +# utf8->SWASHNEW (via perl's utf8.c). That will fail unless we share the +# SWASHNEW method. +# Sadly we can't just add utf8::SWASHNEW to $default_share because perl's +# utf8.c code does a fetchmethod on SWASHNEW to check if utf8.pm is loaded, +# and sharing makes it look like the method exists. +# The simplest and most robust fix is to ensure the utf8 module is loaded when +# Safe is loaded. Then we can add utf8::SWASHNEW to $default_share. +require utf8; +# we must ensure that utf8_heavy.pl, where SWASHNEW is defined, is loaded +# but without depending on too much knowledge of that implementation detail. +# This code (//i on a unicode string) should ensure utf8 is fully loaded +# and also loads the ToFold SWASH, unless things change so that these +# particular code points don't cause it to load. +# (Swashes are cached internally by perl in PL_utf8_* variables +# independent of being inside/outside of Safe. So once loaded they can be) +do { my $a = pack('U',0x100); my $b = chr 0x101; utf8::upgrade $b; $a =~ /$b/i }; +# now we can safely include utf8::SWASHNEW in $default_share defined below. + +my $default_root = 0; +# share *_ and functions defined in universal.c +# Don't share stuff like *UNIVERSAL:: otherwise code from the +# compartment can 0wn functions in UNIVERSAL +my $default_share = [qw[ + *_ + &PerlIO::get_layers + &UNIVERSAL::isa + &UNIVERSAL::can + &UNIVERSAL::VERSION + &utf8::is_utf8 + &utf8::valid + &utf8::encode + &utf8::decode + &utf8::upgrade + &utf8::downgrade + &utf8::native_to_unicode + &utf8::unicode_to_native + &utf8::SWASHNEW + $version::VERSION + $version::CLASS + $version::STRICT + $version::LAX + @version::ISA +], ($] < 5.010 && qw[ + &utf8::SWASHGET +]), ($] >= 5.008001 && qw[ + &Regexp::DESTROY +]), ($] >= 5.010 && qw[ + &re::is_regexp + &re::regname + &re::regnames + &re::regnames_count + &UNIVERSAL::DOES + &version::() + &version::new + &version::("" + &version::stringify + &version::(0+ + &version::numify + &version::normal + &version::(cmp + &version::(<=> + &version::vcmp + &version::(bool + &version::boolean + &version::(nomethod + &version::noop + &version::is_alpha + &version::qv + &version::vxs::declare + &version::vxs::qv + &version::vxs::_VERSION + &version::vxs::stringify + &version::vxs::new + &version::vxs::parse + &version::vxs::VCMP +]), ($] >= 5.011 && qw[ + &re::regexp_pattern +]), ($] >= 5.010 && $] < 5.014 && qw[ + &Tie::Hash::NamedCapture::FETCH + &Tie::Hash::NamedCapture::STORE + &Tie::Hash::NamedCapture::DELETE + &Tie::Hash::NamedCapture::CLEAR + &Tie::Hash::NamedCapture::EXISTS + &Tie::Hash::NamedCapture::FIRSTKEY + &Tie::Hash::NamedCapture::NEXTKEY + &Tie::Hash::NamedCapture::SCALAR + &Tie::Hash::NamedCapture::flags +])]; +if (defined $Devel::Cover::VERSION) { + push @$default_share, '&Devel::Cover::use_file'; +} + +sub new { + my($class, $root, $mask) = @_; + my $obj = {}; + bless $obj, $class; + + if (defined($root)) { + croak "Can't use \"$root\" as root name" + if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; + $obj->{Root} = $root; + $obj->{Erase} = 0; + } + else { + $obj->{Root} = "Safe::Root".$default_root++; + $obj->{Erase} = 1; + } + + # use permit/deny methods instead till interface issues resolved + # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; + croak "Mask parameter to new no longer supported" if defined $mask; + $obj->permit_only(':default'); + + # We must share $_ and @_ with the compartment or else ops such + # as split, length and so on won't default to $_ properly, nor + # will passing argument to subroutines work (via @_). In fact, + # for reasons I don't completely understand, we need to share + # the whole glob *_ rather than $_ and @_ separately, otherwise + # @_ in non default packages within the compartment don't work. + $obj->share_from('main', $default_share); + + Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); + + return $obj; +} + +sub DESTROY { + my $obj = shift; + $obj->erase('DESTROY') if $obj->{Erase}; +} + +sub erase { + my ($obj, $action) = @_; + my $pkg = $obj->root(); + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "main::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + # The 'my $foo' is needed! Without it you get an + # 'Attempt to free unreferenced scalar' warning! + my $stem_symtab = *{$stem}{HASH}; + + #warn "erase($pkg) stem=$stem, leaf=$leaf"; + #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; + # ", join(', ', %$stem_symtab),"\n"; + +# delete $stem_symtab->{$leaf}; + + my $leaf_glob = $stem_symtab->{$leaf}; + my $leaf_symtab = *{$leaf_glob}{HASH}; +# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; + %$leaf_symtab = (); + #delete $leaf_symtab->{'__ANON__'}; + #delete $leaf_symtab->{'foo'}; + #delete $leaf_symtab->{'main::'}; +# my $foo = undef ${"$stem\::"}{"$leaf\::"}; + + if ($action and $action eq 'DESTROY') { + delete $stem_symtab->{$leaf}; + } else { + $obj->share_from('main', $default_share); + } + 1; +} + + +sub reinit { + my $obj= shift; + $obj->erase; + $obj->share_redo; +} + +sub root { + my $obj = shift; + croak("Safe root method now read-only") if @_; + return $obj->{Root}; +} + + +sub mask { + my $obj = shift; + return $obj->{Mask} unless @_; + $obj->deny_only(@_); +} + +# v1 compatibility methods +sub trap { shift->deny(@_) } +sub untrap { shift->permit(@_) } + +sub deny { + my $obj = shift; + $obj->{Mask} |= opset(@_); +} +sub deny_only { + my $obj = shift; + $obj->{Mask} = opset(@_); +} + +sub permit { + my $obj = shift; + # XXX needs testing + $obj->{Mask} &= invert_opset opset(@_); +} +sub permit_only { + my $obj = shift; + $obj->{Mask} = invert_opset opset(@_); +} + + +sub dump_mask { + my $obj = shift; + print opset_to_hex($obj->{Mask}),"\n"; +} + + +sub share { + my($obj, @vars) = @_; + $obj->share_from(scalar(caller), \@vars); +} + + +sub share_from { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $no_record = shift || 0; + my $root = $obj->root(); + croak("vars not an array ref") unless ref $vars eq 'ARRAY'; + no strict 'refs'; + # Check that 'from' package actually exists + croak("Package \"$pkg\" does not exist") + unless keys %{"$pkg\::"}; + my $arg; + foreach $arg (@$vars) { + # catch some $safe->share($var) errors: + my ($var, $type); + $type = $1 if ($var = $arg) =~ s/^(\W)//; + # warn "share_from $pkg $type $var"; + for (1..2) { # assign twice to avoid any 'used once' warnings + *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} + : ($type eq '&') ? \&{$pkg."::$var"} + : ($type eq '$') ? \${$pkg."::$var"} + : ($type eq '@') ? \@{$pkg."::$var"} + : ($type eq '%') ? \%{$pkg."::$var"} + : ($type eq '*') ? *{$pkg."::$var"} + : croak(qq(Can't share "$type$var" of unknown type)); + } + } + $obj->share_record($pkg, $vars) unless $no_record or !$vars; +} + + +sub share_record { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + # Record shares using keys of $obj->{Shares}. See reinit. + @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; +} + + +sub share_redo { + my $obj = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + my($var, $pkg); + while(($var, $pkg) = each %$shares) { + # warn "share_redo $pkg\:: $var"; + $obj->share_from($pkg, [ $var ], 1); + } +} + + +sub share_forget { + delete shift->{Shares}; +} + + +sub varglob { + my ($obj, $var) = @_; + no strict 'refs'; + return *{$obj->root()."::$var"}; +} + +sub _clean_stash { + my ($root, $saved_refs) = @_; + $saved_refs ||= []; + no strict 'refs'; + foreach my $hook (qw(DESTROY AUTOLOAD), grep /^\(/, keys %$root) { + push @$saved_refs, \*{$root.$hook}; + delete ${$root}{$hook}; + } + + for (grep /::$/, keys %$root) { + next if \%{$root.$_} eq \%$root; + _clean_stash($root.$_, $saved_refs); + } +} + +sub reval { + my ($obj, $expr, $strict) = @_; + die "Bad Safe object" unless $obj->isa('Safe'); + + my $root = $obj->{Root}; + + my $evalsub = lexless_anon_sub($root, $strict, $expr); + # propagate context + my $sg = sub_generation(); + my @subret; + if (defined wantarray) { + @subret = (wantarray) + ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) + : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); + } + else { + Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); + } + _clean_stash($root.'::') if $sg != sub_generation(); + $obj->wrap_code_refs_within(@subret); + return (wantarray) ? @subret : $subret[0]; +} + +my %OID; + +sub wrap_code_refs_within { + my $obj = shift; + + %OID = (); + $obj->_find_code_refs('wrap_code_ref', @_); +} + + +sub _find_code_refs { + my $obj = shift; + my $visitor = shift; + + for my $item (@_) { + my $reftype = $item && reftype $item + or next; + + # skip references already seen + next if ++$OID{refaddr $item} > 1; + + if ($reftype eq 'ARRAY') { + $obj->_find_code_refs($visitor, @$item); + } + elsif ($reftype eq 'HASH') { + $obj->_find_code_refs($visitor, values %$item); + } + # XXX GLOBs? + elsif ($reftype eq 'CODE') { + $item = $obj->$visitor($item); + } + } +} + + +sub wrap_code_ref { + my ($obj, $sub) = @_; + die "Bad safe object" unless $obj->isa('Safe'); + + # wrap code ref $sub with _safe_call_sv so that, when called, the + # execution will happen with the compartment fully 'in effect'. + + croak "Not a CODE reference" + if reftype $sub ne 'CODE'; + + my $ret = sub { + my @args = @_; # lexical to close over + my $sub_with_args = sub { $sub->(@args) }; + + my @subret; + my $error; + do { + local $@; # needed due to perl_call_sv(sv, G_EVAL|G_KEEPERR) + my $sg = sub_generation(); + @subret = (wantarray) + ? Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args) + : scalar Opcode::_safe_call_sv($obj->{Root}, $obj->{Mask}, $sub_with_args); + $error = $@; + _clean_stash($obj->{Root}.'::') if $sg != sub_generation(); + }; + if ($error) { # rethrow exception + $error =~ s/\t\(in cleanup\) //; # prefix added by G_KEEPERR + die $error; + } + return (wantarray) ? @subret : $subret[0]; + }; + + return $ret; +} + + +sub rdo { + my ($obj, $file) = @_; + die "Bad Safe object" unless $obj->isa('Safe'); + + my $root = $obj->{Root}; + + my $sg = sub_generation(); + my $evalsub = eval + sprintf('package %s; sub { @_ = (); do $file }', $root); + my @subret = (wantarray) + ? Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub) + : scalar Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); + _clean_stash($root.'::') if $sg != sub_generation(); + $obj->wrap_code_refs_within(@subret); + return (wantarray) ? @subret : $subret[0]; +} + + +1; + +__END__ + + +package Env; + +our $VERSION = '1.04'; + + +sub import { + my ($callpack) = caller(0); + my $pack = shift; + my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV)); + return unless @vars; + + @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars; + + eval "package $callpack; use vars qw(" . join(' ', @vars) . ")"; + die $@ if $@; + foreach (@vars) { + my ($type, $name) = m/^([\$\@])(.*)$/; + if ($type eq '$') { + tie ${"${callpack}::$name"}, Env, $name; + } else { + if ($^O eq 'VMS') { + tie @{"${callpack}::$name"}, Env::Array::VMS, $name; + } else { + tie @{"${callpack}::$name"}, Env::Array, $name; + } + } + } +} + +sub TIESCALAR { + bless \($_[1]); +} + +sub FETCH { + my ($self) = @_; + $ENV{$$self}; +} + +sub STORE { + my ($self, $value) = @_; + if (defined($value)) { + $ENV{$$self} = $value; + } else { + delete $ENV{$$self}; + } +} + +###################################################################### + +package Env::Array; + +use Config; +use Tie::Array; + +@ISA = qw(Tie::Array); + +my $sep = $Config::Config{path_sep}; + +sub TIEARRAY { + bless \($_[1]); +} + +sub FETCHSIZE { + my ($self) = @_; + return 1 + scalar(() = $ENV{$$self} =~ /\Q$sep\E/g); +} + +sub STORESIZE { + my ($self, $size) = @_; + my @temp = split($sep, $ENV{$$self}); + $#temp = $size - 1; + $ENV{$$self} = join($sep, @temp); +} + +sub CLEAR { + my ($self) = @_; + $ENV{$$self} = ''; +} + +sub FETCH { + my ($self, $index) = @_; + return (split($sep, $ENV{$$self}))[$index]; +} + +sub STORE { + my ($self, $index, $value) = @_; + my @temp = split($sep, $ENV{$$self}); + $temp[$index] = $value; + $ENV{$$self} = join($sep, @temp); + return $value; +} + +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { + my ($self, $index) = @_; + my @temp = split($sep, $ENV{$$self}); + my $value = splice(@temp, $index, 1, ()); + $ENV{$$self} = join($sep, @temp); + return $value; +} + +sub PUSH { + my $self = shift; + my @temp = split($sep, $ENV{$$self}); + push @temp, @_; + $ENV{$$self} = join($sep, @temp); + return scalar(@temp); +} + +sub POP { + my ($self) = @_; + my @temp = split($sep, $ENV{$$self}); + my $result = pop @temp; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub UNSHIFT { + my $self = shift; + my @temp = split($sep, $ENV{$$self}); + my $result = unshift @temp, @_; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub SHIFT { + my ($self) = @_; + my @temp = split($sep, $ENV{$$self}); + my $result = shift @temp; + $ENV{$$self} = join($sep, @temp); + return $result; +} + +sub SPLICE { + my $self = shift; + my $offset = shift; + my $length = shift; + my @temp = split($sep, $ENV{$$self}); + if (wantarray) { + my @result = splice @temp, $offset, $length, @_; + $ENV{$$self} = join($sep, @temp); + return @result; + } else { + my $result = scalar splice @temp, $offset, $length, @_; + $ENV{$$self} = join($sep, @temp); + return $result; + } +} + +###################################################################### + +package Env::Array::VMS; +use Tie::Array; + +@ISA = qw(Tie::Array); + +sub TIEARRAY { + bless \($_[1]); +} + +sub FETCHSIZE { + my ($self) = @_; + my $i = 0; + while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; }; + return $i; +} + +sub FETCH { + my ($self, $index) = @_; + return $ENV{$$self . ';' . $index}; +} + +sub EXISTS { + my ($self, $index) = @_; + return $index < $self->FETCHSIZE; +} + +sub DELETE { } + +1; +# FindBin.pm +# +# Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. + + +package FindBin; +use Carp; +require 5.000; +require Exporter; +use Cwd qw(getcwd cwd abs_path); +use File::Basename; +use File::Spec; + +@EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); +%EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); +@ISA = qw(Exporter); + +$VERSION = "1.51"; + + +# needed for VMS-specific filename translation +if( $^O eq 'VMS' ) { + require VMS::Filespec; + VMS::Filespec->import; +} + +sub cwd2 { + my $cwd = getcwd(); + # getcwd might fail if it hasn't access to the current directory. + # try harder. + defined $cwd or $cwd = cwd(); + $cwd; +} + +sub init +{ + *Dir = \$Bin; + *RealDir = \$RealBin; + + if($0 eq '-e' || $0 eq '-') + { + # perl invoked with -e or script is on C + $Script = $RealScript = $0; + $Bin = $RealBin = cwd2(); + $Bin = VMS::Filespec::unixify($Bin) if $^O eq 'VMS'; + } + else + { + my $script = $0; + + if ($^O eq 'VMS') + { + ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*[\]>\/]+)(.*)/s; + # C isn't going to work, so unixify first + ($Bin = VMS::Filespec::unixify($Bin)) =~ s/\/\z//; + ($RealBin,$RealScript) = ($Bin,$Script); + } + else + { + croak("Cannot find current script '$0'") unless(-f $script); + + # Ensure $script contains the complete path in case we C + + $script = File::Spec->catfile(cwd2(), $script) + unless File::Spec->file_name_is_absolute($script); + + ($Script,$Bin) = fileparse($script); + + # Resolve $script if it is a link + while(1) + { + my $linktext = readlink($script); + + ($RealScript,$RealBin) = fileparse($script); + last unless defined $linktext; + + $script = (File::Spec->file_name_is_absolute($linktext)) + ? $linktext + : File::Spec->catfile($RealBin, $linktext); + } + + # Get absolute paths to directories + if ($Bin) { + my $BinOld = $Bin; + $Bin = abs_path($Bin); + defined $Bin or $Bin = File::Spec->canonpath($BinOld); + } + $RealBin = abs_path($RealBin) if($RealBin); + } + } +} + +BEGIN { init } + +*again = \&init; + +1; # Keep require happy +package Symbol; + + +BEGIN { require 5.005; } + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(gensym ungensym qualify qualify_to_ref); +@EXPORT_OK = qw(delete_package geniosym); + +$VERSION = '1.08'; + +my $genpkg = "Symbol::"; +my $genseq = 0; + +my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT); + +# +# Note that we never _copy_ the glob; we just make a ref to it. +# If we did copy it, then SVf_FAKE would be set on the copy, and +# glob-specific behaviors (e.g. C<*$ref = \&func>) wouldn't work. +# +sub gensym () { + my $name = "GEN" . $genseq++; + my $ref = \*{$genpkg . $name}; + delete $$genpkg{$name}; + $ref; +} + +sub geniosym () { + my $sym = gensym(); + # force the IO slot to be filled + select(select $sym); + *$sym{IO}; +} + +sub ungensym ($) {} + +sub qualify ($;$) { + my ($name) = @_; + if (!ref($name) && index($name, '::') == -1 && index($name, "'") == -1) { + my $pkg; + # Global names: special character, "^xyz", or other. + if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) { + # RGS 2001-11-05 : translate leading ^X to control-char + $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei; + $pkg = "main"; + } + else { + $pkg = (@_ > 1) ? $_[1] : caller; + } + $name = $pkg . "::" . $name; + } + $name; +} + +sub qualify_to_ref ($;$) { + return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller }; +} + +# +# of Safe.pm lineage +# +sub delete_package ($) { + my $pkg = shift; + + # expand to full symbol table name if needed + + unless ($pkg =~ /^main::.*::$/) { + $pkg = "main$pkg" if $pkg =~ /^::/; + $pkg = "main::$pkg" unless $pkg =~ /^main::/; + $pkg .= '::' unless $pkg =~ /::$/; + } + + my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + my $stem_symtab = *{$stem}{HASH}; + return unless defined $stem_symtab and exists $stem_symtab->{$leaf}; + + + # free all the symbols in the package + + my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; + foreach my $name (keys %$leaf_symtab) { + undef *{$pkg . $name}; + } + + # delete the symbol table + + %$leaf_symtab = (); + delete $stem_symtab->{$leaf}; +} + +1; +package blib; + + +use Cwd; +use File::Spec; + +our $VERSION = '1.07'; +our $Verbose = 0; + +sub import +{ + my $package = shift; + my $dir; + if ($^O eq "MSWin32" && -f "Win32.xs") { + # We don't use getcwd() on Windows because it will internally + # call Win32::GetCwd(), which will get the Win32 module loaded. + # That means that it would not be possible to run `make test` + # for the Win32 module because blib.pm would always load the + # installed version before @INC gets updated with the blib path. + chomp($dir = `cd`); + } + else { + $dir = getcwd; + } + if ($^O eq 'VMS') { ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--; } + if (@_) + { + $dir = shift; + $dir =~ s/blib\z//; + $dir =~ s,/+\z,,; + $dir = File::Spec->curdir unless ($dir); + die "$dir is not a directory\n" unless (-d $dir); + } + + # detaint: if the user asked for blib, s/he presumably knew + # what s/he wanted + $dir = $1 if $dir =~ /^(.*)$/; + + my $i = 5; + my($blib, $blib_lib, $blib_arch); + while ($i--) + { + $blib = File::Spec->catdir($dir, "blib"); + $blib_lib = File::Spec->catdir($blib, "lib"); + $blib_arch = File::Spec->catdir($blib, "arch"); + + if (-d $blib && -d $blib_arch && -d $blib_lib) + { + unshift(@INC,$blib_arch,$blib_lib); + warn "Using $blib\n" if $Verbose; + return; + } + $dir = File::Spec->catdir($dir, File::Spec->updir); + } + die "Cannot find blib even in $dir\n"; +} + +1; +package autouse; + +#use strict; # debugging only +use 5.006; # use warnings + +$autouse::VERSION = '1.11'; + +$autouse::DEBUG ||= 0; + +sub vet_import ($); + +sub croak { + require Carp; + Carp::croak(@_); +} + +sub import { + my $class = @_ ? shift : 'autouse'; + croak "usage: use $class MODULE [,SUBS...]" unless @_; + my $module = shift; + + (my $pm = $module) =~ s{::}{/}g; + $pm .= '.pm'; + if (exists $INC{$pm}) { + vet_import $module; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + # $Exporter::Verbose = 1; + return $module->import(map { (my $f = $_) =~ s/\(.*?\)$//; $f } @_); + } + + # It is not loaded: need to do real work. + my $callpkg = caller(0); + print "autouse called from $callpkg\n" if $autouse::DEBUG; + + my $index; + for my $f (@_) { + my $proto; + $proto = $1 if (my $func = $f) =~ s/\((.*)\)$//; + + my $closure_import_func = $func; # Full name + my $closure_func = $func; # Name inside package + my $index = rindex($func, '::'); + if ($index == -1) { + $closure_import_func = "${callpkg}::$func"; + } else { + $closure_func = substr $func, $index + 2; + croak "autouse into different package attempted" + unless substr($func, 0, $index) eq $module; + } + + my $load_sub = sub { + unless ($INC{$pm}) { + require $pm; + vet_import $module; + } + no warnings qw(redefine prototype); + *$closure_import_func = \&{"${module}::$closure_func"}; + print "autousing $module; " + ."imported $closure_func as $closure_import_func\n" + if $autouse::DEBUG; + goto &$closure_import_func; + }; + + if (defined $proto) { + *$closure_import_func = eval "sub ($proto) { goto &\$load_sub }" + || die; + } else { + *$closure_import_func = $load_sub; + } + } +} + +sub vet_import ($) { + my $module = shift; + if (my $import = $module->can('import')) { + croak "autoused module $module has unique import() method" + unless defined(&Exporter::import) + && ($import == \&Exporter::import || + $import == \&UNIVERSAL::import) + } +} + +1; + +__END__ + +# -*- mode: perl; perl-indent-level: 2; -*- +# Memoize.pm +# +# Transparent memoization of idempotent functions +# +# Copyright 1998, 1999, 2000, 2001, 2012 M. J. Dominus. +# You may copy and distribute this program under the +# same terms as Perl itself. If in doubt, +# write to mjd-perl-memoize+@plover.com for a license. + +package Memoize; +$VERSION = '1.03_01'; + +# Compile-time constants +sub SCALAR () { 0 } +sub LIST () { 1 } + + +# +# Usage memoize(functionname/ref, +# { NORMALIZER => coderef, INSTALL => name, +# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor } +# + +use Carp; +use Exporter; +use vars qw($DEBUG); +use Config; # Dammit. +@ISA = qw(Exporter); +@EXPORT = qw(memoize); +@EXPORT_OK = qw(unmemoize flush_cache); +use strict; + +my %memotable; +my %revmemotable; +my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH); +my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS; + +# Raise an error if the user tries to specify one of thesepackage as a +# tie for LIST_CACHE + +my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File); + +sub memoize { + my $fn = shift; + my %options = @_; + my $options = \%options; + + unless (defined($fn) && + (ref $fn eq 'CODE' || ref $fn eq '')) { + croak "Usage: memoize 'functionname'|coderef {OPTIONS}"; + } + + my $uppack = caller; # TCL me Elmo! + my $cref; # Code reference to original function + my $name = (ref $fn ? undef : $fn); + + # Convert function names to code references + $cref = &_make_cref($fn, $uppack); + + # Locate function prototype, if any + my $proto = prototype $cref; + if (defined $proto) { $proto = "($proto)" } + else { $proto = "" } + + # I would like to get rid of the eval, but there seems not to be any + # other way to set the prototype properly. The switch here for + # 'usethreads' works around a bug in threadperl having to do with + # magic goto. It would be better to fix the bug and use the magic + # goto version everywhere. + my $wrapper = + $Config{usethreads} + ? eval "sub $proto { &_memoizer(\$cref, \@_); }" + : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }"; + + my $normalizer = $options{NORMALIZER}; + if (defined $normalizer && ! ref $normalizer) { + $normalizer = _make_cref($normalizer, $uppack); + } + + my $install_name; + if (defined $options->{INSTALL}) { + # INSTALL => name + $install_name = $options->{INSTALL}; + } elsif (! exists $options->{INSTALL}) { + # No INSTALL option provided; use original name if possible + $install_name = $name; + } else { + # INSTALL => undef means don't install + } + + if (defined $install_name) { + $install_name = $uppack . '::' . $install_name + unless $install_name =~ /::/; + no strict; + local($^W) = 0; # ``Subroutine $install_name redefined at ...'' + *{$install_name} = $wrapper; # Install memoized version + } + + $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key + + # These will be the caches + my %caches; + for my $context (qw(SCALAR LIST)) { + # suppress subsequent 'uninitialized value' warnings + $options{"${context}_CACHE"} ||= ''; + + my $cache_opt = $options{"${context}_CACHE"}; + my @cache_opt_args; + if (ref $cache_opt) { + @cache_opt_args = @$cache_opt; + $cache_opt = shift @cache_opt_args; + } + if ($cache_opt eq 'FAULT') { # no cache + $caches{$context} = undef; + } elsif ($cache_opt eq 'HASH') { # user-supplied hash + my $cache = $cache_opt_args[0]; + my $package = ref(tied %$cache); + if ($context eq 'LIST' && $scalar_only{$package}) { + croak("You can't use $package for LIST_CACHE because it can only store scalars"); + } + $caches{$context} = $cache; + } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) { + # default is that we make up an in-memory hash + $caches{$context} = {}; + # (this might get tied later, or MERGEd away) + } else { + croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting"; + } + } + + # Perhaps I should check here that you didn't supply *both* merge + # options. But if you did, it does do something reasonable: They + # both get merged to the same in-memory hash. + if ($options{SCALAR_CACHE} eq 'MERGE' || $options{LIST_CACHE} eq 'MERGE') { + $options{MERGED} = 1; + $caches{SCALAR} = $caches{LIST}; + } + + # Now deal with the TIE options + { + my $context; + foreach $context (qw(SCALAR LIST)) { + # If the relevant option wasn't `TIE', this call does nothing. + _my_tie($context, $caches{$context}, $options); # Croaks on failure + } + } + + # We should put some more stuff in here eventually. + # We've been saying that for serveral versions now. + # And you know what? More stuff keeps going in! + $memotable{$cref} = + { + O => $options, # Short keys here for things we need to access frequently + N => $normalizer, + U => $cref, + MEMOIZED => $wrapper, + PACKAGE => $uppack, + NAME => $install_name, + S => $caches{SCALAR}, + L => $caches{LIST}, + }; + + $wrapper # Return just memoized version +} + +# This function tries to load a tied hash class and tie the hash to it. +sub _my_tie { + my ($context, $hash, $options) = @_; + my $fullopt = $options->{"${context}_CACHE"}; + + # We already checked to make sure that this works. + my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt; + + return unless defined $shortopt && $shortopt eq 'TIE'; + carp("TIE option to memoize() is deprecated; use HASH instead") + if $^W; + + my @args = ref $fullopt ? @$fullopt : (); + shift @args; + my $module = shift @args; + if ($context eq 'LIST' && $scalar_only{$module}) { + croak("You can't use $module for LIST_CACHE because it can only store scalars"); + } + my $modulefile = $module . '.pm'; + $modulefile =~ s{::}{/}g; + eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require $modulefile + }; + if ($@) { + croak "Memoize: Couldn't load hash tie module `$module': $@; aborting"; + } + my $rc = (tie %$hash => $module, @args); + unless ($rc) { + croak "Memoize: Couldn't tie hash to `$module': $!; aborting"; + } + 1; +} + +sub flush_cache { + my $func = _make_cref($_[0], scalar caller); + my $info = $memotable{$revmemotable{$func}}; + die "$func not memoized" unless defined $info; + for my $context (qw(S L)) { + my $cache = $info->{$context}; + if (tied %$cache && ! (tied %$cache)->can('CLEAR')) { + my $funcname = defined($info->{NAME}) ? + "function $info->{NAME}" : "anonymous function $func"; + my $context = {S => 'scalar', L => 'list'}->{$context}; + croak "Tied cache hash for $context-context $funcname does not support flushing"; + } else { + %$cache = (); + } + } +} + +# This is the function that manages the memo tables. +sub _memoizer { + my $orig = shift; # stringized version of ref to original func. + my $info = $memotable{$orig}; + my $normalizer = $info->{N}; + + my $argstr; + my $context = (wantarray() ? LIST : SCALAR); + + if (defined $normalizer) { + no strict; + if ($context == SCALAR) { + $argstr = &{$normalizer}(@_); + } elsif ($context == LIST) { + ($argstr) = &{$normalizer}(@_); + } else { + croak "Internal error \#41; context was neither LIST nor SCALAR\n"; + } + } else { # Default normalizer + local $^W = 0; + $argstr = join chr(28),@_; + } + + if ($context == SCALAR) { + my $cache = $info->{S}; + _crap_out($info->{NAME}, 'scalar') unless $cache; + if (exists $cache->{$argstr}) { + return $info->{O}{MERGED} + ? $cache->{$argstr}[0] : $cache->{$argstr}; + } else { + my $val = &{$info->{U}}(@_); + # Scalars are considered to be lists; store appropriately + if ($info->{O}{MERGED}) { + $cache->{$argstr} = [$val]; + } else { + $cache->{$argstr} = $val; + } + $val; + } + } elsif ($context == LIST) { + my $cache = $info->{L}; + _crap_out($info->{NAME}, 'list') unless $cache; + if (exists $cache->{$argstr}) { + return @{$cache->{$argstr}}; + } else { + my @q = &{$info->{U}}(@_); + $cache->{$argstr} = \@q; + @q; + } + } else { + croak "Internal error \#42; context was neither LIST nor SCALAR\n"; + } +} + +sub unmemoize { + my $f = shift; + my $uppack = caller; + my $cref = _make_cref($f, $uppack); + + unless (exists $revmemotable{$cref}) { + croak "Could not unmemoize function `$f', because it was not memoized to begin with"; + } + + my $tabent = $memotable{$revmemotable{$cref}}; + unless (defined $tabent) { + croak "Could not figure out how to unmemoize function `$f'"; + } + my $name = $tabent->{NAME}; + if (defined $name) { + no strict; + local($^W) = 0; # ``Subroutine $install_name redefined at ...'' + *{$name} = $tabent->{U}; # Replace with original function + } + undef $memotable{$revmemotable{$cref}}; + undef $revmemotable{$cref}; + + # This removes the last reference to the (possibly tied) memo tables + # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'}; + # undef $tabent; + +# # Untie the memo tables if they were tied. +# my $i; +# for $i (0,1) { +# if (tied %{$memotabs->[$i]}) { +# warn "Untying hash #$i\n"; +# untie %{$memotabs->[$i]}; +# } +# } + + $tabent->{U}; +} + +sub _make_cref { + my $fn = shift; + my $uppack = shift; + my $cref; + my $name; + + if (ref $fn eq 'CODE') { + $cref = $fn; + } elsif (! ref $fn) { + if ($fn =~ /::/) { + $name = $fn; + } else { + $name = $uppack . '::' . $fn; + } + no strict; + if (defined $name and !defined(&$name)) { + croak "Cannot operate on nonexistent function `$fn'"; + } +# $cref = \&$name; + $cref = *{$name}{CODE}; + } else { + my $parent = (caller(1))[3]; # Function that called _make_cref + croak "Usage: argument 1 to `$parent' must be a function name or reference.\n"; + } + $DEBUG and warn "${name}($fn) => $cref in _make_cref\n"; + $cref; +} + +sub _crap_out { + my ($funcname, $context) = @_; + if (defined $funcname) { + croak "Function `$funcname' called in forbidden $context context; faulting"; + } else { + croak "Anonymous function called in forbidden $context context; faulting"; + } +} + +1; + + + + + +package charnames; +use strict; +use warnings; +our $VERSION = '1.45'; +use unicore::Name; # mktables-generated algorithmically-defined names +use _charnames (); # The submodule for this where most of the work gets done + +use bytes (); # for $bytes::hint_bits +use re "/aa"; # Everything in here should be ASCII + +# Translate between Unicode character names and their code points. +# This is a wrapper around the submodule C<_charnames>. This design allows +# C<_charnames> to be autoloaded to enable use of \N{...}, but requires this +# module to be explicitly requested for the functions API. + +$Carp::Internal{ (__PACKAGE__) } = 1; + +sub import +{ + shift; ## ignore class name + _charnames->import(@_); +} + +# Cache of already looked-up values. This is set to only contain +# official values, and user aliases can't override them, so scoping is +# not an issue. +my %viacode; + +sub viacode { + return _charnames::viacode(@_); +} + +sub vianame +{ + if (@_ != 1) { + _charnames::carp "charnames::vianame() expects one name argument"; + return () + } + + # Looks up the character name and returns its ordinal if + # found, undef otherwise. + + my $arg = shift; + + if ($arg =~ /^U\+([0-9a-fA-F]+)$/) { + + # khw claims that this is poor interface design. The function should + # return either a an ord or a chr for all inputs; not be bipolar. But + # can't change it because of backward compatibility. New code can use + # string_vianame() instead. + my $ord = CORE::hex $1; + return pack("U", $ord) if $ord <= 255 || ! ((caller 0)[8] & $bytes::hint_bits); + _charnames::carp _charnames::not_legal_use_bytes_msg($arg, chr $ord); + return; + } + + # The first 1 arg means wants an ord returned; the second that we are in + # runtime, and this is the first level routine called from the user + return _charnames::lookup_name($arg, 1, 1); +} # vianame + +sub string_vianame { + + # Looks up the character name and returns its string representation if + # found, undef otherwise. + + if (@_ != 1) { + _charnames::carp "charnames::string_vianame() expects one name argument"; + return; + } + + my $arg = shift; + + if ($arg =~ /^U\+([0-9a-fA-F]+)$/) { + + my $ord = CORE::hex $1; + return pack("U", $ord) if $ord <= 255 || ! ((caller 0)[8] & $bytes::hint_bits); + + _charnames::carp _charnames::not_legal_use_bytes_msg($arg, chr $ord); + return; + } + + # The 0 arg means wants a string returned; the 1 arg means that we are in + # runtime, and this is the first level routine called from the user + return _charnames::lookup_name($arg, 0, 1); +} # string_vianame + +1; +__END__ + + +# ex: set ts=8 sts=2 sw=2 et: +use 5.008; +package fields; + +require 5.005; +use strict; +no strict 'refs'; +unless( eval q{require warnings::register; warnings::register->import; 1} ) { + *warnings::warnif = sub { + require Carp; + Carp::carp(@_); + } +} +our %attr; + +our $VERSION = '2.24'; +$VERSION =~ tr/_//d; + +# constant.pm is slow +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + + +# The %attr hash holds the attributes of the currently assigned fields +# per class. The hash is indexed by class names and the hash value is +# an array reference. The first element in the array is the lowest field +# number not belonging to a base class. The remaining elements' indices +# are the field numbers. The values are integer bit masks, or undef +# in the case of base class private fields (which occupy a slot but are +# otherwise irrelevant to the class). + +sub import { + my $class = shift; + return unless @_; + my $package = caller(0); + # avoid possible typo warnings + %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; + my $fields = \%{"$package\::FIELDS"}; + my $fattr = ($attr{$package} ||= [1]); + my $next = @$fattr; + + # Quiet pseudo-hash deprecation warning for uses of fields::new. + bless \%{"$package\::FIELDS"}, 'pseudohash'; + + if ($next > $fattr->[0] + and ($fields->{$_[0]} || 0) >= $fattr->[0]) + { + # There are already fields not belonging to base classes. + # Looks like a possible module reload... + $next = $fattr->[0]; + } + foreach my $f (@_) { + my $fno = $fields->{$f}; + + # Allow the module to be reloaded so long as field positions + # have not changed. + if ($fno and $fno != $next) { + require Carp; + if ($fno < $fattr->[0]) { + if ($] < 5.006001) { + warn("Hides field '$f' in base class") if $^W; + } else { + warnings::warnif("Hides field '$f' in base class") ; + } + } else { + Carp::croak("Field name '$f' already in use"); + } + } + $fields->{$f} = $next; + $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; + $next += 1; + } + if (@$fattr > $next) { + # Well, we gave them the benefit of the doubt by guessing the + # module was reloaded, but they appear to be declaring fields + # in more than one place. We can't be sure (without some extra + # bookkeeping) that the rest of the fields will be declared or + # have the same positions, so punt. + require Carp; + Carp::croak ("Reloaded module must declare all fields at once"); + } +} + +sub inherit { + require base; + goto &base::inherit_fields; +} + +sub _dump # sometimes useful for debugging +{ + for my $pkg (sort keys %attr) { + print "\n$pkg"; + if (@{"$pkg\::ISA"}) { + print " (", join(", ", @{"$pkg\::ISA"}), ")"; + } + print "\n"; + my $fields = \%{"$pkg\::FIELDS"}; + for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { + my $no = $fields->{$f}; + print " $no: $f"; + my $fattr = $attr{$pkg}[$no]; + if (defined $fattr) { + my @a; + push(@a, "public") if $fattr & PUBLIC; + push(@a, "private") if $fattr & PRIVATE; + push(@a, "inherited") if $fattr & INHERITED; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } + } +} + +if ($] < 5.009) { + *new = sub { + my $class = shift; + $class = ref $class if ref $class; + return bless [\%{$class . "::FIELDS"}], $class; + } +} else { + *new = sub { + my $class = shift; + $class = ref $class if ref $class; + require Hash::Util; + my $self = bless {}, $class; + + # The lock_keys() prototype won't work since we require Hash::Util :( + &Hash::Util::lock_keys(\%$self, _accessible_keys($class)); + return $self; + } +} + +sub _accessible_keys { + my ($class) = @_; + return ( + keys %{$class.'::FIELDS'}, + map(_accessible_keys($_), @{$class.'::ISA'}), + ); +} + +sub phash { + die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; + my $h; + my $v; + if (@_) { + if (ref $_[0] eq 'ARRAY') { + my $a = shift; + @$h{@$a} = 1 .. @$a; + if (@_) { + $v = shift; + unless (! @_ and ref $v eq 'ARRAY') { + require Carp; + Carp::croak ("Expected at most two array refs\n"); + } + } + } + else { + if (@_ % 2) { + require Carp; + Carp::croak ("Odd number of elements initializing pseudo-hash\n"); + } + my $i = 0; + @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; + $i = 0; + $v = [grep $i++ % 2, @_]; + } + } + else { + $h = {}; + $v = []; + } + [ $h, @$v ]; + +} + +1; + +__END__ + +package Thread; + +use strict; +use warnings; +no warnings 'redefine'; + +our $VERSION = '3.04'; +$VERSION = eval $VERSION; + +BEGIN { + use Config; + if (! $Config{useithreads}) { + die("This Perl not built to support threads\n"); + } +} + +use threads 'yield'; +use threads::shared; + +require Exporter; +our @ISA = qw(Exporter threads); +our @EXPORT = qw(cond_wait cond_broadcast cond_signal); +our @EXPORT_OK = qw(async yield); + +sub async (&;@) { return Thread->new(shift); } + +sub done { return ! shift->is_running(); } + +sub eval { die("'eval' not implemented with 'ithreads'\n"); }; +sub flags { die("'flags' not implemented with 'ithreads'\n"); }; + +1; + +__END__ + +package parent; +use strict; +use vars qw($VERSION); +$VERSION = '0.236'; + +sub import { + my $class = shift; + + my $inheritor = caller(0); + + if ( @_ and $_[0] eq '-norequire' ) { + shift @_; + } else { + for ( my @filename = @_ ) { + s{::|'}{/}g; + require "$_.pm"; # dies if the file is not found + } + } + + { + no strict 'refs'; + push @{"$inheritor\::ISA"}, @_; # dies if a loop is detected + }; +}; + +1; + +__END__ + +package less; +use strict; +use warnings; + +our $VERSION = '0.03'; + +sub _pack_tags { + return join ' ', @_; +} + +sub _unpack_tags { + return grep { defined and length } + map { split ' ' } + grep {defined} @_; +} + +sub stash_name { $_[0] } + +sub of { + my $class = shift @_; + + # If no one wants the result, don't bother computing it. + return unless defined wantarray; + + my $hinthash = ( caller 0 )[10]; + my %tags; + @tags{ _unpack_tags( $hinthash->{ $class->stash_name } ) } = (); + + if (@_) { + exists $tags{$_} and return !!1 for @_; + return; + } + else { + return keys %tags; + } +} + +sub import { + my $class = shift @_; + my $stash = $class->stash_name; + + @_ = 'please' if not @_; + my %tags; + @tags{ _unpack_tags( @_, $^H{ $stash } ) } = (); + + $^H{$stash} = _pack_tags( keys %tags ); + return; +} + +sub unimport { + my $class = shift @_; + + if (@_) { + my %tags; + @tags{ _unpack_tags( $^H{$class} ) } = (); + delete @tags{ _unpack_tags(@_) }; + my $new = _pack_tags( keys %tags ); + + if ( not length $new ) { + delete $^H{ $class->stash_name }; + } + else { + $^H{ $class->stash_name } = $new; + } + } + else { + delete $^H{ $class->stash_name }; + } + + return; +} + +1; + +__END__ + +package Benchmark; + +use strict; + + + +# evaluate something in a clean lexical environment +sub _doeval { no strict; eval shift } + +# +# put any lexicals at file scope AFTER here +# + +use Carp; +use Exporter; + +our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); + +@ISA=qw(Exporter); +@EXPORT=qw(timeit timethis timethese timediff timestr); +@EXPORT_OK=qw(timesum cmpthese countit + clearcache clearallcache disablecache enablecache); +%EXPORT_TAGS=( all => [ @EXPORT, @EXPORT_OK ] ) ; + +$VERSION = 1.22; + +# --- ':hireswallclock' special handling + +my $hirestime; + +sub mytime () { time } + +init(); + +sub BEGIN { + if (eval 'require Time::HiRes') { + import Time::HiRes qw(time); + $hirestime = \&Time::HiRes::time; + } +} + +sub import { + my $class = shift; + if (grep { $_ eq ":hireswallclock" } @_) { + @_ = grep { $_ ne ":hireswallclock" } @_; + local $^W=0; + *mytime = $hirestime if defined $hirestime; + } + Benchmark->export_to_level(1, $class, @_); +} + +our($Debug, $Min_Count, $Min_CPU, $Default_Format, $Default_Style, + %_Usage, %Cache, $Do_Cache); + +sub init { + $Debug = 0; + $Min_Count = 4; + $Min_CPU = 0.4; + $Default_Format = '5.2f'; + $Default_Style = 'auto'; + # The cache can cause a slight loss of sys time accuracy. If a + # user does many tests (>10) with *very* large counts (>10000) + # or works on a very slow machine the cache may be useful. + disablecache(); + clearallcache(); +} + +sub debug { $Debug = ($_[1] != 0); } + +sub usage { + my $calling_sub = (caller(1))[3]; + $calling_sub =~ s/^Benchmark:://; + return $_Usage{$calling_sub} || ''; +} + +# The cache needs two branches: 's' for strings and 'c' for code. The +# empty loop is different in these two cases. + +$_Usage{clearcache} = <<'USAGE'; +usage: clearcache($count); +USAGE + +sub clearcache { + die usage unless @_ == 1; + delete $Cache{"$_[0]c"}; delete $Cache{"$_[0]s"}; +} + +$_Usage{clearallcache} = <<'USAGE'; +usage: clearallcache(); +USAGE + +sub clearallcache { + die usage if @_; + %Cache = (); +} + +$_Usage{enablecache} = <<'USAGE'; +usage: enablecache(); +USAGE + +sub enablecache { + die usage if @_; + $Do_Cache = 1; +} + +$_Usage{disablecache} = <<'USAGE'; +usage: disablecache(); +USAGE + +sub disablecache { + die usage if @_; + $Do_Cache = 0; +} + + +# --- Functions to process the 'time' data type + +sub new { my @t = (mytime, times, @_ == 2 ? $_[1] : 0); + print STDERR "new=@t\n" if $Debug; + bless \@t; } + +sub cpu_p { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps ; } +sub cpu_c { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $cu+$cs ; } +sub cpu_a { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $pu+$ps+$cu+$cs ; } +sub real { my($r,$pu,$ps,$cu,$cs) = @{$_[0]}; $r ; } +sub iters { $_[0]->[5] ; } + +# return the sum of various times: which ones depending on $style + +sub elapsed { + my ($self, $style) = @_; + $style = "" unless defined $style; + + return $self->cpu_c if $style eq 'nop'; + return $self->cpu_p if $style eq 'noc'; + return $self->cpu_a; +} + + +$_Usage{timediff} = <<'USAGE'; +usage: $result_diff = timediff($result1, $result2); +USAGE + +sub timediff { + my($a, $b) = @_; + + die usage unless ref $a and ref $b; + + my @r; + for (my $i=0; $i < @$a; ++$i) { + push(@r, $a->[$i] - $b->[$i]); + } + #die "Bad timediff(): ($r[1] + $r[2]) <= 0 (@$a[1,2]|@$b[1,2])\n" + # if ($r[1] + $r[2]) < 0; + bless \@r; +} + +$_Usage{timesum} = <<'USAGE'; +usage: $sum = timesum($result1, $result2); +USAGE + +sub timesum { + my($a, $b) = @_; + + die usage unless ref $a and ref $b; + + my @r; + for (my $i=0; $i < @$a; ++$i) { + push(@r, $a->[$i] + $b->[$i]); + } + bless \@r; +} + + +$_Usage{timestr} = <<'USAGE'; +usage: $formatted_result = timestr($result1); +USAGE + +sub timestr { + my($tr, $style, $f) = @_; + + die usage unless ref $tr; + + my @t = @$tr; + warn "bad time value (@t)" unless @t==6; + my($r, $pu, $ps, $cu, $cs, $n) = @t; + my($pt, $ct, $tt) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a); + $f = $Default_Format unless defined $f; + # format a time in the required style, other formats may be added here + $style ||= $Default_Style; + return '' if $style eq 'none'; + $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto'; + my $s = "@t $style"; # default for unknown style + my $w = $hirestime ? "%2g" : "%2d"; + $s = sprintf("$w wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)", + $r,$pu,$ps,$cu,$cs,$tt) if $style eq 'all'; + $s = sprintf("$w wallclock secs (%$f usr + %$f sys = %$f CPU)", + $r,$pu,$ps,$pt) if $style eq 'noc'; + $s = sprintf("$w wallclock secs (%$f cusr + %$f csys = %$f CPU)", + $r,$cu,$cs,$ct) if $style eq 'nop'; + my $elapsed = $tr->elapsed($style); + $s .= sprintf(" @ %$f/s (n=$n)",$n/($elapsed)) if $n && $elapsed; + $s; +} + +sub timedebug { + my($msg, $t) = @_; + print STDERR "$msg",timestr($t),"\n" if $Debug; +} + +# --- Functions implementing low-level support for timing loops + +$_Usage{runloop} = <<'USAGE'; +usage: runloop($number, [$string | $coderef]) +USAGE + +sub runloop { + my($n, $c) = @_; + + $n+=0; # force numeric now, so garbage won't creep into the eval + croak "negative loopcount $n" if $n<0; + confess usage unless defined $c; + my($t0, $t1, $td); # before, after, difference + + # find package of caller so we can execute code there + my($curpack) = caller(0); + my($i, $pack)= 0; + while (($pack) = caller(++$i)) { + last if $pack ne $curpack; + } + + my ($subcode, $subref); + if (ref $c eq 'CODE') { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; &\$c; } }"; + $subref = eval $subcode; + } + else { + $subcode = "sub { for (1 .. $n) { local \$_; package $pack; $c;} }"; + $subref = _doeval($subcode); + } + croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@; + print STDERR "runloop $n '$subcode'\n" if $Debug; + + # Wait for the user timer to tick. This makes the error range more like + # -0.01, +0. If we don't wait, then it's more like -0.01, +0.01. This + # may not seem important, but it significantly reduces the chances of + # getting a too low initial $n in the initial, 'find the minimum' loop + # in &countit. This, in turn, can reduce the number of calls to + # &runloop a lot, and thus reduce additive errors. + # + # Note that its possible for the act of reading the system clock to + # burn lots of system CPU while we burn very little user clock in the + # busy loop, which can cause the loop to run for a very long wall time. + # So gradually ramp up the duration of the loop. See RT #122003 + # + my $tbase = Benchmark->new(0)->[1]; + my $limit = 1; + while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) { + for (my $i=0; $i < $limit; $i++) { my $x = $i / 1.5 } # burn user CPU + $limit *= 1.1; + } + $subref->(); + $t1 = Benchmark->new($n); + $td = &timediff($t1, $t0); + timedebug("runloop:",$td); + $td; +} + +$_Usage{timeit} = <<'USAGE'; +usage: $result = timeit($count, 'code' ); or + $result = timeit($count, sub { code } ); +USAGE + +sub timeit { + my($n, $code) = @_; + my($wn, $wc, $wd); + + die usage unless defined $code and + (!ref $code or ref $code eq 'CODE'); + + printf STDERR "timeit $n $code\n" if $Debug; + my $cache_key = $n . ( ref( $code ) ? 'c' : 's' ); + if ($Do_Cache && exists $Cache{$cache_key} ) { + $wn = $Cache{$cache_key}; + } else { + $wn = &runloop($n, ref( $code ) ? sub { } : '' ); + # Can't let our baseline have any iterations, or they get subtracted + # out of the result. + $wn->[5] = 0; + $Cache{$cache_key} = $wn; + } + + $wc = &runloop($n, $code); + + $wd = timediff($wc, $wn); + timedebug("timeit: ",$wc); + timedebug(" - ",$wn); + timedebug(" = ",$wd); + + $wd; +} + + +my $default_for = 3; +my $min_for = 0.1; + + +$_Usage{countit} = <<'USAGE'; +usage: $result = countit($time, 'code' ); or + $result = countit($time, sub { code } ); +USAGE + +sub countit { + my ( $tmax, $code ) = @_; + + die usage unless @_; + + if ( not defined $tmax or $tmax == 0 ) { + $tmax = $default_for; + } elsif ( $tmax < 0 ) { + $tmax = -$tmax; + } + + die "countit($tmax, ...): timelimit cannot be less than $min_for.\n" + if $tmax < $min_for; + + my ($n, $tc); + + # First find the minimum $n that gives a significant timing. + my $zeros=0; + for ($n = 1; ; $n *= 2 ) { + my $t0 = Benchmark->new(0); + my $td = timeit($n, $code); + my $t1 = Benchmark->new(0); + $tc = $td->[1] + $td->[2]; + if ( $tc <= 0 and $n > 1024 ) { + my $d = timediff($t1, $t0); + # note that $d is the total CPU time taken to call timeit(), + # while $tc is is difference in CPU secs between the empty run + # and the code run. If the code is trivial, its possible + # for $d to get large while $tc is still zero (or slightly + # negative). Bail out once timeit() starts taking more than a + # few seconds without noticeable difference. + if ($d->[1] + $d->[2] > 8 + || ++$zeros > 16) + { + die "Timing is consistently zero in estimation loop, cannot benchmark. N=$n\n"; + } + } else { + $zeros = 0; + } + last if $tc > 0.1; + } + + my $nmin = $n; + + # Get $n high enough that we can guess the final $n with some accuracy. + my $tpra = 0.1 * $tmax; # Target/time practice. + while ( $tc < $tpra ) { + # The 5% fudge is to keep us from iterating again all + # that often (this speeds overall responsiveness when $tmax is big + # and we guess a little low). This does not noticeably affect + # accuracy since we're not counting these times. + $n = int( $tpra * 1.05 * $n / $tc ); # Linear approximation. + my $td = timeit($n, $code); + my $new_tc = $td->[1] + $td->[2]; + # Make sure we are making progress. + $tc = $new_tc > 1.2 * $tc ? $new_tc : 1.2 * $tc; + } + + # Now, do the 'for real' timing(s), repeating until we exceed + # the max. + my $ntot = 0; + my $rtot = 0; + my $utot = 0.0; + my $stot = 0.0; + my $cutot = 0.0; + my $cstot = 0.0; + my $ttot = 0.0; + + # The 5% fudge is because $n is often a few % low even for routines + # with stable times and avoiding extra timeit()s is nice for + # accuracy's sake. + $n = int( $n * ( 1.05 * $tmax / $tc ) ); + $zeros=0; + while () { + my $td = timeit($n, $code); + $ntot += $n; + $rtot += $td->[0]; + $utot += $td->[1]; + $stot += $td->[2]; + $cutot += $td->[3]; + $cstot += $td->[4]; + $ttot = $utot + $stot; + last if $ttot >= $tmax; + if ( $ttot <= 0 ) { + ++$zeros > 16 + and die "Timing is consistently zero, cannot benchmark. N=$n\n"; + } else { + $zeros = 0; + } + $ttot = 0.01 if $ttot < 0.01; + my $r = $tmax / $ttot - 1; # Linear approximation. + $n = int( $r * $ntot ); + $n = $nmin if $n < $nmin; + } + + return bless [ $rtot, $utot, $stot, $cutot, $cstot, $ntot ]; +} + +# --- Functions implementing high-level time-then-print utilities + +sub n_to_for { + my $n = shift; + return $n == 0 ? $default_for : $n < 0 ? -$n : undef; +} + +$_Usage{timethis} = <<'USAGE'; +usage: $result = timethis($time, 'code' ); or + $result = timethis($time, sub { code } ); +USAGE + +sub timethis{ + my($n, $code, $title, $style) = @_; + my($t, $forn); + + die usage unless defined $code and + (!ref $code or ref $code eq 'CODE'); + + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + $t = timeit($n, $code); + $title = "timethis $n" unless defined $title; + } else { + my $fort = n_to_for( $n ); + $t = countit( $fort, $code ); + $title = "timethis for $fort" unless defined $title; + $forn = $t->[-1]; + } + local $| = 1; + $style = "" unless defined $style; + printf("%10s: ", $title) unless $style eq 'none'; + print timestr($t, $style, $Default_Format),"\n" unless $style eq 'none'; + + $n = $forn if defined $forn; + + if ($t->elapsed($style) < 0) { + # due to clock granularity and variable CPU speed and load, + # on quick code with a small number of loops, it's possible for + # the empty loop to appear to take longer than the real loop + # (e.g. 1 tick versus 0 ticks). This leads to a negative elapsed + # time. In this case, floor it at zero, to stop bizarre results. + print " (warning: too few iterations for a reliable count)\n"; + $t->[$_] = 0 for 1..4; + } + + # A conservative warning to spot very silly tests. + # Don't assume that your benchmark is ok simply because + # you don't get this warning! + print " (warning: too few iterations for a reliable count)\n" + if $n < $Min_Count + || ($t->real < 1 && $n < 1000) + || $t->cpu_a < $Min_CPU; + $t; +} + + +$_Usage{timethese} = <<'USAGE'; +usage: timethese($count, { Name1 => 'code1', ... }); or + timethese($count, { Name1 => sub { code1 }, ... }); +USAGE + +sub timethese{ + my($n, $alt, $style) = @_; + die usage unless ref $alt eq 'HASH'; + + my @names = sort keys %$alt; + $style = "" unless defined $style; + print "Benchmark: " unless $style eq 'none'; + if ( $n > 0 ) { + croak "non-integer loopcount $n, stopped" if int($n)<$n; + print "timing $n iterations of" unless $style eq 'none'; + } else { + print "running" unless $style eq 'none'; + } + print " ", join(', ',@names) unless $style eq 'none'; + unless ( $n > 0 ) { + my $for = n_to_for( $n ); + print ", each" if $n > 1 && $style ne 'none'; + print " for at least $for CPU seconds" unless $style eq 'none'; + } + print "...\n" unless $style eq 'none'; + + # we could save the results in an array and produce a summary here + # sum, min, max, avg etc etc + my %results; + foreach my $name (@names) { + $results{$name} = timethis ($n, $alt -> {$name}, $name, $style); + } + + return \%results; +} + + +$_Usage{cmpthese} = <<'USAGE'; +usage: cmpthese($count, { Name1 => 'code1', ... }); or + cmpthese($count, { Name1 => sub { code1 }, ... }); or + cmpthese($result, $style); +USAGE + +sub cmpthese{ + my ($results, $style); + + # $count can be a blessed object. + if ( ref $_[0] eq 'HASH' ) { + ($results, $style) = @_; + } + else { + my($count, $code) = @_[0,1]; + $style = $_[2] if defined $_[2]; + + die usage unless ref $code eq 'HASH'; + + $results = timethese($count, $code, ($style || "none")); + } + + $style = "" unless defined $style; + + # Flatten in to an array of arrays with the name as the first field + my @vals = map{ [ $_, @{$results->{$_}} ] } keys %$results; + + for (@vals) { + # recreate the pre-flattened Benchmark object + my $tmp_bm = bless [ @{$_}[1..$#$_] ]; + my $elapsed = $tmp_bm->elapsed($style); + # The epsilon fudge here is to prevent div by 0. Since clock + # resolutions are much larger, it's below the noise floor. + my $rate = $_->[6]/(($elapsed)+0.000000000000001); + $_->[7] = $rate; + } + + # Sort by rate + @vals = sort { $a->[7] <=> $b->[7] } @vals; + + # If more than half of the rates are greater than one... + my $display_as_rate = @vals ? ($vals[$#vals>>1]->[7] > 1) : 0; + + my @rows; + my @col_widths; + + my @top_row = ( + '', + $display_as_rate ? 'Rate' : 's/iter', + map { $_->[0] } @vals + ); + + push @rows, \@top_row; + @col_widths = map { length( $_ ) } @top_row; + + # Build the data rows + # We leave the last column in even though it never has any data. Perhaps + # it should go away. Also, perhaps a style for a single column of + # percentages might be nice. + for my $row_val ( @vals ) { + my @row; + + # Column 0 = test name + push @row, $row_val->[0]; + $col_widths[0] = length( $row_val->[0] ) + if length( $row_val->[0] ) > $col_widths[0]; + + # Column 1 = performance + my $row_rate = $row_val->[7]; + + # We assume that we'll never get a 0 rate. + my $rate = $display_as_rate ? $row_rate : 1 / $row_rate; + + # Only give a few decimal places before switching to sci. notation, + # since the results aren't usually that accurate anyway. + my $format = + $rate >= 100 ? + "%0.0f" : + $rate >= 10 ? + "%0.1f" : + $rate >= 1 ? + "%0.2f" : + $rate >= 0.1 ? + "%0.3f" : + "%0.2e"; + + $format .= "/s" + if $display_as_rate; + + my $formatted_rate = sprintf( $format, $rate ); + push @row, $formatted_rate; + $col_widths[1] = length( $formatted_rate ) + if length( $formatted_rate ) > $col_widths[1]; + + # Columns 2..N = performance ratios + my $skip_rest = 0; + for ( my $col_num = 0 ; $col_num < @vals ; ++$col_num ) { + my $col_val = $vals[$col_num]; + my $out; + if ( $skip_rest ) { + $out = ''; + } + elsif ( $col_val->[0] eq $row_val->[0] ) { + $out = "--"; + # $skip_rest = 1; + } + else { + my $col_rate = $col_val->[7]; + $out = sprintf( "%.0f%%", 100*$row_rate/$col_rate - 100 ); + } + push @row, $out; + $col_widths[$col_num+2] = length( $out ) + if length( $out ) > $col_widths[$col_num+2]; + + # A little weirdness to set the first column width properly + $col_widths[$col_num+2] = length( $col_val->[0] ) + if length( $col_val->[0] ) > $col_widths[$col_num+2]; + } + push @rows, \@row; + } + + return \@rows if $style eq "none"; + + # Equalize column widths in the chart as much as possible without + # exceeding 80 characters. This does not use or affect cols 0 or 1. + my @sorted_width_refs = + sort { $$a <=> $$b } map { \$_ } @col_widths[2..$#col_widths]; + my $max_width = ${$sorted_width_refs[-1]}; + + my $total = @col_widths - 1 ; + for ( @col_widths ) { $total += $_ } + + STRETCHER: + while ( $total < 80 ) { + my $min_width = ${$sorted_width_refs[0]}; + last + if $min_width == $max_width; + for ( @sorted_width_refs ) { + last + if $$_ > $min_width; + ++$$_; + ++$total; + last STRETCHER + if $total >= 80; + } + } + + # Dump the output + my $format = join( ' ', map { "%${_}s" } @col_widths ) . "\n"; + substr( $format, 1, 0 ) = '-'; + for ( @rows ) { + printf $format, @$_; + } + + return \@rows ; +} + + +1; +package Carp; + +{ use 5.006; } +use strict; +use warnings; +BEGIN { + # Very old versions of warnings.pm load Carp. This can go wrong due + # to the circular dependency. If warnings is invoked before Carp, + # then warnings starts by loading Carp, then Carp (above) tries to + # invoke warnings, and gets nothing because warnings is in the process + # of loading and hasn't defined its import method yet. If we were + # only turning on warnings ("use warnings" above) this wouldn't be too + # bad, because Carp would just gets the state of the -w switch and so + # might not get some warnings that it wanted. The real problem is + # that we then want to turn off Unicode warnings, but "no warnings + # 'utf8'" won't be effective if we're in this circular-dependency + # situation. So, if warnings.pm is an affected version, we turn + # off all warnings ourselves by directly setting ${^WARNING_BITS}. + # On unaffected versions, we turn off just Unicode warnings, via + # the proper API. + if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { + ${^WARNING_BITS} = ""; + } else { + "warnings"->unimport("utf8"); + } +} + +sub _fetch_sub { # fetch sub without autovivifying + my($pack, $sub) = @_; + $pack .= '::'; + # only works with top-level packages + return unless exists($::{$pack}); + for ($::{$pack}) { + return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub}; + for ($$_{$sub}) { + return ref \$_ eq 'GLOB' ? *$_{CODE} : undef + } + } +} + +# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp +# must avoid applying a regular expression to an upgraded (is_utf8) +# string. There are multiple problems, on different Perl versions, +# that require this to be avoided. All versions prior to 5.13.8 will +# load utf8_heavy.pl for the swash system, even if the regexp doesn't +# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit +# specific problems when Carp is being invoked in the aftermath of a +# syntax error. +BEGIN { + if("$]" < 5.013011) { + *UTF8_REGEXP_PROBLEM = sub () { 1 }; + } else { + *UTF8_REGEXP_PROBLEM = sub () { 0 }; + } +} + +# is_utf8() is essentially the utf8::is_utf8() function, which indicates +# whether a string is represented in the upgraded form (using UTF-8 +# internally). As utf8::is_utf8() is only available from Perl 5.8 +# onwards, extra effort is required here to make it work on Perl 5.6. +BEGIN { + if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) { + *is_utf8 = $sub; + } else { + # black magic for perl 5.6 + *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 }; + } +} + +# The downgrade() function defined here is to be used for attempts to +# downgrade where it is acceptable to fail. It must be called with a +# second argument that is a true value. +BEGIN { + if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) { + *downgrade = \&{"utf8::downgrade"}; + } else { + *downgrade = sub { + my $r = ""; + my $l = length($_[0]); + for(my $i = 0; $i != $l; $i++) { + my $o = ord(substr($_[0], $i, 1)); + return if $o > 255; + $r .= chr($o); + } + $_[0] = $r; + }; + } +} + +# is_safe_printable_codepoint() indicates whether a character, specified +# by integer codepoint, is OK to output literally in a trace. Generally +# this is if it is a printable character in the ancestral character set +# (ASCII or EBCDIC). This is used on some Perls in situations where a +# regexp can't be used. +BEGIN { + *is_safe_printable_codepoint = + "$]" >= 5.007_003 ? + eval(q(sub ($) { + my $u = utf8::native_to_unicode($_[0]); + $u >= 0x20 && $u <= 0x7e; + })) + : ord("A") == 65 ? + sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e } + : + sub ($) { + # Early EBCDIC + # 3 EBCDIC code pages supported then; all controls but one + # are the code points below SPACE. The other one is 0x5F on + # POSIX-BC; FF on the other two. + # FIXME: there are plenty of unprintable codepoints other + # than those that this code and the comment above identifies + # as "controls". + $_[0] >= ord(" ") && $_[0] <= 0xff && + $_[0] != (ord ("^") == 106 ? 0x5f : 0xff); + } + ; +} + +sub _univ_mod_loaded { + return 0 unless exists($::{"UNIVERSAL::"}); + for ($::{"UNIVERSAL::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"}; + for ($$_{"$_[0]::"}) { + return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"}; + for ($$_{"VERSION"}) { + return 0 unless ref \$_ eq "GLOB"; + return ${*$_{SCALAR}}; + } + } + } +} + +# _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid +# the latter if the UNIVERSAL::isa module has been loaded, to avoid infi- +# nite recursion; in that case _maybe_isa simply returns true. +my $isa; +BEGIN { + if (_univ_mod_loaded('isa')) { + *_maybe_isa = sub { 1 } + } + else { + # Since we have already done the check, record $isa for use below + # when defining _StrVal. + *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa"); + } +} + + +# We need an overload::StrVal or equivalent function, but we must avoid +# loading any modules on demand, as Carp is used from __DIE__ handlers and +# may be invoked after a syntax error. +# We can copy recent implementations of overload::StrVal and use +# overloading.pm, which is the fastest implementation, so long as +# overloading is available. If it is not available, we use our own pure- +# Perl StrVal. We never actually use overload::StrVal, for various rea- +# sons described below. +# overload versions are as follows: +# undef-1.00 (up to perl 5.8.0) uses bless (avoid!) +# 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util +# 1.18+ (perl 5.16+) uses overloading +# The ancient 'bless' implementation (that inspires our pure-Perl version) +# blesses unblessed references and must be avoided. Those using +# Scalar::Util use refaddr, possibly the pure-Perl implementation, which +# has the same blessing bug, and must be avoided. Also, Scalar::Util is +# loaded on demand. Since we avoid the Scalar::Util implementations, we +# end up having to implement our own overloading.pm-based version for perl +# 5.10.1 to 5.14. Since it also works just as well in more recent ver- +# sions, we use it there, too. +BEGIN { + if (eval { require "overloading.pm" }) { + *_StrVal = eval 'sub { no overloading; "$_[0]" }' + } + else { + # Work around the UNIVERSAL::can/isa modules to avoid recursion. + + # _mycan is either UNIVERSAL::can, or, in the presence of an + # override, overload::mycan. + *_mycan = _univ_mod_loaded('can') + ? do { require "overload.pm"; _fetch_sub overload => 'mycan' } + : \&UNIVERSAL::can; + + # _blessed is either UNIVERAL::isa(...), or, in the presence of an + # override, a hideous, but fairly reliable, workaround. + *_blessed = $isa + ? sub { &$isa($_[0], "UNIVERSAL") } + : sub { + my $probe = "UNIVERSAL::Carp_probe_" . rand; + no strict 'refs'; + local *$probe = sub { "unlikely string" }; + local $@; + local $SIG{__DIE__} = sub{}; + (eval { $_[0]->$probe } || '') eq 'unlikely string' + }; + + *_StrVal = sub { + my $pack = ref $_[0]; + # Perl's overload mechanism uses the presence of a special + # "method" named "((" or "()" to signal it is in effect. + # This test seeks to see if it has been set up. "((" post- + # dates overloading.pm, so we can skip it. + return "$_[0]" unless _mycan($pack, "()"); + # Even at this point, the invocant may not be blessed, so + # check for that. + return "$_[0]" if not _blessed($_[0]); + bless $_[0], "Carp"; + my $str = "$_[0]"; + bless $_[0], $pack; + $pack . substr $str, index $str, "="; + } + } +} + + +our $VERSION = '1.50'; +$VERSION =~ tr/_//d; + +our $MaxEvalLen = 0; +our $Verbose = 0; +our $CarpLevel = 0; +our $MaxArgLen = 64; # How much of each argument to print. 0 = all. +our $MaxArgNums = 8; # How many arguments to print. 0 = all. +our $RefArgFormatter = undef; # allow caller to format reference arguments + +require Exporter; +our @ISA = ('Exporter'); +our @EXPORT = qw(confess croak carp); +our @EXPORT_OK = qw(cluck verbose longmess shortmess); +our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode + +# The members of %Internal are packages that are internal to perl. +# Carp will not report errors from within these packages if it +# can. The members of %CarpInternal are internal to Perl's warning +# system. Carp will not report errors from within these packages +# either, and will not report calls *to* these packages for carp and +# croak. They replace $CarpLevel, which is deprecated. The +# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval +# text and function arguments should be formatted when printed. + +our %CarpInternal; +our %Internal; + +# disable these by default, so they can live w/o require Carp +$CarpInternal{Carp}++; +$CarpInternal{warnings}++; +$Internal{Exporter}++; +$Internal{'Exporter::Heavy'}++; + +# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") +# then the following method will be called by the Exporter which knows +# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word +# 'verbose'. + +sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } + +sub _cgc { + no strict 'refs'; + return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; + return; +} + +sub longmess { + local($!, $^E); + # Icky backwards compatibility wrapper. :-( + # + # The story is that the original implementation hard-coded the + # number of call levels to go back, so calls to longmess were off + # by one. Other code began calling longmess and expecting this + # behaviour, so the replacement has to emulate that behaviour. + my $cgc = _cgc(); + my $call_pack = $cgc ? $cgc->() : caller(); + if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { + return longmess_heavy(@_); + } + else { + local $CarpLevel = $CarpLevel + 1; + return longmess_heavy(@_); + } +} + +our @CARP_NOT; + +sub shortmess { + local($!, $^E); + my $cgc = _cgc(); + + # Icky backwards compatibility wrapper. :-( + local @CARP_NOT = $cgc ? $cgc->() : caller(); + shortmess_heavy(@_); +} + +sub croak { die shortmess @_ } +sub confess { die longmess @_ } +sub carp { warn shortmess @_ } +sub cluck { warn longmess @_ } + +BEGIN { + if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) || + ("$]" >= 5.012005 && "$]" < 5.013)) { + *CALLER_OVERRIDE_CHECK_OK = sub () { 1 }; + } else { + *CALLER_OVERRIDE_CHECK_OK = sub () { 0 }; + } +} + +sub caller_info { + my $i = shift(@_) + 1; + my %call_info; + my $cgc = _cgc(); + { + # Some things override caller() but forget to implement the + # @DB::args part of it, which we need. We check for this by + # pre-populating @DB::args with a sentinel which no-one else + # has the address of, so that we can detect whether @DB::args + # has been properly populated. However, on earlier versions + # of perl this check tickles a bug in CORE::caller() which + # leaks memory. So we only check on fixed perls. + @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK; + package DB; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) } + = $cgc ? $cgc->($i) : caller($i); + } + + unless ( defined $call_info{file} ) { + return (); + } + + my $sub_name = Carp::get_subname( \%call_info ); + if ( $call_info{has_args} ) { + # Guard our serialization of the stack from stack refcounting bugs + # NOTE this is NOT a complete solution, we cannot 100% guard against + # these bugs. However in many cases Perl *is* capable of detecting + # them and throws an error when it does. Unfortunately serializing + # the arguments on the stack is a perfect way of finding these bugs, + # even when they would not affect normal program flow that did not + # poke around inside the stack. Inside of Carp.pm it makes little + # sense reporting these bugs, as Carp's job is to report the callers + # errors, not the ones it might happen to tickle while doing so. + # See: https://rt.perl.org/Public/Bug/Display.html?id=131046 + # and: https://rt.perl.org/Public/Bug/Display.html?id=52610 + # for more details and discussion. - Yves + my @args = map { + my $arg; + local $@= $@; + eval { + $arg = $_; + 1; + } or do { + $arg = '** argument not available anymore **'; + }; + $arg; + } @DB::args; + if (CALLER_OVERRIDE_CHECK_OK && @args == 1 + && ref $args[0] eq ref \$i + && $args[0] == \$i ) { + @args = (); # Don't let anyone see the address of $i + local $@; + my $where = eval { + my $func = $cgc or return ''; + my $gv = + (_fetch_sub B => 'svref_2object' or return '') + ->($func)->GV; + my $package = $gv->STASH->NAME; + my $subname = $gv->NAME; + return unless defined $package && defined $subname; + + # returning CORE::GLOBAL::caller isn't useful for tracing the cause: + return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; + " in &${package}::$subname"; + } || ''; + @args + = "** Incomplete caller override detected$where; \@DB::args were not set **"; + } + else { + my $overflow; + if ( $MaxArgNums and @args > $MaxArgNums ) + { # More than we want to show? + $#args = $MaxArgNums - 1; + $overflow = 1; + } + + @args = map { Carp::format_arg($_) } @args; + + if ($overflow) { + push @args, '...'; + } + } + + # Push the args onto the subroutine + $sub_name .= '(' . join( ', ', @args ) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} + +# Transform an argument to a function into a string. +our $in_recurse; +sub format_arg { + my $arg = shift; + + if ( my $pack= ref($arg) ) { + + # legitimate, let's not leak it. + if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) && + do { + local $@; + local $in_recurse = 1; + local $SIG{__DIE__} = sub{}; + eval {$arg->can('CARP_TRACE') } + }) + { + return $arg->CARP_TRACE(); + } + elsif (!$in_recurse && + defined($RefArgFormatter) && + do { + local $@; + local $in_recurse = 1; + local $SIG{__DIE__} = sub{}; + eval {$arg = $RefArgFormatter->($arg); 1} + }) + { + return $arg; + } + else + { + # Argument may be blessed into a class with overloading, and so + # might have an overloaded stringification. We don't want to + # risk getting the overloaded stringification, so we need to + # use _StrVal, our overload::StrVal()-equivalent. + return _StrVal $arg; + } + } + return "undef" if !defined($arg); + downgrade($arg, 1); + return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) && + $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/; + my $suffix = ""; + if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) { + substr ( $arg, $MaxArgLen - 3 ) = ""; + $suffix = "..."; + } + if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) { + for(my $i = length($arg); $i--; ) { + my $c = substr($arg, $i, 1); + my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2} + if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") { + substr $arg, $i, 0, "\\"; + next; + } + my $o = ord($c); + substr $arg, $i, 1, sprintf("\\x{%x}", $o) + unless is_safe_printable_codepoint($o); + } + } else { + $arg =~ s/([\"\\\$\@])/\\$1/g; + # This is all the ASCII printables spelled-out. It is portable to all + # Perl versions and platforms (such as EBCDIC). There are other more + # compact ways to do this, but may not work everywhere every version. + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; + } + downgrade($arg, 1); + return "\"".$arg."\"".$suffix; +} + +sub Regexp::CARP_TRACE { + my $arg = "$_[0]"; + downgrade($arg, 1); + if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) { + for(my $i = length($arg); $i--; ) { + my $o = ord(substr($arg, $i, 1)); + my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2} + substr $arg, $i, 1, sprintf("\\x{%x}", $o) + unless is_safe_printable_codepoint($o); + } + } else { + # See comment in format_arg() about this same regex. + $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg; + } + downgrade($arg, 1); + my $suffix = ""; + if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) { + ($suffix, $arg) = ($1, $2); + } + if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) { + substr ( $arg, $MaxArgLen - 3 ) = ""; + $suffix = "...".$suffix; + } + return "qr($arg)$suffix"; +} + +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; + return @{ $cache->{$pkg} }; +} + +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if ( defined( $info->{evaltext} ) ) { + my $eval = $info->{evaltext}; + if ( $info->{is_require} ) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; + } + } + + # this can happen on older perls when the sub (or the stash containing it) + # has been deleted + if ( !defined( $info->{sub} ) ) { + return '__ANON__::__ANON__'; + } + + return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; +} + +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + ++$i; + my $cgc = _cgc(); + my @caller = $cgc ? $cgc->($i) : caller($i); + my $pkg = $caller[0]; + unless ( defined($pkg) ) { + + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + elsif (defined $caller[2]) { + # this can happen when the stash has been deleted + # in that case, just assume that it's a reasonable place to + # stop (the file and line data will still be intact in any + # case) - the only issue is that we can't detect if the + # deleted package was internal (so don't do that then) + # -doy + redo unless 0 > --$lvl; + last; + } + else { + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} + +sub longmess_heavy { + if ( ref( $_[0] ) ) { # don't break references as exceptions + return wantarray ? @_ : $_[0]; + } + my $i = long_error_loc(); + return ret_backtrace( $i, @_ ); +} + +BEGIN { + if("$]" >= 5.017004) { + # The LAST_FH constant is a reference to the variable. + $Carp::{LAST_FH} = \eval '\${^LAST_FH}'; + } else { + eval '*LAST_FH = sub () { 0 }'; + } +} + +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ( $i, @error ) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if ( defined &threads::tid ) { + my $tid = threads->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg"; + if( $. ) { + # Use ${^LAST_FH} if available. + if (LAST_FH) { + if (${+LAST_FH}) { + $mess .= sprintf ", <%s> %s %d", + *${+LAST_FH}{NAME}, + ($/ eq "\n" ? "line" : "chunk"), $. + } + } + else { + local $@ = ''; + local $SIG{__DIE__}; + eval { + CORE::die; + }; + if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) { + $mess .= $1; + } + } + } + $mess .= "\.\n"; + + while ( my %i = caller_info( ++$i ) ) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + } + + return $mess; +} + +sub ret_summary { + my ( $i, @error ) = @_; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if ( defined &threads::tid ) { + my $tid = threads->tid; + $tid_msg = " thread $tid" if $tid; + } + + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\.\n"; +} + +sub short_error_loc { + # You have to create your (hash)ref out here, rather than defaulting it + # inside trusts *on a lexical*, as you want it to persist across calls. + # (You can default it on $_[2], but that gets messy) + my $cache = {}; + my $i = 1; + my $lvl = $CarpLevel; + { + my $cgc = _cgc(); + my $called = $cgc ? $cgc->($i) : caller($i); + $i++; + my $caller = $cgc ? $cgc->($i) : caller($i); + + if (!defined($caller)) { + my @caller = $cgc ? $cgc->($i) : caller($i); + if (@caller) { + # if there's no package but there is other caller info, then + # the package has been deleted - treat this as a valid package + # in this case + redo if defined($called) && $CarpInternal{$called}; + redo unless 0 > --$lvl; + last; + } + else { + return 0; + } + } + redo if $Internal{$caller}; + redo if $CarpInternal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts( $called, $caller, $cache ); + redo if trusts( $caller, $called, $cache ); + redo unless 0 > --$lvl; + } + return $i - 1; +} + +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref( $_[0] ); # don't break references as exceptions + my $i = short_error_loc(); + if ($i) { + ret_summary( $i, @_ ); + } + else { + longmess_heavy(@_); + } +} + +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if ( 2 < $max and $max < length($str) ) { + substr( $str, $max - 3 ) = '...'; + } + return $str; +} + +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift; + my ( $known, $partial ) = get_status( $cache, $child ); + + # Figure out consequences until we have an answer + while ( @$partial and not exists $known->{$parent} ) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; + } + return exists $known->{$parent}; +} + +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + no strict 'refs'; + my $stash = \%{"$class\::"}; + for my $var (qw/ CARP_NOT ISA /) { + # Don't try using the variable until we know it exists, + # to avoid polluting the caller's namespace. + if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB' + && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) { + return @{$stash->{$var}} + } + } + return; +} + +if(!defined($warnings::VERSION) || + do { no warnings "numeric"; $warnings::VERSION < 1.03 }) { + # Very old versions of warnings.pm import from Carp. This can go + # wrong due to the circular dependency. If Carp is invoked before + # warnings, then Carp starts by loading warnings, then warnings + # tries to import from Carp, and gets nothing because Carp is in + # the process of loading and hasn't defined its import method yet. + # So we work around that by manually exporting to warnings here. + no strict "refs"; + *{"warnings::$_"} = \&$_ foreach @EXPORT; +} + +1; + +__END__ + +# +# Documentation is at the __END__ +# + +package DB; + +# "private" globals + +my ($running, $ready, $deep, $usrctxt, $evalarg, + @stack, @saved, @skippkg, @clients); +my $preeval = {}; +my $posteval = {}; +my $ineval = {}; + +#### +# +# Globals - must be defined at startup so that clients can refer to +# them right after a C +# +#### + +BEGIN { + + # these are hardcoded in perl source (some are magical) + + $DB::sub = ''; # name of current subroutine + %DB::sub = (); # "filename:fromline-toline" for every known sub + $DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use) + $DB::signal = 0; # signal flag (will cause a stop at the next line) + $DB::trace = 0; # are we tracing through subroutine calls? + @DB::args = (); # arguments of current subroutine or @ARGV array + @DB::dbline = (); # list of lines in currently loaded file + %DB::dbline = (); # actions in current file (keyed by line number) + @DB::ret = (); # return value of last sub executed in list context + $DB::ret = ''; # return value of last sub executed in scalar context + + # other "public" globals + + $DB::package = ''; # current package space + $DB::filename = ''; # current filename + $DB::subname = ''; # currently executing sub (fully qualified name) + $DB::lineno = ''; # current line number + + $DB::VERSION = $DB::VERSION = '1.08'; + + # initialize private globals to avoid warnings + + $running = 1; # are we running, or are we stopped? + @stack = (0); + @clients = (); + $deep = 1000; + $ready = 0; + @saved = (); + @skippkg = (); + $usrctxt = ''; + $evalarg = ''; +} + +#### +# entry point for all subroutine calls +# +sub sub { + push(@stack, $DB::single); + $DB::single &= 1; + $DB::single |= 4 if $#stack == $deep; + if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) { + &$DB::sub; + $DB::single |= pop(@stack); + $DB::ret = undef; + } + elsif (wantarray) { + @DB::ret = &$DB::sub; + $DB::single |= pop(@stack); + @DB::ret; + } + else { + $DB::ret = &$DB::sub; + $DB::single |= pop(@stack); + $DB::ret; + } +} + +#### +# this is called by perl for every statement +# +sub DB { + return unless $ready; + &save; + ($DB::package, $DB::filename, $DB::lineno) = caller; + + return if @skippkg and grep { $_ eq $DB::package } @skippkg; + + $usrctxt = "package $DB::package;"; # this won't let them modify, alas + local(*DB::dbline) = "::_<$DB::filename"; + + my ($stop, $action); + if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) { + if ($stop eq '1') { + $DB::signal |= 1; + } + else { + $stop = 0 unless $stop; # avoid un_init warning + $evalarg = "\$DB::signal |= do { $stop; }"; &eval; + $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt + } + } + if ($DB::single || $DB::trace || $DB::signal) { + $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #'; + DB->loadfile($DB::filename, $DB::lineno); + } + $evalarg = $action, &eval if $action; + if ($DB::single || $DB::signal) { + _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4; + $DB::single = 0; + $DB::signal = 0; + $running = 0; + + &eval if ($evalarg = DB->prestop); + my $c; + for $c (@clients) { + # perform any client-specific prestop actions + &eval if ($evalarg = $c->cprestop); + + # Now sit in an event loop until something sets $running + do { + $c->idle; # call client event loop; must not block + if ($running == 2) { # client wants something eval-ed + &eval if ($evalarg = $c->evalcode); + $running = 0; + } + } until $running; + + # perform any client-specific poststop actions + &eval if ($evalarg = $c->cpoststop); + } + &eval if ($evalarg = DB->poststop); + } + ($@, $!, $,, $/, $\, $^W) = @saved; + (); +} + +#### +# this takes its argument via $evalarg to preserve current @_ +# +sub eval { + ($@, $!, $,, $/, $\, $^W) = @saved; + eval "$usrctxt $evalarg; &DB::save"; + _outputall($@) if $@; +} + +############################################################################### +# no compile-time subroutine call allowed before this point # +############################################################################### + +use strict; # this can run only after DB() and sub() are defined + +sub save { + @saved = ($@, $!, $,, $/, $\, $^W); + $, = ""; $/ = "\n"; $\ = ""; $^W = 0; +} + +sub catch { + for (@clients) { $_->awaken; } + $DB::signal = 1; + $ready = 1; +} + +#### +# +# Client callable (read inheritable) methods defined after this point +# +#### + +sub register { + my $s = shift; + $s = _clientname($s) if ref($s); + push @clients, $s; +} + +sub done { + my $s = shift; + $s = _clientname($s) if ref($s); + @clients = grep {$_ ne $s} @clients; + $s->cleanup; +# $running = 3 unless @clients; + exit(0) unless @clients; +} + +sub _clientname { + my $name = shift; + "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; + return $1; +} + +sub next { + my $s = shift; + $DB::single = 2; + $running = 1; +} + +sub step { + my $s = shift; + $DB::single = 1; + $running = 1; +} + +sub cont { + my $s = shift; + my $i = shift; + $s->set_tbreak($i) if $i; + for ($i = 0; $i <= $#stack;) { + $stack[$i++] &= ~1; + } + $DB::single = 0; + $running = 1; +} + +#### +# XXX caller must experimentally determine $i (since it depends +# on how many client call frames are between this call and the DB call). +# Such is life. +# +sub ret { + my $s = shift; + my $i = shift; # how many levels to get to DB sub + $i = 0 unless defined $i; + $stack[$#stack-$i] |= 1; + $DB::single = 0; + $running = 1; +} + +#### +# XXX caller must experimentally determine $start (since it depends +# on how many client call frames are between this call and the DB call). +# Such is life. +# +sub backtrace { + my $self = shift; + my $start = shift; + my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i); + $start = 1 unless $start; + for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { + @a = @DB::args; + for (@a) { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + require 'meta_notation.pm'; + $_ = _meta_notation($_) if /[[:^print:]]/a; + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/[\\\']/\\$1/g if $e; + if ($r) { + $s = "require '$e'"; + } elsif (defined $r) { + $s = "eval '$e'"; + } elsif ($s eq '(eval)') { + $s = "eval {...}"; + } + $f = "file '$f'" unless $f eq '-e'; + push @ret, "$w&$s$a from $f line $l"; + last if $DB::signal; + } + return @ret; +} + +sub _outputall { + my $c; + for $c (@clients) { + $c->output(@_); + } +} + +sub trace_toggle { + my $s = shift; + $DB::trace = !$DB::trace; +} + + +#### +# without args: returns all defined subroutine names +# with subname args: returns a listref [file, start, end] +# +sub subs { + my $s = shift; + if (@_) { + my(@ret) = (); + while (@_) { + my $name = shift; + push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] + if exists $DB::sub{$name}; + } + return @ret; + } + return keys %DB::sub; +} + +#### +# first argument is a filename whose subs will be returned +# if a filename is not supplied, all subs in the current +# filename are returned. +# +sub filesubs { + my $s = shift; + my $fname = shift; + $fname = $DB::filename unless $fname; + return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub; +} + +#### +# returns a list of all filenames that DB knows about +# +sub files { + my $s = shift; + my(@f) = grep(m|^_<|, keys %main::); + return map { substr($_,2) } @f; +} + +#### +# returns reference to an array holding the lines in currently +# loaded file +# +sub lines { + my $s = shift; + return \@DB::dbline; +} + +#### +# loadfile($file, $line) +# +sub loadfile { + my $s = shift; + my($file, $line) = @_; + if (!defined $main::{'_<' . $file}) { + my $try; + if (($try) = grep(m|^_<.*$file|, keys %main::)) { + $file = substr($try,2); + } + } + if (defined($main::{'_<' . $file})) { + my $c; +# _outputall("Loading file $file.."); + *DB::dbline = "::_<$file"; + $DB::filename = $file; + for $c (@clients) { +# print "2 ", $file, '|', $line, "\n"; + $c->showfile($file, $line); + } + return $file; + } + return undef; +} + +sub lineevents { + my $s = shift; + my $fname = shift; + my(%ret) = (); + my $i; + $fname = $DB::filename unless $fname; + local(*DB::dbline) = "::_<$fname"; + for ($i = 1; $i <= $#DB::dbline; $i++) { + $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})] + if defined $DB::dbline{$i}; + } + return %ret; +} + +sub set_break { + my $s = shift; + my $i = shift; + my $cond = shift; + $i ||= $DB::lineno; + $cond ||= '1'; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not breakable.\n"); + } + else { + $DB::dbline{$i} =~ s/^[^\0]*/$cond/; + } + } +} + +sub set_tbreak { + my $s = shift; + my $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not breakable.\n"); + } + else { + $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. + } + } +} + +sub _find_subline { + my $name = shift; + $name =~ s/\'/::/; + $name = "${DB::package}\:\:" . $name if $name !~ /::/; + $name = "main" . $name if substr($name,0,2) eq "::"; + my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/); + if ($from) { + local *DB::dbline = "::_<$fname"; + ++$from while $DB::dbline[$from] == 0 && $from < $to; + return $from; + } + return undef; +} + +sub clr_breaks { + my $s = shift; + my $i; + if (@_) { + while (@_) { + $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/^[^\0]+//; + if ($DB::dbline{$i} =~ s/^\0?$//) { + delete $DB::dbline{$i}; + } + } + } + } + else { + for ($i = 1; $i <= $#DB::dbline ; $i++) { + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/^[^\0]+//; + if ($DB::dbline{$i} =~ s/^\0?$//) { + delete $DB::dbline{$i}; + } + } + } + } +} + +sub set_action { + my $s = shift; + my $i = shift; + my $act = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i) { + if ($DB::dbline[$i] == 0) { + $s->output("Line $i not actionable.\n"); + } + else { + $DB::dbline{$i} =~ s/\0[^\0]*//; + $DB::dbline{$i} .= "\0" . $act; + } + } +} + +sub clr_actions { + my $s = shift; + my $i; + if (@_) { + while (@_) { + my $i = shift; + $i = _find_subline($i) if ($i =~ /\D/); + $s->output("Subroutine not found.\n") unless $i; + if ($i && $DB::dbline[$i] != 0) { + $DB::dbline{$i} =~ s/\0[^\0]*//; + delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; + } + } + } + else { + for ($i = 1; $i <= $#DB::dbline ; $i++) { + if (defined $DB::dbline{$i}) { + $DB::dbline{$i} =~ s/\0[^\0]*//; + delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; + } + } + } +} + +sub prestop { + my ($client, $val) = @_; + return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; +} + +sub poststop { + my ($client, $val) = @_; + return defined($val) ? $posteval->{$client} = $val : $posteval->{$client}; +} + +# +# "pure virtual" methods +# + +# client-specific pre/post-stop actions. +sub cprestop {} +sub cpoststop {} + +# client complete startup +sub awaken {} + +sub skippkg { + my $s = shift; + push @skippkg, @_ if @_; +} + +sub evalcode { + my ($client, $val) = @_; + if (defined $val) { + $running = 2; # hand over to DB() to evaluate in its context + $ineval->{$client} = $val; + } + return $ineval->{$client}; +} + +sub ready { + my $s = shift; + return $ready = 1; +} + +# stubs + +sub init {} +sub stop {} +sub idle {} +sub cleanup {} +sub output {} + +# +# client init +# +for (@clients) { $_->init } + +$SIG{'INT'} = \&DB::catch; + +# disable this if stepping through END blocks is desired +# (looks scary and deconstructivist with Swat) +END { $ready = 0 } + +1; +__END__ + +package FileHandle; + +use 5.006; +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK); + +$VERSION = "2.03"; + +require IO::File; +@ISA = qw(IO::File); + +@EXPORT = qw(_IOFBF _IOLBF _IONBF); + +@EXPORT_OK = qw( + pipe + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + + print + printf + getline + getlines +); + +# +# Everything we're willing to export, we must first import. +# +IO::Handle->import( grep { !defined(&$_) } @EXPORT, @EXPORT_OK ); + +# +# Some people call "FileHandle::function", so all the functions +# that were in the old FileHandle class must be imported, too. +# +{ + no strict 'refs'; + + my %import = ( + 'IO::Handle' => + [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets + eof flush error clearerr setbuf setvbuf _open_mode_string)], + 'IO::Seekable' => + [qw(seek tell getpos setpos)], + 'IO::File' => + [qw(new new_tmpfile open)] + ); + for my $pkg (keys %import) { + for my $func (@{$import{$pkg}}) { + my $c = *{"${pkg}::$func"}{CODE} + or die "${pkg}::$func missing"; + *$func = $c; + } + } +} + +# +# Specialized importer for Fcntl magic. +# +sub import { + my $pkg = shift; + my $callpkg = caller; + require Exporter; + Exporter::export($pkg, $callpkg, @_); + + # + # If the Fcntl extension is available, + # export its constants. + # + eval { + require Fcntl; + Exporter::export('Fcntl', $callpkg); + }; +} + +################################################ +# This is the only exported function we define; +# the rest come from other classes. +# + +sub pipe { + my $r = IO::Handle->new; + my $w = IO::Handle->new; + CORE::pipe($r, $w) or return undef; + ($r, $w); +} + +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + +1; + +__END__ + +package filetest; + +our $VERSION = '1.03'; + + +$filetest::hint_bits = 0x00400000; # HINT_FILETEST_ACCESS + +sub import { + if ( $_[1] eq 'access' ) { + $^H |= $filetest::hint_bits; + } else { + die "filetest: the only implemented subpragma is 'access'.\n"; + } +} + +sub unimport { + if ( $_[1] eq 'access' ) { + $^H &= ~$filetest::hint_bits; + } else { + die "filetest: the only implemented subpragma is 'access'.\n"; + } +} + +1; +package bignum; + +use 5.010; +use strict; +use warnings; + +our $VERSION = '0.49'; + +use Exporter; +our @ISA = qw( bigint ); +our @EXPORT_OK = qw( PI e bpi bexp hex oct ); +our @EXPORT = qw( inf NaN ); + +use overload; +use bigint (); + +############################################################################## + +BEGIN { + *inf = \&bigint::inf; + *NaN = \&bigint::NaN; + *hex = \&bigint::hex; + *oct = \&bigint::oct; +} + +# These are all alike, and thus faked by AUTOLOAD + +my @faked = qw/round_mode accuracy precision div_scale/; +our ($AUTOLOAD, $_lite); # _lite for testsuite + +sub AUTOLOAD { + my $name = $AUTOLOAD; + + $name =~ s/.*:://; # split package + no strict 'refs'; + foreach my $n (@faked) { + if ($n eq $name) { + *{"bignum::$name"} = + sub { + my $self = shift; + no strict 'refs'; + if (defined $_[0]) { + Math::BigInt->$name($_[0]); + return Math::BigFloat->$name($_[0]); + } + return Math::BigInt->$name(); + }; + return &$name; + } + } + + # delayed load of Carp and avoid recursion + require Carp; + Carp::croak ("Can't call bignum\-\>$name, not a valid method"); +} + +sub unimport { + $^H{bignum} = undef; # no longer in effect + overload::remove_constant('binary', '', 'float', '', 'integer'); +} + +sub in_effect { + my $level = shift || 0; + my $hinthash = (caller($level))[10]; + $hinthash->{bignum}; +} + +############################################################################# + +sub import { + my $self = shift; + + $^H{bignum} = 1; # we are in effect + + # for newer Perls override hex() and oct() with a lexical version: + if ($] > 5.009004) { + bigint::_override(); + } + + # some defaults + my $lib = ''; + my $lib_kind = 'try'; + my $upgrade = 'Math::BigFloat'; + my $downgrade = 'Math::BigInt'; + + my @import = (':constant'); # drive it w/ constant + my @a = @_; + my $l = scalar @_; + my $j = 0; + my ($ver, $trace); # version? trace? + my ($a, $p); # accuracy, precision + for (my $i = 0; $i < $l; $i++, $j++) { + if ($_[$i] eq 'upgrade') { + # this causes upgrading + $upgrade = $_[$i + 1]; # or undef to disable + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } elsif ($_[$i] eq 'downgrade') { + # this causes downgrading + $downgrade = $_[$i + 1]; # or undef to disable + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } elsif ($_[$i] =~ /^(l|lib|try|only)$/) { + # this causes a different low lib to take care... + $lib_kind = $1; + $lib_kind = 'lib' if $lib_kind eq 'l'; + $lib = $_[$i + 1] || ''; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(a|accuracy)$/) { + $a = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(p|precision)$/) { + $p = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } + elsif ($_[$i] =~ /^(v|version)$/) { + $ver = 1; + splice @a, $j, 1; + $j--; + } + elsif ($_[$i] =~ /^(t|trace)$/) { + $trace = 1; + splice @a, $j, 1; + $j--; + } + elsif ($_[$i] !~ /^(PI|e|bexp|bpi|hex|oct)\z/) { + die ("unknown option $_[$i]"); + } + } + my $class; + $_lite = 0; # using M::BI::L ? + if ($trace) { + require Math::BigInt::Trace; + $class = 'Math::BigInt::Trace'; + $upgrade = 'Math::BigFloat::Trace'; + } + else { + # see if we can find Math::BigInt::Lite + if (!defined $a && !defined $p) { # rounding won't work to well + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + if (eval { require Math::BigInt::Lite; 1 }) { + @import = (); # :constant in Lite, not MBI + Math::BigInt::Lite->import(':constant'); + $_lite = 1; # signal okay + } + } + require Math::BigInt if $_lite == 0; # not already loaded? + $class = 'Math::BigInt'; # regardless of MBIL or not + } + push @import, $lib_kind => $lib if $lib ne ''; + # Math::BigInt::Trace or plain Math::BigInt + $class->import(@import, upgrade => $upgrade); + + if ($trace) { + require Math::BigFloat::Trace; + $class = 'Math::BigFloat::Trace'; + $downgrade = 'Math::BigInt::Trace'; + } + else { + require Math::BigFloat; + $class = 'Math::BigFloat'; + } + $class->import(':constant', 'downgrade', $downgrade); + + bignum->accuracy($a) if defined $a; + bignum->precision($p) if defined $p; + if ($ver) { + print "bignum\t\t\t v$VERSION\n"; + print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite; + print "Math::BigInt\t\t v$Math::BigInt::VERSION"; + my $config = Math::BigInt->config(); + print " lib => $config->{lib} v$config->{lib_version}\n"; + print "Math::BigFloat\t\t v$Math::BigFloat::VERSION\n"; + exit; + } + + # Take care of octal/hexadecimal constants + overload::constant binary => + sub { + bigint::_binary_constant(shift); + }; + + # if another big* was already loaded: + my ($package) = caller(); + + no strict 'refs'; + if (!defined *{"${package}::inf"}) { + $self->export_to_level(1, $self, @a); # export inf and NaN + } +} + +sub PI () { Math::BigFloat->new('3.141592653589793238462643383279502884197'); } +sub e () { Math::BigFloat->new('2.718281828459045235360287471352662497757'); } +sub bpi ($) { Math::BigFloat->bpi(@_); } +sub bexp ($$) { + my $x = Math::BigFloat->new($_[0]); + $x->bexp($_[1]); +} + +1; + +__END__ + +# !!!!!!! INTERNAL PERL USE ONLY !!!!!!! +# This helper module is for internal use by core Perl only. This module is +# subject to change or removal at any time without notice. Don't use it +# directly. Use the public module instead. + +package _charnames; +use strict; +use warnings; +our $VERSION = '1.45'; +use unicore::Name; # mktables-generated algorithmically-defined names + +use bytes (); # for $bytes::hint_bits +use re "/aa"; # Everything in here should be ASCII + +$Carp::Internal{ (__PACKAGE__) } = 1; + +# Translate between Unicode character names and their code points. This is a +# submodule of package , used to allow \N{...} to be autoloaded, +# but it was decided not to autoload the various functions in charnames; the +# splitting allows this behavior. +# +# The official names with their code points are stored in a table in +# lib/unicore/Name.pl which is read in as a large string (almost 3/4 Mb in +# Unicode 6.0). Each code point/name combination is separated by a \n in the +# string. (Some of the CJK and the Hangul syllable names are instead +# determined algorithmically via subroutines stored instead in +# lib/unicore/Name.pm). Because of the large size of this table, it isn't +# converted into hashes for faster lookup. +# +# But, user defined aliases are stored in their own hashes, as are Perl +# extensions to the official names. These are checked first before looking at +# the official table. +# +# Basically, the table is grepped for the input code point (viacode()) or +# name (the other functions), and the corresponding value on the same line is +# returned. The grepping is done by turning the input into a regular +# expression. Thus, the same table does double duty, used by both name and +# code point lookup. (If we were to have hashes, we would need two, one for +# each lookup direction.) +# +# For loose name matching, the logical thing would be to have a table +# with all the ignorable characters squeezed out, and then grep it with the +# similiarly-squeezed input name. (And this is in fact how the lookups are +# done with the small Perl extension hashes.) But since we need to be able to +# go from code point to official name, the original table would still need to +# exist. Due to the large size of the table, it was decided to not read +# another very large string into memory for a second table. Instead, the +# regular expression of the input name is modified to have optional spaces and +# dashes between characters. For example, in strict matching, the regular +# expression would be: +# qr/\tDIGIT ONE$/m +# Under loose matching, the blank would be squeezed out, and the re would be: +# qr/\tD[- ]?I[- ]?G[- ]?I[- ]?T[- ]?O[- ]?N[- ]?E$/m +# which matches a blank or dash between any characters in the official table. +# +# This is also how script lookup is done. Basically the re looks like +# qr/ (?:LATIN|GREEK|CYRILLIC) (?:SMALL )?LETTER $name/ +# where $name is the loose or strict regex for the remainder of the name. + +# The hashes are stored as utf8 strings. This makes it easier to deal with +# sequences. I (khw) also tried making Name.pl utf8, but it slowed things +# down by a factor of 7. I then tried making Name.pl store the ut8 +# equivalents but not calling them utf8. That led to similar speed as leaving +# it alone, but since that is harder for a human to parse, I left it as-is. + +my %system_aliases = ( + + 'SINGLE-SHIFT 2' => chr utf8::unicode_to_native(0x8E), + 'SINGLE-SHIFT 3' => chr utf8::unicode_to_native(0x8F), + 'PRIVATE USE 1' => chr utf8::unicode_to_native(0x91), + 'PRIVATE USE 2' => chr utf8::unicode_to_native(0x92), +); + +# These are the aliases above that differ under :loose and :full matching +# because the :full versions have blanks or hyphens in them. +#my %loose_system_aliases = ( +#); + +#my %deprecated_aliases; +#$deprecated_aliases{'BELL'} = chr utf8::unicode_to_native(0x07) if $^V lt v5.17.0; + +#my %loose_deprecated_aliases = ( +#); + +# These are special cased in :loose matching, differing only in a medial +# hyphen +my $HANGUL_JUNGSEONG_O_E_utf8 = chr 0x1180; +my $HANGUL_JUNGSEONG_OE_utf8 = chr 0x116C; + + +my $txt; # The table of official character names + +my %full_names_cache; # Holds already-looked-up names, so don't have to +# re-look them up again. The previous versions of charnames had scoping +# bugs. For example if we use script A in one scope and find and cache +# what Z resolves to, we can't use that cache in a different scope that +# uses script B instead of A, as Z might be an entirely different letter +# there; or there might be different aliases in effect in different +# scopes, or :short may be in effect or not effect in different scopes, +# or various combinations thereof. This was solved in this version +# mostly by moving things to %^H. But some things couldn't be moved +# there. One of them was the cache of runtime looked-up names, in part +# because %^H is read-only at runtime. I (khw) don't know why the cache +# was run-time only in the previous versions: perhaps oversight; perhaps +# that compile time looking doesn't happen in a loop so didn't think it +# was worthwhile; perhaps not wanting to make the cache too large. But +# I decided to make it compile time as well; this could easily be +# changed. +# Anyway, this hash is not scoped, and is added to at runtime. It +# doesn't have scoping problems because the data in it is restricted to +# official names, which are always invariant, and we only set it and +# look at it at during :full lookups, so is unaffected by any other +# scoped options. I put this in to maintain parity with the older +# version. If desired, a %short_names cache could also be made, as well +# as one for each script, say in %script_names_cache, with each key +# being a hash for a script named in a 'use charnames' statement. I +# decided not to do that for now, just because it's added complication, +# and because I'm just trying to maintain parity, not extend it. + +# Like %full_names_cache, but for use when :loose is in effect. There needs +# to be two caches because :loose may not be in effect for a scope, and a +# loose name could inappropriately be returned when only exact matching is +# called for. +my %loose_names_cache; + +# Designed so that test decimal first, and then hex. Leading zeros +# imply non-decimal, as do non-[0-9] +my $decimal_qr = qr/^[1-9]\d*$/; + +# Returns the hex number in $1. +my $hex_qr = qr/^(?:[Uu]\+|0[xX])?([[:xdigit:]]+)$/; + +sub croak +{ + require Carp; goto &Carp::croak; +} # croak + +sub carp +{ + require Carp; goto &Carp::carp; +} # carp + +sub alias (@) # Set up a single alias +{ + my @errors; + my $nbsp = chr utf8::unicode_to_native(0xA0); + + my $alias = ref $_[0] ? $_[0] : { @_ }; + foreach my $name (sort keys %$alias) { # Sort only because it helps having + # deterministic output for + # t/lib/charnames/alias + my $value = $alias->{$name}; + next unless defined $value; # Omit if screwed up. + + # Is slightly slower to just after this statement see if it is + # decimal, since we already know it is after having converted from + # hex, but makes the code easier to maintain, and is called + # infrequently, only at compile-time + if ($value !~ $decimal_qr && $value =~ $hex_qr) { + my $temp = CORE::hex $1; + $temp = utf8::unicode_to_native($temp) if $value =~ /^[Uu]\+/; + $value = $temp; + } + if ($value =~ $decimal_qr) { + no warnings qw(non_unicode surrogate nonchar); # Allow any of these + $^H{charnames_ord_aliases}{$name} = chr $value; + + # Use a canonical form. + $^H{charnames_inverse_ords}{sprintf("%05X", $value)} = $name; + } + else { + my $ok_portion = ""; + $ok_portion = $1 if $name =~ / ^ ( + \p{_Perl_Charname_Begin} + \p{_Perl_Charname_Continue}* + ) /x; + + # If the name was fully correct, the above should have matched all of + # it. + if (length $ok_portion < length $name) { + my $first_bad = substr($name, length($ok_portion), 1); + push @errors, "Invalid character in charnames alias definition; " + . "marked by <-- HERE in '$ok_portion$first_bad<-- HERE " + . substr($name, length($ok_portion) + 1) + . "'"; + } + else { + if ($name =~ / ( .* \s ) ( \s* ) $ /x) { + push @errors, "charnames alias definitions may not contain " + . "trailing white-space; marked by <-- HERE in " + . "'$1 <-- HERE " . $2 . "'"; + next; + } + + # Use '+' instead of '*' in this regex, because any trailing + # blanks have already been found + if ($name =~ / ( .*? \s{2} ) ( .+ ) /x) { + push @errors, "charnames alias definitions may not contain a " + . "sequence of multiple spaces; marked by <-- HERE " + . "in '$1 <-- HERE " . $2 . "'"; + next; + } + + $^H{charnames_name_aliases}{$name} = $value; + } + } + } + + # We find and output all errors from this :alias definition, rather than + # failing on the first one, so fewer runs are needed to get it to compile + if (@errors) { + croak join "\n", @errors; + } + + return; +} # alias + +sub not_legal_use_bytes_msg { + my ($name, $utf8) = @_; + my $return; + + if (length($utf8) == 1) { + $return = sprintf("Character 0x%04x with name '%s' is", ord $utf8, $name); + } else { + $return = sprintf("String with name '%s' (and ordinals %s) contains character(s)", $name, join(" ", map { sprintf "0x%04X", ord $_ } split(//, $utf8))); + } + return $return . " above 0xFF with 'use bytes' in effect"; +} + +sub alias_file ($) # Reads a file containing alias definitions +{ + require File::Spec; + my ($arg, $file) = @_; + if (-f $arg && File::Spec->file_name_is_absolute ($arg)) { + $file = $arg; + } + elsif ($arg =~ m/ ^ \p{_Perl_IDStart} \p{_Perl_IDCont}* $/x) { + $file = "unicore/${arg}_alias.pl"; + } + else { + croak "Charnames alias file names can only have identifier characters"; + } + if (my @alias = do $file) { + @alias == 1 && !defined $alias[0] and + croak "$file cannot be used as alias file for charnames"; + @alias % 2 and + croak "$file did not return a (valid) list of alias pairs"; + alias (@alias); + return (1); + } + 0; +} # alias_file + +# For use when don't import anything. This structure must be kept in +# sync with the one that import() fills up. +my %dummy_H = ( + charnames_stringified_names => "", + charnames_stringified_ords => "", + charnames_scripts => "", + charnames_full => 1, + charnames_loose => 0, + charnames_short => 0, + ); + + +sub lookup_name ($$$) { + my ($name, $wants_ord, $runtime) = @_; + + # Lookup the name or sequence $name in the tables. If $wants_ord is false, + # returns the string equivalent of $name; if true, returns the ordinal value + # instead, but in this case $name must not be a sequence; otherwise undef is + # returned and a warning raised. $runtime is 0 if compiletime, otherwise + # gives the number of stack frames to go back to get the application caller + # info. + # If $name is not found, returns undef in runtime with no warning; and in + # compiletime, the Unicode replacement character, with a warning. + + # It looks first in the aliases, then in the large table of official Unicode + # names. + + my $result; # The string result + my $save_input; + + if ($runtime) { + + my $hints_ref = (caller($runtime))[10]; + + # If we didn't import anything (which happens with 'use charnames ()', + # substitute a dummy structure. + $hints_ref = \%dummy_H if ! defined $hints_ref + || (! defined $hints_ref->{charnames_full} + && ! defined $hints_ref->{charnames_loose}); + + # At runtime, but currently not at compile time, %^H gets + # stringified, so un-stringify back to the original data structures. + # These get thrown away by perl before the next invocation + # Also fill in the hash with the non-stringified data. + # N.B. New fields must be also added to %dummy_H + + %{$^H{charnames_name_aliases}} = split ',', + $hints_ref->{charnames_stringified_names}; + %{$^H{charnames_ord_aliases}} = split ',', + $hints_ref->{charnames_stringified_ords}; + $^H{charnames_scripts} = $hints_ref->{charnames_scripts}; + $^H{charnames_full} = $hints_ref->{charnames_full}; + $^H{charnames_loose} = $hints_ref->{charnames_loose}; + $^H{charnames_short} = $hints_ref->{charnames_short}; + } + + my $loose = $^H{charnames_loose}; + my $lookup_name; # Input name suitably modified for grepping for in the + # table + + # User alias should be checked first or else can't override ours, and if we + # were to add any, could conflict with theirs. + if (exists $^H{charnames_ord_aliases}{$name}) { + $result = $^H{charnames_ord_aliases}{$name}; + } + elsif (exists $^H{charnames_name_aliases}{$name}) { + $name = $^H{charnames_name_aliases}{$name}; + $save_input = $lookup_name = $name; # Cache the result for any error + # message + # The aliases are documented to not match loosely, so change loose match + # into full. + if ($loose) { + $loose = 0; + $^H{charnames_full} = 1; + } + } + else { + + # Here, not a user alias. That means that loose matching may be in + # effect; will have to modify the input name. + $lookup_name = $name; + if ($loose) { + $lookup_name = uc $lookup_name; + + # Squeeze out all underscores + $lookup_name =~ s/_//g; + + # Remove all medial hyphens + $lookup_name =~ s/ (?<= \S ) - (?= \S )//gx; + + # Squeeze out all spaces + $lookup_name =~ s/\s//g; + } + + # Here, $lookup_name has been modified as necessary for looking in the + # hashes. Check the system alias files next. Most of these aliases are + # the same for both strict and loose matching. To save space, the ones + # which differ are in their own separate hash, which is checked if loose + # matching is selected and the regular match fails. To save time, the + # loose hashes could be expanded to include all aliases, and there would + # only have to be one check. But if someone specifies :loose, they are + # interested in convenience over speed, and the time for this second check + # is miniscule compared to the rest of the routine. + if (exists $system_aliases{$lookup_name}) { + $result = $system_aliases{$lookup_name}; + } + # There are currently no entries in this hash, so don't waste time looking + # for them. But the code is retained for the unlikely possibility that + # some will be added in the future. +# elsif ($loose && exists $loose_system_aliases{$lookup_name}) { +# $result = $loose_system_aliases{$lookup_name}; +# } +# if (exists $deprecated_aliases{$lookup_name}) { +# require warnings; +# warnings::warnif('deprecated', +# "Unicode character name \"$name\" is deprecated, use \"" +# . viacode(ord $deprecated_aliases{$lookup_name}) +# . "\" instead"); +# $result = $deprecated_aliases{$lookup_name}; +# } + # There are currently no entries in this hash, so don't waste time looking + # for them. But the code is retained for the unlikely possibility that + # some will be added in the future. +# elsif ($loose && exists $loose_deprecated_aliases{$lookup_name}) { +# require warnings; +# warnings::warnif('deprecated', +# "Unicode character name \"$name\" is deprecated, use \"" +# . viacode(ord $loose_deprecated_aliases{$lookup_name}) +# . "\" instead"); +# $result = $loose_deprecated_aliases{$lookup_name}; +# } + } + + my @off; # Offsets into table of pattern match begin and end + + # If haven't found it yet... + if (! defined $result) { + + # See if has looked this input up earlier. + if (! $loose && $^H{charnames_full} && exists $full_names_cache{$name}) { + $result = $full_names_cache{$name}; + } + elsif ($loose && exists $loose_names_cache{$name}) { + $result = $loose_names_cache{$name}; + } + else { # Here, must do a look-up + + # If full or loose matching succeeded, points to where to cache the + # result + my $cache_ref; + + ## Suck in the code/name list as a big string. + ## Lines look like: + ## "00052\tLATIN CAPITAL LETTER R\n" + # or + # "0052 0303\tLATIN CAPITAL LETTER R WITH TILDE\n" + $txt = do "unicore/Name.pl" unless $txt; + + ## @off will hold the index into the code/name string of the start and + ## end of the name as we find it. + + ## If :loose, look for a loose match; if :full, look for the name + ## exactly + # First, see if the name is one which is algorithmically determinable. + # The subroutine is included in Name.pl. The table contained in + # $txt doesn't contain these. Experiments show that checking + # for these before checking for the regular names has no + # noticeable impact on performance for the regular names, but + # the other way around slows down finding these immensely. + # Algorithmically determinables are not placed in the cache because + # that uses up memory, and finding these again is fast. + if (($loose || $^H{charnames_full}) + && (defined (my $ord = charnames::name_to_code_point_special($lookup_name, $loose)))) + { + $result = chr $ord; + } + else { + + # Not algorithmically determinable; look up in the table. The name + # will be turned into a regex, so quote any meta characters. + $lookup_name = quotemeta $lookup_name; + + if ($loose) { + + # For loose matches, $lookup_name has already squeezed out the + # non-essential characters. We have to add in code to make the + # squeezed version match the non-squeezed equivalent in the table. + # The only remaining hyphens are ones that start or end a word in + # the original. They have been quoted in $lookup_name so they look + # like "\-". Change all other characters except the backslash + # quotes for any metacharacters, and the final character, so that + # e.g., COLON gets transformed into: /C[- ]?O[- ]?L[- ]?O[- ]?N/ + $lookup_name =~ s/ (?! \\ -) # Don't do this to the \- sequence + ( [^-\\] ) # Nor the "-" within that sequence, + # nor the "\" that quotes metachars, + # but otherwise put the char into $1 + (?=.) # And don't do it for the final char + /$1\[- \]?/gx; # And add an optional blank or + # '-' after each $1 char + + # Those remaining hyphens were originally at the beginning or end of + # a word, so they can match either a blank before or after, but not + # both. (Keep in mind that they have been quoted, so are a '\-' + # sequence) + $lookup_name =~ s/\\ -/(?:- | -)/xg; + } + + # Do the lookup in the full table if asked for, and if succeeds + # save the offsets and set where to cache the result. + if (($loose || $^H{charnames_full}) && $txt =~ /\t$lookup_name$/m) { + @off = ($-[0] + 1, $+[0]); # The 1 is for the tab + $cache_ref = ($loose) ? \%loose_names_cache : \%full_names_cache; + } + else { + + # Here, didn't look for, or didn't find the name. + # If :short is allowed, see if input is like "greek:Sigma". + # Keep in mind that $lookup_name has had the metas quoted. + my $scripts_trie = ""; + my $name_has_uppercase; + if (($^H{charnames_short}) + && $lookup_name =~ /^ (?: \\ \s)* # Quoted space + (.+?) # $1 = the script + (?: \\ \s)* + \\ : # Quoted colon + (?: \\ \s)* + (.+?) # $2 = the name + (?: \\ \s)* $ + /xs) + { + # Even in non-loose matching, the script traditionally has been + # case insensitive + $scripts_trie = "\U$1"; + $lookup_name = $2; + + # Use original name to find its input casing, but ignore the + # script part of that to make the determination. + $save_input = $name if ! defined $save_input; + $name =~ s/.*?://; + $name_has_uppercase = $name =~ /[[:upper:]]/; + } + else { # Otherwise look in allowed scripts + $scripts_trie = $^H{charnames_scripts}; + + # Use original name to find its input casing + $name_has_uppercase = $name =~ /[[:upper:]]/; + } + + my $case = $name_has_uppercase ? "CAPITAL" : "SMALL"; + return if (! $scripts_trie || $txt !~ + /\t (?: $scripts_trie ) \ (?:$case\ )? LETTER \ \U$lookup_name $/xm); + + # Here have found the input name in the table. + @off = ($-[0] + 1, $+[0]); # The 1 is for the tab + } + + # Here, the input name has been found; we haven't set up the output, + # but we know where in the string + # the name starts. The string is set up so that for single characters + # (and not named sequences), the name is preceded immediately by a + # tab and 5 hex digits for its code, with a \n before those. Named + # sequences won't have the 7th preceding character be a \n. + # (Actually, for the very first entry in the table this isn't strictly + # true: subtracting 7 will yield -1, and the substr below will + # therefore yield the very last character in the table, which should + # also be a \n, so the statement works anyway.) + if (substr($txt, $off[0] - 7, 1) eq "\n") { + $result = chr CORE::hex substr($txt, $off[0] - 6, 5); + + # Handle the single loose matching special case, in which two names + # differ only by a single medial hyphen. If the original had a + # hyphen (or more) in the right place, then it is that one. + $result = $HANGUL_JUNGSEONG_O_E_utf8 + if $loose + && $result eq $HANGUL_JUNGSEONG_OE_utf8 + && $name =~ m/O \s* - [-\s]* E/ix; + # Note that this wouldn't work if there were a 2nd + # OE in the name + } + else { + + # Here, is a named sequence. Need to go looking for the beginning, + # which is just after the \n from the previous entry in the table. + # The +1 skips past that newline, or, if the rindex() fails, to put + # us to an offset of zero. + my $charstart = rindex($txt, "\n", $off[0] - 7) + 1; + $result = pack("W*", map { CORE::hex } + split " ", substr($txt, $charstart, $off[0] - $charstart - 1)); + } + } + + # Cache the input so as to not have to search the large table + # again, but only if it came from the one search that we cache. + # (Haven't bothered with the pain of sorting out scoping issues for the + # scripts searches.) + $cache_ref->{$name} = $result if defined $cache_ref; + } + } + + # Here, have the result character. If the return is to be an ord, must be + # any single character. + if ($wants_ord) { + return ord($result) if length $result == 1; + } + elsif (! utf8::is_utf8($result)) { + + # Here isn't UTF-8. That's OK if it is all ASCII, or we are being called + # at compile time where we know we can guarantee that Unicode rules are + # correctly imposed on the result, or under 'bytes' where we don't want + # those rules. But otherwise we have to make it UTF8 to guarantee Unicode + # rules on the returned string. + return $result if ! $runtime + || (caller $runtime)[8] & $bytes::hint_bits + || $result !~ /[[:^ascii:]]/; + utf8::upgrade($result); + return $result; + } + else { + + # Here, wants string output. If utf8 is acceptable, just return what + # we've got; otherwise attempt to convert it to non-utf8 and return that. + my $in_bytes = ($runtime) + ? (caller $runtime)[8] & $bytes::hint_bits + : $^H & $bytes::hint_bits; + return $result if (! $in_bytes || utf8::downgrade($result, 1)) # The 1 arg + # means don't die on failure + } + + # Here, there is an error: either there are too many characters, or the + # result string needs to be non-utf8, and at least one character requires + # utf8. Prefer any official name over the input one for the error message. + if (@off) { + $name = substr($txt, $off[0], $off[1] - $off[0]) if @off; + } + else { + $name = (defined $save_input) ? $save_input : $_[0]; + } + + if ($wants_ord) { + # Only way to get here in this case is if result too long. Message + # assumes that our only caller that requires single char result is + # vianame. + carp "charnames::vianame() doesn't handle named sequences ($name). Use charnames::string_vianame() instead"; + return; + } + + # Only other possible failure here is from use bytes. + if ($runtime) { + carp not_legal_use_bytes_msg($name, $result); + return; + } else { + croak not_legal_use_bytes_msg($name, $result); + } + +} # lookup_name + +sub charnames { + + # For \N{...}. Looks up the character name and returns the string + # representation of it. + + # The first 0 arg means wants a string returned; the second that we are in + # compile time + return lookup_name($_[0], 0, 0); +} + +sub import +{ + shift; ## ignore class name + + if (not @_) { + carp("'use charnames' needs explicit imports list"); + } + $^H{charnames} = \&charnames ; + $^H{charnames_ord_aliases} = {}; + $^H{charnames_name_aliases} = {}; + $^H{charnames_inverse_ords} = {}; + # New fields must be added to %dummy_H, and the code in lookup_name() + # that copies fields from the runtime structure + + ## + ## fill %h keys with our @_ args. + ## + my ($promote, %h, @args) = (0); + while (my $arg = shift) { + if ($arg eq ":alias") { + @_ or + croak ":alias needs an argument in charnames"; + my $alias = shift; + if (ref $alias) { + ref $alias eq "HASH" or + croak "Only HASH reference supported as argument to :alias"; + alias ($alias); + $promote = 1; + next; + } + if ($alias =~ m{:(\w+)$}) { + $1 eq "full" || $1 eq "loose" || $1 eq "short" and + croak ":alias cannot use existing pragma :$1 (reversed order?)"; + alias_file ($1) and $promote = 1; + next; + } + alias_file ($alias) and $promote = 1; + next; + } + if (substr($arg, 0, 1) eq ':' + and ! ($arg eq ":full" || $arg eq ":short" || $arg eq ":loose")) + { + warn "unsupported special '$arg' in charnames"; + next; + } + push @args, $arg; + } + + @args == 0 && $promote and @args = (":full"); + @h{@args} = (1) x @args; + + # Don't leave these undefined as are tested for in lookup_names + $^H{charnames_full} = delete $h{':full'} || 0; + $^H{charnames_loose} = delete $h{':loose'} || 0; + $^H{charnames_short} = delete $h{':short'} || 0; + my @scripts = map { uc quotemeta } keys %h; + + ## + ## If utf8? warnings are enabled, and some scripts were given, + ## see if at least we can find one letter from each script. + ## + if (warnings::enabled('utf8') && @scripts) { + $txt = do "unicore/Name.pl" unless $txt; + + for my $script (@scripts) { + if (not $txt =~ m/\t$script (?:CAPITAL |SMALL )?LETTER /) { + warnings::warn('utf8', "No such script: '$script'"); + $script = quotemeta $script; # Escape it, for use in the re. + } + } + } + + # %^H gets stringified, so serialize it ourselves so can extract the + # real data back later. + $^H{charnames_stringified_ords} = join ",", %{$^H{charnames_ord_aliases}}; + $^H{charnames_stringified_names} = join ",", %{$^H{charnames_name_aliases}}; + $^H{charnames_stringified_inverse_ords} = join ",", %{$^H{charnames_inverse_ords}}; + + # Modify the input script names for loose name matching if that is also + # specified, similar to the way the base character name is prepared. They + # don't (currently, and hopefully never will) have dashes. These go into a + # regex, and have already been uppercased and quotemeta'd. Squeeze out all + # input underscores, blanks, and dashes. Then convert so will match a blank + # between any characters. + if ($^H{charnames_loose}) { + for (my $i = 0; $i < @scripts; $i++) { + $scripts[$i] =~ s/[_ -]//g; + $scripts[$i] =~ s/ ( [^\\] ) (?= . ) /$1\\ ?/gx; + } + } + + $^H{charnames_scripts} = join "|", @scripts; # Stringifiy them as a trie +} # import + +# Cache of already looked-up values. This is set to only contain +# official values, and user aliases can't override them, so scoping is +# not an issue. +my %viacode; + +my $no_name_code_points_re = join "|", map { sprintf("%05X", + utf8::unicode_to_native($_)) } + 0x80, 0x81, 0x84, 0x99; +$no_name_code_points_re = qr/$no_name_code_points_re/; + +sub viacode { + + # Returns the name of the code point argument + + if (@_ != 1) { + carp "charnames::viacode() expects one argument"; + return; + } + + my $arg = shift; + + # This is derived from Unicode::UCD, where it is nearly the same as the + # function _getcode(), but here it makes sure that even a hex argument + # has the proper number of leading zeros, which is critical in + # matching against $txt below + # Must check if decimal first; see comments at that definition + my $hex; + if ($arg =~ $decimal_qr) { + $hex = sprintf "%05X", $arg; + } elsif ($arg =~ $hex_qr) { + $hex = CORE::hex $1; + $hex = utf8::unicode_to_native($hex) if $arg =~ /^[Uu]\+/; + # Below is the line that differs from the _getcode() source + $hex = sprintf "%05X", $hex; + } else { + carp("unexpected arg \"$arg\" to charnames::viacode()"); + return; + } + + return $viacode{$hex} if exists $viacode{$hex}; + + my $return; + + # If the code point is above the max in the table, there's no point + # looking through it. Checking the length first is slightly faster + if (length($hex) <= 5 || CORE::hex($hex) <= 0x10FFFF) { + $txt = do "unicore/Name.pl" unless $txt; + + # See if the name is algorithmically determinable. + my $algorithmic = charnames::code_point_to_name_special(CORE::hex $hex); + if (defined $algorithmic) { + $viacode{$hex} = $algorithmic; + return $algorithmic; + } + + # Return the official name, if exists. It's unclear to me (khw) at + # this juncture if it is better to return a user-defined override, so + # leaving it as is for now. + if ($txt =~ m/^$hex\t/m) { + + # The name starts with the next character and goes up to the + # next new-line. Using capturing parentheses above instead of + # @+ more than doubles the execution time in Perl 5.13 + $return = substr($txt, $+[0], index($txt, "\n", $+[0]) - $+[0]); + + # If not one of these 4 code points, return what we've found. + if ($hex !~ / ^ $no_name_code_points_re $ /x) { + $viacode{$hex} = $return; + return $return; + } + + # For backwards compatibility, we don't return the official name of + # the 4 code points if there are user-defined aliases for them -- so + # continue looking. + } + } + + # See if there is a user name for it, before giving up completely. + # First get the scoped aliases, give up if have none. + my $H_ref = (caller(1))[10]; + return if ! defined $return + && (! defined $H_ref + || ! exists $H_ref->{charnames_stringified_inverse_ords}); + + my %code_point_aliases; + if (defined $H_ref->{charnames_stringified_inverse_ords}) { + %code_point_aliases = split ',', + $H_ref->{charnames_stringified_inverse_ords}; + return $code_point_aliases{$hex} if exists $code_point_aliases{$hex}; + } + + # Here there is no user-defined alias, return any official one. + return $return if defined $return; + + if (CORE::hex($hex) > 0x10FFFF + && warnings::enabled('non_unicode')) + { + carp "Unicode characters only allocated up to U+10FFFF (you asked for U+$hex)"; + } + return; + +} # viacode + +1; + +# ex: set ts=8 sts=2 sw=2 et: +package open; +use warnings; + +our $VERSION = '1.11'; + +require 5.008001; # for PerlIO::get_layers() + +my $locale_encoding; + +sub _get_encname { + return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; + return; +} + +sub croak { + require Carp; goto &Carp::croak; +} + +sub _drop_oldenc { + # If by the time we arrive here there already is at the top of the + # perlio layer stack an encoding identical to what we would like + # to push via this open pragma, we will pop away the old encoding + # (+utf8) so that we can push ourselves in place (this is easier + # than ignoring pushing ourselves because of the way how ${^OPEN} + # works). So we are looking for something like + # + # stdio encoding(xxx) utf8 + # + # in the existing layer stack, and in the new stack chunk for + # + # :encoding(xxx) + # + # If we find a match, we pop the old stack (once, since + # the utf8 is just a flag on the encoding layer) + my ($h, @new) = @_; + return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; + my @old = PerlIO::get_layers($h); + return unless @old >= 3 && + $old[-1] eq 'utf8' && + $old[-2] =~ /^encoding\(.+\)$/; + require Encode; + my ($loname, $lcname) = _get_encname($old[-2]); + unless (defined $lcname) { # Should we trust get_layers()? + croak("open: Unknown encoding '$loname'"); + } + my ($voname, $vcname) = _get_encname($new[-1]); + unless (defined $vcname) { + croak("open: Unknown encoding '$voname'"); + } + if ($lcname eq $vcname) { + binmode($h, ":pop"); # utf8 is part of the encoding layer + } +} + +sub import { + my ($class,@args) = @_; + croak("open: needs explicit list of PerlIO layers") unless @args; + my $std; + my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); + while (@args) { + my $type = shift(@args); + my $dscp; + if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { + $type = 'IO'; + $dscp = ":$1"; + } elsif ($type eq ':std') { + $std = 1; + next; + } else { + $dscp = shift(@args) || ''; + } + my @val; + foreach my $layer (split(/\s+/,$dscp)) { + $layer =~ s/^://; + if ($layer eq 'locale') { + require Encode; + require encoding; + $locale_encoding = encoding::_get_locale_encoding() + unless defined $locale_encoding; + (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) + unless defined $locale_encoding; + $layer = "encoding($locale_encoding)"; + $std = 1; + } else { + my $target = $layer; # the layer name itself + $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters + + unless(PerlIO::Layer::->find($target,1)) { + warnings::warnif("layer", "Unknown PerlIO layer '$target'"); + } + } + push(@val,":$layer"); + if ($layer =~ /^(crlf|raw)$/) { + $^H{"open_$type"} = $layer; + } + } + if ($type eq 'IN') { + _drop_oldenc(*STDIN, @val) if $std; + $in = join(' ', @val); + } + elsif ($type eq 'OUT') { + if ($std) { + _drop_oldenc(*STDOUT, @val); + _drop_oldenc(*STDERR, @val); + } + $out = join(' ', @val); + } + elsif ($type eq 'IO') { + if ($std) { + _drop_oldenc(*STDIN, @val); + _drop_oldenc(*STDOUT, @val); + _drop_oldenc(*STDERR, @val); + } + $in = $out = join(' ', @val); + } + else { + croak "Unknown PerlIO layer class '$type' (need IN, OUT or IO)"; + } + } + ${^OPEN} = join("\0", $in, $out); + if ($std) { + if ($in) { + if ($in =~ /:utf8\b/) { + binmode(STDIN, ":utf8"); + } elsif ($in =~ /(\w+\(.+\))/) { + binmode(STDIN, ":$1"); + } + } + if ($out) { + if ($out =~ /:utf8\b/) { + binmode(STDOUT, ":utf8"); + binmode(STDERR, ":utf8"); + } elsif ($out =~ /(\w+\(.+\))/) { + binmode(STDOUT, ":$1"); + binmode(STDERR, ":$1"); + } + } + } +} + +1; +__END__ + +package UNIVERSAL; + +our $VERSION = '1.13'; + +# UNIVERSAL should not contain any extra subs/methods beyond those +# that it exists to define. The existence of import() below is a historical +# accident that can't be fixed without breaking code. + +# Make sure that even though the import method is called, it doesn't do +# anything unless called on UNIVERSAL. +sub import { + return unless $_[0] eq __PACKAGE__; + return unless @_ > 1; + require Carp; + Carp::croak("UNIVERSAL does not export anything"); +} + +1; +__END__ + + + +package DB; + +use strict; + +use Cwd (); + +my $_initial_cwd; + +BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl + +BEGIN { + require feature; + $^V =~ /^v(\d+\.\d+)/; + feature->import(":$1"); + $_initial_cwd = Cwd::getcwd(); +} + +# Debugger for Perl 5.00x; perl5db.pl patch level: +use vars qw($VERSION $header); + +# bump to X.XX in blead, only use X.XX_XX in maint +$VERSION = '1.53'; + +$header = "perl5db.pl version $VERSION"; + + +############################################## Begin lexical danger zone + +# 'my' variables used here could leak into (that is, be visible in) +# the context that the code being evaluated is executing in. This means that +# the code could modify the debugger's variables. +# +# Fiddling with the debugger's context could be Bad. We insulate things as +# much as we can. + +use vars qw( + @args + %break_on_load + $CommandSet + $CreateTTY + $DBGR + @dbline + $dbline + %dbline + $dieLevel + $filename + $histfile + $histsize + $IN + $inhibit_exit + @ini_INC + $ini_warn + $maxtrace + $od + @options + $osingle + $otrace + $pager + $post + %postponed + $prc + $pre + $pretype + $psh + @RememberOnROptions + $remoteport + @res + $rl + @saved + $signalLevel + $sub + $term + $usercontext + $warnLevel +); + +our ( + @cmdfhs, + $evalarg, + $frame, + $hist, + $ImmediateStop, + $line, + $onetimeDump, + $onetimedumpDepth, + %option, + $OUT, + $packname, + $signal, + $single, + $start, + %sub, + $subname, + $trace, + $window, +); + +# Used to save @ARGV and extract any debugger-related flags. +use vars qw(@ARGS); + +# Used to prevent multiple entries to diesignal() +# (if for instance diesignal() itself dies) +use vars qw($panic); + +# Used to prevent the debugger from running nonstop +# after a restart +our ($second_time); + +sub _calc_usercontext { + my ($package) = @_; + + # Cancel strict completely for the evaluated code, so the code + # the user evaluates won't be affected by it. (Shlomi Fish) + return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;' + . "package $package;"; # this won't let them modify, alas +} + +sub eval { + + # 'my' would make it visible from user code + # but so does local! --tchrist + # Remember: this localizes @DB::res, not @main::res. + local @res; + { + + # Try to keep the user code from messing with us. Save these so that + # even if the eval'ed code changes them, we can put them back again. + # Needed because the user could refer directly to the debugger's + # package globals (and any 'my' variables in this containing scope) + # inside the eval(), and we want to try to stay safe. + local $otrace = $trace; + local $osingle = $single; + local $od = $^D; + + # Untaint the incoming eval() argument. + { ($evalarg) = $evalarg =~ /(.*)/s; } + + # $usercontext built in DB::DB near the comment + # "set up the context for DB::eval ..." + # Evaluate and save any results. + @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug + + # Restore those old values. + $trace = $otrace; + $single = $osingle; + $^D = $od; + } + + # Save the current value of $@, and preserve it in the debugger's copy + # of the saved precious globals. + my $at = $@; + + # Since we're only saving $@, we only have to localize the array element + # that it will be stored in. + local $saved[0]; # Preserve the old value of $@ + eval { &DB::save }; + + # Now see whether we need to report an error back to the user. + if ($at) { + local $\ = ''; + print $OUT $at; + } + + # Display as required by the caller. $onetimeDump and $onetimedumpDepth + # are package globals. + elsif ($onetimeDump) { + if ( $onetimeDump eq 'dump' ) { + local $option{dumpDepth} = $onetimedumpDepth + if defined $onetimedumpDepth; + dumpit( $OUT, \@res ); + } + elsif ( $onetimeDump eq 'methods' ) { + methods( $res[0] ); + } + } ## end elsif ($onetimeDump) + @res; +} ## end sub eval + +############################################## End lexical danger zone + +# After this point it is safe to introduce lexicals. +# The code being debugged will be executing in its own context, and +# can't see the inside of the debugger. +# +# However, one should not overdo it: leave as much control from outside as +# possible. If you make something a lexical, it's not going to be addressable +# from outside the debugger even if you know its name. + +# This file is automatically included if you do perl -d. +# It's probably not useful to include this yourself. +# +# Before venturing further into these twisty passages, it is +# wise to read the perldebguts man page or risk the ire of dragons. +# +# (It should be noted that perldebguts will tell you a lot about +# the underlying mechanics of how the debugger interfaces into the +# Perl interpreter, but not a lot about the debugger itself. The new +# comments in this code try to address this problem.) + +# Note that no subroutine call is possible until &DB::sub is defined +# (for subroutines defined outside of the package DB). In fact the same is +# true if $deep is not defined. + +# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich) + +# modified Perl debugger, to be run from Emacs in perldb-mode +# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990 +# Johan Vromans -- upgrade to 4.0 pl 10 +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) +######################################################################## + + +# Needed for the statement after exec(): +# +# This BEGIN block is simply used to switch off warnings during debugger +# compilation. Probably it would be better practice to fix the warnings, +# but this is how it's done at the moment. + +BEGIN { + $ini_warn = $^W; + $^W = 0; +} # Switch compilation warnings off until another BEGIN. + +local ($^W) = 0; # Switch run-time warnings off during init. + + +BEGIN { + # ensure we can share our non-threaded variables or no-op + if ($ENV{PERL5DB_THREADED}) { + require threads; + require threads::shared; + import threads::shared qw(share); + $DBGR; + share(\$DBGR); + lock($DBGR); + print "Threads support enabled\n"; + } else { + *lock = sub(*) {}; + *share = sub(\[$@%]) {}; + } +} + +# These variables control the execution of 'dumpvar.pl'. +{ + package dumpvar; + use vars qw( + $hashDepth + $arrayDepth + $dumpDBFiles + $dumpPackages + $quoteHighBit + $printUndef + $globPrint + $usageOnly + ); +} + +# used to control die() reporting in diesignal() +{ + package Carp; + use vars qw($CarpLevel); +} + +# without threads, $filename is not defined until DB::DB is called +share($main::{'_<'.$filename}) if defined $filename; + +# Command-line + PERLLIB: +# Save the contents of @INC before they are modified elsewhere. +@ini_INC = @INC; + +# This was an attempt to clear out the previous values of various +# trapped errors. Apparently it didn't help. XXX More info needed! +# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?! + +# We set these variables to safe values. We don't want to blindly turn +# off warnings, because other packages may still want them. +$trace = $signal = $single = 0; # Uninitialized warning suppression + # (local $^W cannot help - other packages!). + +# Default to not exiting when program finishes; print the return +# value when the 'r' command is used to return from a subroutine. +$inhibit_exit = $option{PrintRet} = 1; + +use vars qw($trace_to_depth); + +# Default to 1E9 so it won't be limited to a certain recursion depth. +$trace_to_depth = 1E9; + + +@options = qw( + CommandSet HistFile HistSize + hashDepth arrayDepth dumpDepth + DumpDBFiles DumpPackages DumpReused + compactDump veryCompact quote + HighBit undefPrint globPrint + PrintRet UsageOnly frame + AutoTrace TTY noTTY + ReadLine NonStop LineInfo + maxTraceLen recallCommand ShellBang + pager tkRunning ornaments + signalLevel warnLevel dieLevel + inhibit_exit ImmediateStop bareStringify + CreateTTY RemotePort windowSize + DollarCaretP +); + +@RememberOnROptions = qw(DollarCaretP); + + +use vars qw(%optionVars); + +%optionVars = ( + hashDepth => \$dumpvar::hashDepth, + arrayDepth => \$dumpvar::arrayDepth, + CommandSet => \$CommandSet, + DumpDBFiles => \$dumpvar::dumpDBFiles, + DumpPackages => \$dumpvar::dumpPackages, + DumpReused => \$dumpvar::dumpReused, + HighBit => \$dumpvar::quoteHighBit, + undefPrint => \$dumpvar::printUndef, + globPrint => \$dumpvar::globPrint, + UsageOnly => \$dumpvar::usageOnly, + CreateTTY => \$CreateTTY, + bareStringify => \$dumpvar::bareStringify, + frame => \$frame, + AutoTrace => \$trace, + inhibit_exit => \$inhibit_exit, + maxTraceLen => \$maxtrace, + ImmediateStop => \$ImmediateStop, + RemotePort => \$remoteport, + windowSize => \$window, + HistFile => \$histfile, + HistSize => \$histsize, +); + + +use vars qw(%optionAction); + +%optionAction = ( + compactDump => \&dumpvar::compactDump, + veryCompact => \&dumpvar::veryCompact, + quote => \&dumpvar::quote, + TTY => \&TTY, + noTTY => \&noTTY, + ReadLine => \&ReadLine, + NonStop => \&NonStop, + LineInfo => \&LineInfo, + recallCommand => \&recallCommand, + ShellBang => \&shellBang, + pager => \&pager, + signalLevel => \&signalLevel, + warnLevel => \&warnLevel, + dieLevel => \&dieLevel, + tkRunning => \&tkRunning, + ornaments => \&ornaments, + RemotePort => \&RemotePort, + DollarCaretP => \&DollarCaretP, +); + + +# Note that this list is not complete: several options not listed here +# actually require that dumpvar.pl be loaded for them to work, but are +# not in the table. A subsequent patch will correct this problem; for +# the moment, we're just recommenting, and we are NOT going to change +# function. +use vars qw(%optionRequire); + +%optionRequire = ( + compactDump => 'dumpvar.pl', + veryCompact => 'dumpvar.pl', + quote => 'dumpvar.pl', +); + + +# These guys may be defined in $ENV{PERL5DB} : +$rl = 1 unless defined $rl; +$warnLevel = 1 unless defined $warnLevel; +$dieLevel = 1 unless defined $dieLevel; +$signalLevel = 1 unless defined $signalLevel; +$pre = [] unless defined $pre; +$post = [] unless defined $post; +$pretype = [] unless defined $pretype; +$CreateTTY = 3 unless defined $CreateTTY; +$CommandSet = '580' unless defined $CommandSet; + +share($rl); +share($warnLevel); +share($dieLevel); +share($signalLevel); +share($pre); +share($post); +share($pretype); +share($rl); +share($CreateTTY); +share($CommandSet); + + +warnLevel($warnLevel); +dieLevel($dieLevel); +signalLevel($signalLevel); + + +# This routine makes sure $pager is set up so that '|' can use it. +pager( + + # If PAGER is defined in the environment, use it. + defined $ENV{PAGER} + ? $ENV{PAGER} + + # If not, see if Config.pm defines it. + : eval { require Config } + && defined $Config::Config{pager} + ? $Config::Config{pager} + + # If not, fall back to 'more'. + : 'more' + ) + unless defined $pager; + + +setman(); + +# Set up defaults for command recall and shell escape (note: +# these currently don't work in linemode debugging). +recallCommand("!") unless defined $prc; +shellBang("!") unless defined $psh; + + +sethelp(); + +# If we didn't get a default for the length of eval/stack trace args, +# set it here. +$maxtrace = 400 unless defined $maxtrace; + + +# Save the current contents of the environment; we're about to +# much with it. We'll need this if we have to restart. +use vars qw($ini_pids); +$ini_pids = $ENV{PERLDB_PIDS}; + +use vars qw ($pids $term_pid); + +if ( defined $ENV{PERLDB_PIDS} ) { + + # We're a child. Make us a label out of the current PID structure + # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having + # a term yet so the parent will give us one later via resetterm(). + + my $env_pids = $ENV{PERLDB_PIDS}; + $pids = "[$env_pids]"; + + # Unless we are on OpenVMS, all programs under the DCL shell run under + # the same PID. + + if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) { + $term_pid = $$; + } + else { + $ENV{PERLDB_PIDS} .= "->$$"; + $term_pid = -1; + } + +} ## end if (defined $ENV{PERLDB_PIDS... +else { + + # We're the parent PID. Initialize PERLDB_PID in case we end up with a + # child debugger, and mark us as the parent, so we'll know to set up + # more TTY's is we have to. + $ENV{PERLDB_PIDS} = "$$"; + $pids = "[pid=$$]"; + $term_pid = $$; +} + +use vars qw($pidprompt); +$pidprompt = ''; + +# Sets up $emacs as a synonym for $slave_editor. +our ($slave_editor); +*emacs = $slave_editor if $slave_editor; # May be used in afterinit()... + + +# As noted, this test really doesn't check accurately that the debugger +# is running at a terminal or not. + +use vars qw($rcfile); +{ + my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty'); + # this is the wrong metric! + $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini"); +} + + +# This wraps a safety test around "do" to read and evaluate the init file. +# +# This isn't really safe, because there's a race +# between checking and opening. The solution is to +# open and fstat the handle, but then you have to read and +# eval the contents. But then the silly thing gets +# your lexical scope, which is unfortunate at best. +sub safe_do { + my $file = shift; + + # Just exactly what part of the word "CORE::" don't you understand? + local $SIG{__WARN__}; + local $SIG{__DIE__}; + + unless ( is_safe_file($file) ) { + CORE::warn < $b} keys(%pf); + my @enabled_statuses = get_list("PERLDB_FILE_ENABLED_$file_idx"); + for my $line_idx (0 .. $#lines) { + _set_breakpoint_enabled_status( + $filename, + $lines[$line_idx], + ($enabled_statuses[$line_idx] ? 1 : ''), + ); + } + } + + return; +} + +sub _restore_options_after_restart +{ + my %options_map = get_list("PERLDB_OPT"); + + while ( my ( $opt, $val ) = each %options_map ) { + $val =~ s/[\\\']/\\$1/g; + parse_options("$opt'$val'"); + } + + return; +} + +sub _restore_globals_after_restart +{ + # restore original @INC + @INC = get_list("PERLDB_INC"); + @ini_INC = @INC; + + # return pre/postprompt actions and typeahead buffer + $pretype = [ get_list("PERLDB_PRETYPE") ]; + $pre = [ get_list("PERLDB_PRE") ]; + $post = [ get_list("PERLDB_POST") ]; + @typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead ); + + return; +} + + +if ( exists $ENV{PERLDB_RESTART} ) { + + # We're restarting, so we don't need the flag that says to restart anymore. + delete $ENV{PERLDB_RESTART}; + + # $restart = 1; + _restore_shared_globals_after_restart(); + + _restore_breakpoints_and_actions(); + + # restore options + _restore_options_after_restart(); + + _restore_globals_after_restart(); +} ## end if (exists $ENV{PERLDB_RESTART... + + +use vars qw($notty $console $tty $LINEINFO); +use vars qw($lineinfo $doccmd); + +our ($runnonstop); + +# Local autoflush to avoid rt#116769, +# as calling IO::File methods causes an unresolvable loop +# that results in debugger failure. +sub _autoflush { + my $o = select($_[0]); + $|++; + select($o); +} + +if ($notty) { + $runnonstop = 1; + share($runnonstop); +} + + +else { + + # Is Perl being run from a slave editor or graphical debugger? + # If so, don't use readline, and set $slave_editor = 1. + if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) { + $rl = 0; + shift(@main::ARGV); + } + + #require Term::ReadLine; + + + if ( $^O eq 'cygwin' ) { + + # /dev/tty is binary. use stdin for textmode + undef $console; + } + + + elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) { + $console = "con"; + } + + + elsif ( $^O eq 'amigaos' ) { + $console = "CONSOLE:"; + } + + + elsif ($^O eq 'VMS') { + $console = 'sys$command'; + } + +# Keep this penultimate, on the grounds that it satisfies a wide variety of +# Unix-like systems that would otherwise need to be identified individually. + + + elsif ( -e "/dev/tty" ) { + $console = "/dev/tty"; + } + +# Keep this last. + + else { + _db_warn("Can't figure out your console, using stdin"); + undef $console; + } + + + if ( ( $^O eq 'MSWin32' ) and ( $slave_editor or defined $ENV{EMACS} ) ) { + + # /dev/tty is binary. use stdin for textmode + $console = undef; + } + + if ( $^O eq 'NetWare' ) { + + # /dev/tty is binary. use stdin for textmode + $console = undef; + } + + # In OS/2, we need to use STDIN to get textmode too, even though + # it pretty much looks like Unix otherwise. + if ( defined $ENV{OS2_SHELL} and ( $slave_editor or $ENV{WINDOWID} ) ) + { # In OS/2 + $console = undef; + } + + + $console = $tty if defined $tty; + + + # Handle socket stuff. + + if ( defined $remoteport ) { + + # If RemotePort was defined in the options, connect input and output + # to the socket. + $IN = $OUT = connect_remoteport(); + } ## end if (defined $remoteport) + + + # Non-socket. + else { + + # Two debuggers running (probably a system or a backtick that invokes + # the debugger itself under the running one). create a new IN and OUT + # filehandle, and do the necessary mojo to create a new tty if we + # know how, and we can. + create_IN_OUT(4) if $CreateTTY & 4; + if ($console) { + + # If we have a console, check to see if there are separate ins and + # outs to open. (They are assumed identical if not.) + + my ( $i, $o ) = split /,/, $console; + $o = $i unless defined $o; + + # read/write on in, or just read, or read on STDIN. + open( IN, '+<', $i ) + || open( IN, '<', $i ) + || open( IN, "<&STDIN" ); + + # read/write/create/clobber out, or write/create/clobber out, + # or merge with STDERR, or merge with STDOUT. + open( OUT, '+>', $o ) + || open( OUT, '>', $o ) + || open( OUT, ">&STDERR" ) + || open( OUT, ">&STDOUT" ); # so we don't dongle stdout + + } ## end if ($console) + elsif ( not defined $console ) { + + # No console. Open STDIN. + open( IN, "<&STDIN" ); + + # merge with STDERR, or with STDOUT. + open( OUT, ">&STDERR" ) + || open( OUT, ">&STDOUT" ); # so we don't dongle stdout + $console = 'STDIN/OUT'; + } ## end elsif (not defined $console) + + # Keep copies of the filehandles so that when the pager runs, it + # can close standard input without clobbering ours. + if ($console or (not defined($console))) { + $IN = \*IN; + $OUT = \*OUT; + } + } ## end elsif (from if(defined $remoteport)) + + # Unbuffer DB::OUT. We need to see responses right away. + _autoflush($OUT); + + # Line info goes to debugger output unless pointed elsewhere. + # Pointing elsewhere makes it possible for slave editors to + # keep track of file and position. We have both a filehandle + # and a I/O description to keep track of. + $LINEINFO = $OUT unless defined $LINEINFO; + $lineinfo = $console unless defined $lineinfo; + # share($LINEINFO); # <- unable to share globs + share($lineinfo); # + + + # Show the debugger greeting. + $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/; + unless ($runnonstop) { + local $\ = ''; + local $, = ''; + if ( $term_pid eq '-1' ) { + print $OUT "\nDaughter DB session started...\n"; + } + else { + print $OUT "\nLoading DB routines from $header\n"; + print $OUT ( + "Editor support ", + $slave_editor ? "enabled" : "available", ".\n" + ); + print $OUT +"\nEnter h or 'h h' for help, or '$doccmd perldebug' for more help.\n\n"; + } ## end else [ if ($term_pid eq '-1') + } ## end unless ($runnonstop) +} ## end else [ if ($notty) + +# XXX This looks like a bug to me. +# Why copy to @ARGS and then futz with @args? +@ARGS = @ARGV; +# for (@args) { + # Make sure backslashes before single quotes are stripped out, and + # keep args unless they are numeric (XXX why?) + # s/\'/\\\'/g; # removed while not justified understandably + # s/(.*)/'$1'/ unless /^-?[\d.]+$/; # ditto +# } + +# If there was an afterinit() sub defined, call it. It will get +# executed in our scope, so it can fiddle with debugger globals. +if ( defined &afterinit ) { # May be defined in $rcfile + afterinit(); +} + +# Inform us about "Stack dump during die enabled ..." in dieLevel(). +use vars qw($I_m_init); + +$I_m_init = 1; + +############################################################ Subroutines + + +# $cmd cannot be an our() variable unfortunately (possible perl bug?). + +use vars qw( + $action + $cmd + $file + $filename_ini + $finished + %had_breakpoints + $level + $max + $package + $try +); + +our ( + %alias, + $doret, + $end, + $fall_off_end, + $incr, + $laststep, + $rc, + $sh, + $stack_depth, + @stack, + @to_watch, + @old_watch, +); + +sub _DB__determine_if_we_should_break +{ + # if we have something here, see if we should break. + # $stop is lexical and local to this block - $action on the other hand + # is global. + my $stop; + + if ( $dbline{$line} + && _is_breakpoint_enabled($filename, $line) + && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) ) + { + + # Stop if the stop criterion says to just stop. + if ( $stop eq '1' ) { + $signal |= 1; + } + + # It's a conditional stop; eval it in the user's context and + # see if we should stop. If so, remove the one-time sigil. + elsif ($stop) { + $evalarg = "\$DB::signal |= 1 if do {$stop}"; + # The &-call is here to ascertain the mutability of @_. + &DB::eval; + # If the breakpoint is temporary, then delete its enabled status. + if ($dbline{$line} =~ s/;9($|\0)/$1/) { + _cancel_breakpoint_temp_enabled_status($filename, $line); + } + } + } ## end if ($dbline{$line} && ... +} + +sub _DB__is_finished { + if ($finished and $level <= 1) { + end_report(); + return 1; + } + else { + return; + } +} + +sub _DB__read_next_cmd +{ + my ($tid) = @_; + + # We have a terminal, or can get one ... + if (!$term) { + setterm(); + } + + # ... and it belongs to this PID or we get one for this PID ... + if ($term_pid != $$) { + resetterm(1); + } + + # ... and we got a line of command input ... + $cmd = DB::readline( + "$pidprompt $tid DB" + . ( '<' x $level ) + . ( $#hist + 1 ) + . ( '>' x $level ) . " " + ); + + return defined($cmd); +} + +sub _DB__trim_command_and_return_first_component { + my ($obj) = @_; + + $cmd =~ s/\A\s+//s; # trim annoying leading whitespace + $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace + + # A single-character debugger command can be immediately followed by its + # argument if they aren't both alphanumeric; otherwise require space + # between commands and arguments: + my ($verb, $args) = $cmd =~ m{\A(.\b|\S*)\s*(.*)}s; + + $obj->cmd_verb($verb); + $obj->cmd_args($args); + + return; +} + +sub _DB__handle_f_command { + my ($obj) = @_; + + if ($file = $obj->cmd_args) { + # help for no arguments (old-style was return from sub). + if ( !$file ) { + print $OUT + "The old f command is now the r command.\n"; # hint + print $OUT "The new f command switches filenames.\n"; + next CMD; + } ## end if (!$file) + + # if not in magic file list, try a close match. + if ( !defined $main::{ '_<' . $file } ) { + if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) { + { + $try = substr( $try, 2 ); + print $OUT "Choosing $try matching '$file':\n"; + $file = $try; + } + } ## end if (($try) = grep(m#^_<.*$file#... + } ## end if (!defined $main::{ ... + + # If not successfully switched now, we failed. + if ( !defined $main::{ '_<' . $file } ) { + print $OUT "No file matching '$file' is loaded.\n"; + next CMD; + } + + # We switched, so switch the debugger internals around. + elsif ( $file ne $filename ) { + *dbline = $main::{ '_<' . $file }; + $max = $#dbline; + $filename = $file; + $start = 1; + $cmd = "l"; + } ## end elsif ($file ne $filename) + + # We didn't switch; say we didn't. + else { + print $OUT "Already in $file.\n"; + next CMD; + } + } + + return; +} + +sub _DB__handle_dot_command { + my ($obj) = @_; + + # . command. + if ($obj->_is_full('.')) { + $incr = -1; # stay at current line + + # Reset everything to the old location. + $start = $line; + $filename = $filename_ini; + *dbline = $main::{ '_<' . $filename }; + $max = $#dbline; + + # Now where are we? + print_lineinfo($obj->position()); + next CMD; + } + + return; +} + +sub _DB__handle_y_command { + my ($obj) = @_; + + if (my ($match_level, $match_vars) + = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) { + + # See if we've got the necessary support. + if (!eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require PadWalker; PadWalker->VERSION(0.08) }) { + my $Err = $@; + _db_warn( + $Err =~ /locate/ + ? "PadWalker module not found - please install\n" + : $Err + ); + next CMD; + } + + # Load up dumpvar if we don't have it. If we can, that is. + do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; + defined &main::dumpvar + or print $OUT "dumpvar.pl not available.\n" + and next CMD; + + # Got all the modules we need. Find them and print them. + my @vars = split( ' ', $match_vars || '' ); + + # Find the pad. + my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) }; + + # Oops. Can't find it. + if (my $Err = $@) { + $Err =~ s/ at .*//; + _db_warn($Err); + next CMD; + } + + # Show the desired vars with dumplex(). + my $savout = select($OUT); + + # Have dumplex dump the lexicals. + foreach my $key (sort keys %$h) { + dumpvar::dumplex( $key, $h->{$key}, + defined $option{dumpDepth} ? $option{dumpDepth} : -1, + @vars ); + } + select($savout); + next CMD; + } +} + +sub _DB__handle_c_command { + my ($obj) = @_; + + my $i = $obj->cmd_args; + + if ($i =~ m#\A[\w:]*\z#) { + + # Hey, show's over. The debugged program finished + # executing already. + next CMD if _DB__is_finished(); + + # Capture the place to put a one-time break. + $subname = $i; + + # Probably not needed, since we finish an interactive + # sub-session anyway... + # local $filename = $filename; + # local *dbline = *dbline; # XXX Would this work?! + # + # The above question wonders if localizing the alias + # to the magic array works or not. Since it's commented + # out, we'll just leave that to speculation for now. + + # If the "subname" isn't all digits, we'll assume it + # is a subroutine name, and try to find it. + if ( $subname =~ /\D/ ) { # subroutine name + # Qualify it to the current package unless it's + # already qualified. + $subname = $package . "::" . $subname + unless $subname =~ /::/; + + # find_sub will return "file:line_number" corresponding + # to where the subroutine is defined; we call find_sub, + # break up the return value, and assign it in one + # operation. + ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); + + # Force the line number to be numeric. + $i = $i + 0; + + # If we got a line number, we found the sub. + if ($i) { + + # Switch all the debugger's internals around so + # we're actually working with that file. + $filename = $file; + *dbline = $main::{ '_<' . $filename }; + + # Mark that there's a breakpoint in this file. + $had_breakpoints{$filename} |= 1; + + # Scan forward to the first executable line + # after the 'sub whatever' line. + $max = $#dbline; + my $_line_num = $i; + while ($dbline[$_line_num] == 0 && $_line_num< $max) + { + $_line_num++; + } + $i = $_line_num; + } ## end if ($i) + + # We didn't find a sub by that name. + else { + print $OUT "Subroutine $subname not found.\n"; + next CMD; + } + } ## end if ($subname =~ /\D/) + + # At this point, either the subname was all digits (an + # absolute line-break request) or we've scanned through + # the code following the definition of the sub, looking + # for an executable, which we may or may not have found. + # + # If $i (which we set $subname from) is non-zero, we + # got a request to break at some line somewhere. On + # one hand, if there wasn't any real subroutine name + # involved, this will be a request to break in the current + # file at the specified line, so we have to check to make + # sure that the line specified really is breakable. + # + # On the other hand, if there was a subname supplied, the + # preceding block has moved us to the proper file and + # location within that file, and then scanned forward + # looking for the next executable line. We have to make + # sure that one was found. + # + # On the gripping hand, we can't do anything unless the + # current value of $i points to a valid breakable line. + # Check that. + if ($i) { + + # Breakable? + if ( $dbline[$i] == 0 ) { + print $OUT "Line $i not breakable.\n"; + next CMD; + } + + # Yes. Set up the one-time-break sigil. + $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. + _enable_breakpoint_temp_enabled_status($filename, $i); + } ## end if ($i) + + # Turn off stack tracing from here up. + for my $j (0 .. $stack_depth) { + $stack[ $j ] &= ~1; + } + last CMD; + } + + return; +} + +sub _DB__handle_forward_slash_command { + my ($obj) = @_; + + # The pattern as a string. + use vars qw($inpat); + + if (($inpat) = $cmd =~ m#\A/(.*)\z#) { + + # Remove the final slash. + $inpat =~ s:([^\\])/$:$1:; + + # If the pattern isn't null ... + if ( $inpat ne "" ) { + + # Turn off warn and die processing for a bit. + local $SIG{__DIE__}; + local $SIG{__WARN__}; + + # Create the pattern. + eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a"; + if ( $@ ne "" ) { + + # Oops. Bad pattern. No biscuit. + # Print the eval error and go back for more + # commands. + print {$OUT} "$@"; + next CMD; + } + $obj->pat($inpat); + } ## end if ($inpat ne "") + + # Set up to stop on wrap-around. + $end = $start; + + # Don't move off the current line. + $incr = -1; + + my $pat = $obj->pat; + + # Done in eval so nothing breaks if the pattern + # does something weird. + eval + { + no strict q/vars/; + for (;;) { + # Move ahead one line. + ++$start; + + # Wrap if we pass the last line. + if ($start > $max) { + $start = 1; + } + + # Stop if we have gotten back to this line again, + last if ($start == $end); + + # A hit! (Note, though, that we are doing + # case-insensitive matching. Maybe a qr// + # expression would be better, so the user could + # do case-sensitive matching if desired. + if ($dbline[$start] =~ m/$pat/i) { + if ($slave_editor) { + # Handle proper escaping in the slave. + print {$OUT} "\032\032$filename:$start:0\n"; + } + else { + # Just print the line normally. + print {$OUT} "$start:\t",$dbline[$start],"\n"; + } + # And quit since we found something. + last; + } + } + }; + + if ($@) { + warn $@; + } + + # If we wrapped, there never was a match. + if ( $start == $end ) { + print {$OUT} "/$pat/: not found\n"; + } + next CMD; + } + + return; +} + +sub _DB__handle_question_mark_command { + my ($obj) = @_; + + # ? - backward pattern search. + if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) { + + # Get the pattern, remove trailing question mark. + $inpat =~ s:([^\\])\?$:$1:; + + # If we've got one ... + if ( $inpat ne "" ) { + + # Turn off die & warn handlers. + local $SIG{__DIE__}; + local $SIG{__WARN__}; + eval '$inpat =~ m' . "\a$inpat\a"; + + if ( $@ ne "" ) { + + # Ouch. Not good. Print the error. + print $OUT $@; + next CMD; + } + $obj->pat($inpat); + } ## end if ($inpat ne "") + + # Where we are now is where to stop after wraparound. + $end = $start; + + # Don't move away from this line. + $incr = -1; + + my $pat = $obj->pat; + # Search inside the eval to prevent pattern badness + # from killing us. + eval { + no strict q/vars/; + for (;;) { + # Back up a line. + --$start; + + # Wrap if we pass the first line. + + $start = $max if ($start <= 0); + + # Quit if we get back where we started, + last if ($start == $end); + + # Match? + if ($dbline[$start] =~ m/$pat/i) { + if ($slave_editor) { + # Yep, follow slave editor requirements. + print $OUT "\032\032$filename:$start:0\n"; + } + else { + # Yep, just print normally. + print $OUT "$start:\t",$dbline[$start],"\n"; + } + + # Found, so done. + last; + } + } + }; + + # Say we failed if the loop never found anything, + if ( $start == $end ) { + print {$OUT} "?$pat?: not found\n"; + } + next CMD; + } + + return; +} + +sub _DB__handle_restart_and_rerun_commands { + my ($obj) = @_; + + my $cmd_cmd = $obj->cmd_verb; + my $cmd_params = $obj->cmd_args; + # R - restart execution. + # rerun - controlled restart execution. + if ($cmd_cmd eq 'rerun' or $cmd_params eq '') { + + # Change directory to the initial current working directory on + # the script startup, so if the debugged program changed the + # directory, then we will still be able to find the path to the + # the program. (perl 5 RT #121509 ). + chdir ($_initial_cwd); + + my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); + + # Close all non-system fds for a clean restart. A more + # correct method would be to close all fds that were not + # open when the process started, but this seems to be + # hard. See "debugger 'R'estart and open database + # connections" on p5p. + + my $max_fd = 1024; # default if POSIX can't be loaded + if (eval { require POSIX }) { + eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) }; + } + + if (defined $max_fd) { + foreach ($^F+1 .. $max_fd-1) { + next unless open FD_TO_CLOSE, "<&=$_"; + close(FD_TO_CLOSE); + } + } + + # And run Perl again. We use exec() to keep the + # PID stable (and that way $ini_pids is still valid). + exec(@args) or print {$OUT} "exec failed: $!\n"; + + last CMD; + } + + return; +} + +sub _DB__handle_run_command_in_pager_command { + my ($obj) = @_; + + if ($cmd =~ m#\A\|\|?\s*[^|]#) { + if ( $pager =~ /^\|/ ) { + + # Default pager is into a pipe. Redirect I/O. + open( SAVEOUT, ">&STDOUT" ) + || _db_warn("Can't save STDOUT"); + open( STDOUT, ">&OUT" ) + || _db_warn("Can't redirect STDOUT"); + } ## end if ($pager =~ /^\|/) + else { + + # Not into a pipe. STDOUT is safe. + open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT"); + } + + # Fix up environment to record we have less if so. + fix_less(); + + unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) { + + # Couldn't open pipe to pager. + _db_warn("Can't pipe output to '$pager'"); + if ( $pager =~ /^\|/ ) { + + # Redirect I/O back again. + open( OUT, ">&STDOUT" ) # XXX: lost message + || _db_warn("Can't restore DB::OUT"); + open( STDOUT, ">&SAVEOUT" ) + || _db_warn("Can't restore STDOUT"); + close(SAVEOUT); + } ## end if ($pager =~ /^\|/) + else { + + # Redirect I/O. STDOUT already safe. + open( OUT, ">&STDOUT" ) # XXX: lost message + || _db_warn("Can't restore DB::OUT"); + } + next CMD; + } ## end unless ($piped = open(OUT,... + + # Set up broken-pipe handler if necessary. + $SIG{PIPE} = \&DB::catch + if $pager =~ /^\|/ + && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); + + _autoflush(\*OUT); + # Save current filehandle, and put it back. + $obj->selected(scalar( select(OUT) )); + # Don't put it back if pager was a pipe. + if ($cmd !~ /\A\|\|/) + { + select($obj->selected()); + $obj->selected(""); + } + + # Trim off the pipe symbols and run the command now. + $cmd =~ s#\A\|+\s*##; + redo PIPE; + } + + return; +} + +sub _DB__handle_m_command { + my ($obj) = @_; + + if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) { + methods($1); + next CMD; + } + + # m expr - set up DB::eval to do the work + if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval() + $onetimeDump = 'methods'; # method output gets used there + } + + return; +} + +sub _DB__at_end_of_every_command { + my ($obj) = @_; + + # At the end of every command: + if ($obj->piped) { + + # Unhook the pipe mechanism now. + if ( $pager =~ /^\|/ ) { + + # No error from the child. + $? = 0; + + # we cannot warn here: the handle is missing --tchrist + close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; + + # most of the $? crud was coping with broken cshisms + # $? is explicitly set to 0, so this never runs. + if ($?) { + print SAVEOUT "Pager '$pager' failed: "; + if ( $? == -1 ) { + print SAVEOUT "shell returned -1\n"; + } + elsif ( $? >> 8 ) { + print SAVEOUT ( $? & 127 ) + ? " (SIG#" . ( $? & 127 ) . ")" + : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; + } + else { + print SAVEOUT "status ", ( $? >> 8 ), "\n"; + } + } ## end if ($?) + + # Reopen filehandle for our output (if we can) and + # restore STDOUT (if we can). + open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT"); + open( STDOUT, ">&SAVEOUT" ) + || _db_warn("Can't restore STDOUT"); + + # Turn off pipe exception handler if necessary. + $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; + + # Will stop ignoring SIGPIPE if done like nohup(1) + # does SIGINT but Perl doesn't give us a choice. + } ## end if ($pager =~ /^\|/) + else { + + # Non-piped "pager". Just restore STDOUT. + open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT"); + } + + # Let Readline know about the new filehandles. + reset_IN_OUT( \*IN, \*OUT ); + + # Close filehandle pager was using, restore the normal one + # if necessary, + close(SAVEOUT); + + if ($obj->selected() ne "") { + select($obj->selected); + $obj->selected(""); + } + + # No pipes now. + $obj->piped(""); + } ## end if ($piped) + + return; +} + +sub _DB__handle_watch_expressions +{ + my $self = shift; + + if ( $DB::trace & 2 ) { + for my $n (0 .. $#DB::to_watch) { + $DB::evalarg = $DB::to_watch[$n]; + local $DB::onetimeDump; # Tell DB::eval() to not output results + + # Fix context DB::eval() wants to return an array, but + # we need a scalar here. + my ($val) = join( "', '", DB::eval(@_) ); + $val = ( ( defined $val ) ? "'$val'" : 'undef' ); + + # Did it change? + if ( $val ne $DB::old_watch[$n] ) { + + # Yep! Show the difference, and fake an interrupt. + $DB::signal = 1; + print {$DB::OUT} < { t => 'm', v => '_handle_dash_command', }, + '.' => { t => 's', v => \&_DB__handle_dot_command, }, + '=' => { t => 'm', v => '_handle_equal_sign_command', }, + 'H' => { t => 'm', v => '_handle_H_command', }, + 'S' => { t => 'm', v => '_handle_S_command', }, + 'T' => { t => 'm', v => '_handle_T_command', }, + 'W' => { t => 'm', v => '_handle_W_command', }, + 'c' => { t => 's', v => \&_DB__handle_c_command, }, + 'f' => { t => 's', v => \&_DB__handle_f_command, }, + 'm' => { t => 's', v => \&_DB__handle_m_command, }, + 'n' => { t => 'm', v => '_handle_n_command', }, + 'p' => { t => 'm', v => '_handle_p_command', }, + 'q' => { t => 'm', v => '_handle_q_command', }, + 'r' => { t => 'm', v => '_handle_r_command', }, + 's' => { t => 'm', v => '_handle_s_command', }, + 'save' => { t => 'm', v => '_handle_save_command', }, + 'source' => { t => 'm', v => '_handle_source_command', }, + 't' => { t => 'm', v => '_handle_t_command', }, + 'w' => { t => 'm', v => '_handle_w_command', }, + 'x' => { t => 'm', v => '_handle_x_command', }, + 'y' => { t => 's', v => \&_DB__handle_y_command, }, + (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, } + ('X', 'V')), + (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, } + qw(enable disable)), + (map { $_ => + { t => 's', v => \&_DB__handle_restart_and_rerun_commands, }, + } qw(R rerun)), + (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, } + qw(a A b B e E h i l L M o O v w W)), +); +}; + +sub DB { + + # lock the debugger and get the thread id for the prompt + lock($DBGR); + my $tid; + my $position; + my ($prefix, $after, $infix); + my $pat; + my $explicit_stop; + my $piped; + my $selected; + + if ($ENV{PERL5DB_THREADED}) { + $tid = eval { "[".threads->tid."]" }; + } + + my $cmd_verb; + my $cmd_args; + + my $obj = DB::Obj->new( + { + position => \$position, + prefix => \$prefix, + after => \$after, + explicit_stop => \$explicit_stop, + infix => \$infix, + cmd_args => \$cmd_args, + cmd_verb => \$cmd_verb, + pat => \$pat, + piped => \$piped, + selected => \$selected, + }, + ); + + $obj->_DB_on_init__initialize_globals(@_); + + # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. + # The code being debugged may have altered them. + DB::save(); + + # Since DB::DB gets called after every line, we can use caller() to + # figure out where we last were executing. Sneaky, eh? This works because + # caller is returning all the extra information when called from the + # debugger. + local ( $package, $filename, $line ) = caller; + $filename_ini = $filename; + + # set up the context for DB::eval, so it can properly execute + # code on behalf of the user. We add the package in so that the + # code is eval'ed in the proper package (not in the debugger!). + local $usercontext = _calc_usercontext($package); + + # Create an alias to the active file magical array to simplify + # the code here. + local (*dbline) = $main::{ '_<' . $filename }; + + # Last line in the program. + $max = $#dbline; + + # The &-call is here to ascertain the mutability of @_. + &_DB__determine_if_we_should_break; + + # Preserve the current stop-or-not, and see if any of the W + # (watch expressions) has changed. + my $was_signal = $signal; + + # If we have any watch expressions ... + _DB__handle_watch_expressions($obj); + + + # If there's a user-defined DB::watchfunction, call it with the + # current package, filename, and line. The function executes in + # the DB:: package. + if ( $trace & 4 ) { # User-installed watch + return + if watchfunction( $package, $filename, $line ) + and not $single + and not $was_signal + and not( $trace & ~4 ); + } ## end if ($trace & 4) + + # Pick up any alteration to $signal in the watchfunction, and + # turn off the signal now. + $was_signal = $signal; + $signal = 0; + + + # Make sure that we always print if asked for explicitly regardless + # of $trace_to_depth . + $explicit_stop = ($single || $was_signal); + + # Check to see if we should grab control ($single true, + # trace set appropriately, or we got a signal). + if ( $explicit_stop || ( $trace & 1 ) ) { + $obj->_DB__grab_control(@_); + } ## end if ($single || ($trace... + + + # If there's an action, do it now. + if ($action) { + $evalarg = $action; + # The &-call is here to ascertain the mutability of @_. + &DB::eval; + } + + # Are we nested another level (e.g., did we evaluate a function + # that had a breakpoint in it at the debugger prompt)? + if ( $single || $was_signal ) { + + # Yes, go down a level. + local $level = $level + 1; + + # Do any pre-prompt actions. + foreach $evalarg (@$pre) { + # The &-call is here to ascertain the mutability of @_. + &DB::eval; + } + + # Complain about too much recursion if we passed the limit. + if ($single & 4) { + print $OUT $stack_depth . " levels deep in subroutine calls!\n"; + } + + # The line we're currently on. Set $incr to -1 to stay here + # until we get a command that tells us to advance. + $start = $line; + $incr = -1; # for backward motion. + + # Tack preprompt debugger actions ahead of any actual input. + @typeahead = ( @$pretype, @typeahead ); + + + # The big command dispatch loop. It keeps running until the + # user yields up control again. + # + # If we have a terminal for input, and we get something back + # from readline(), keep on processing. + + CMD: + while (_DB__read_next_cmd($tid)) + { + + share($cmd); + # ... try to execute the input as debugger commands. + + # Don't stop running. + $single = 0; + + # No signal is active. + $signal = 0; + + # Handle continued commands (ending with \): + if ($cmd =~ s/\\\z/\n/) { + $cmd .= DB::readline(" cont: "); + redo CMD; + } + + + # Empty input means repeat the last command. + if ($cmd eq '') { + $cmd = $laststep; + } + chomp($cmd); # get rid of the annoying extra newline + if (length($cmd) >= 2) { + push( @hist, $cmd ); + } + push( @truehist, $cmd ); + share(@hist); + share(@truehist); + + # This is a restart point for commands that didn't arrive + # via direct user input. It allows us to 'redo PIPE' to + # re-execute command processing without reading a new command. + PIPE: { + _DB__trim_command_and_return_first_component($obj); + + + # See if there's an alias for the command, and set it up if so. + if ( $alias{$cmd_verb} ) { + + # Squelch signal handling; we want to keep control here + # if something goes loco during the alias eval. + local $SIG{__DIE__}; + local $SIG{__WARN__}; + + # This is a command, so we eval it in the DEBUGGER's + # scope! Otherwise, we can't see the special debugger + # variables, or get to the debugger's subs. (Well, we + # _could_, but why make it even more complicated?) + eval "\$cmd =~ $alias{$cmd_verb}"; + if ($@) { + local $\ = ''; + print $OUT "Couldn't evaluate '$cmd_verb' alias: $@"; + next CMD; + } + _DB__trim_command_and_return_first_component($obj); + } ## end if ($alias{$cmd_verb}) + + + # All of these commands were remapped in perl 5.8.0; + # we send them off to the secondary dispatcher (see below). + $obj->_handle_special_char_cmd_wrapper_commands; + _DB__trim_command_and_return_first_component($obj); + + if (my $cmd_rec = $cmd_lookup{$cmd_verb}) { + my $type = $cmd_rec->{t}; + my $val = $cmd_rec->{v}; + if ($type eq 'm') { + $obj->$val(); + } + elsif ($type eq 's') { + $val->($obj); + } + } + + + _DB__handle_forward_slash_command($obj); + + + _DB__handle_question_mark_command($obj); + + + # $rc - recall command. + $obj->_handle_rc_recall_command; + + + $obj->_handle_sh_command; + + + $obj->_handle_rc_search_history_command; + + + + $obj->_handle_doc_command; + + + # || - run command in the pager, with output to DB::OUT. + _DB__handle_run_command_in_pager_command($obj); + + + } # PIPE: + + # trace an expression + $cmd =~ s/^t\s/\$DB::trace |= 1;\n/; + + # Make sure the flag that says "the debugger's running" is + # still on, to make sure we get control again. + $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; + + # Run *our* eval that executes in the caller's context. + # The &-call is here to ascertain the mutability of @_. + &DB::eval; + + # Turn off the one-time-dump stuff now. + if ($onetimeDump) { + $onetimeDump = undef; + $onetimedumpDepth = undef; + } + elsif ( $term_pid == $$ ) { + eval { # May run under miniperl, when not available... + STDOUT->flush(); + STDERR->flush(); + }; + + # XXX If this is the master pid, print a newline. + print {$OUT} "\n"; + } + } ## end while (($term || &setterm... + + + continue { # CMD: + _DB__at_end_of_every_command($obj); + } # CMD: + + + # No more commands? Quit. + $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF + + # Evaluate post-prompt commands. + foreach $evalarg (@$post) { + # The &-call is here to ascertain the mutability of @_. + &DB::eval; + } + } # if ($single || $signal) + + # Put the user's globals back where you found them. + ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved; + (); +} ## end sub DB + +# Because DB::Obj is used above, +# +# my $obj = DB::Obj->new( +# +# The following package declaration must come before that, +# or else runtime errors will occur with +# +# PERLDB_OPTS="autotrace nonstop" +# +# ( rt#116771 ) +BEGIN { + +package DB::Obj; + +sub new { + my $class = shift; + + my $self = bless {}, $class; + + $self->_init(@_); + + return $self; +} + +sub _init { + my ($self, $args) = @_; + + %{$self} = (%$self, %$args); + + return; +} + +{ + no strict 'refs'; + foreach my $slot_name (qw( + after explicit_stop infix pat piped position prefix selected cmd_verb + cmd_args + )) { + my $slot = $slot_name; + *{$slot} = sub { + my $self = shift; + + if (@_) { + ${ $self->{$slot} } = shift; + } + + return ${ $self->{$slot} }; + }; + + *{"append_to_$slot"} = sub { + my $self = shift; + my $s = shift; + + return $self->$slot($self->$slot . $s); + }; + } +} + +sub _DB_on_init__initialize_globals +{ + my $self = shift; + + # Check for whether we should be running continuously or not. + # _After_ the perl program is compiled, $single is set to 1: + if ( $single and not $second_time++ ) { + + # Options say run non-stop. Run until we get an interrupt. + if ($runnonstop) { # Disable until signal + # If there's any call stack in place, turn off single + # stepping into subs throughout the stack. + for my $i (0 .. $stack_depth) { + $stack[ $i ] &= ~1; + } + + # And we are now no longer in single-step mode. + $single = 0; + + # If we simply returned at this point, we wouldn't get + # the trace info. Fall on through. + # return; + } ## end if ($runnonstop) + + elsif ($ImmediateStop) { + + # We are supposed to stop here; XXX probably a break. + $ImmediateStop = 0; # We've processed it; turn it off + $signal = 1; # Simulate an interrupt to force + # us into the command loop + } + } ## end if ($single and not $second_time... + + # If we're in single-step mode, or an interrupt (real or fake) + # has occurred, turn off non-stop mode. + $runnonstop = 0 if $single or $signal; + + return; +} + +sub _my_print_lineinfo +{ + my ($self, $i, $incr_pos) = @_; + + if ($frame) { + # Print it indented if tracing is on. + DB::print_lineinfo( ' ' x $stack_depth, + "$i:\t$DB::dbline[$i]" . $self->after ); + } + else { + DB::depth_print_lineinfo($self->explicit_stop, $incr_pos); + } +} + +sub _curr_line { + return $DB::dbline[$line]; +} + +sub _is_full { + my ($self, $letter) = @_; + + return ($DB::cmd eq $letter); +} + +sub _DB__grab_control +{ + my $self = shift; + + # Yes, grab control. + if ($slave_editor) { + + # Tell the editor to update its position. + $self->position("\032\032${DB::filename}:$line:0\n"); + DB::print_lineinfo($self->position()); + } + + + elsif ( $DB::package eq 'DB::fake' ) { + + # Fallen off the end already. + if (!$DB::term) { + DB::setterm(); + } + + DB::print_help(< to quit or B to restart, +use B I to avoid stopping after program termination, +B, B or B to get additional info. +EOP + + # Set the DB::eval context appropriately. + # At program termination disable any user actions. + $DB::action = undef; + + $DB::package = 'main'; + $DB::usercontext = DB::_calc_usercontext($DB::package); + } ## end elsif ($package eq 'DB::fake') + + + else { + + + # Still somewhere in the midst of execution. Set up the + # debugger prompt. + $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to + # Perl 5 ones (sorry, we don't print Klingon + #module names) + + $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::')); + $self->append_to_prefix( "$DB::sub(${DB::filename}:" ); + $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" ); + + # Break up the prompt if it's really long. + if ( length($self->prefix()) > 30 ) { + $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after); + $self->prefix(""); + $self->infix(":\t"); + } + else { + $self->infix("):\t"); + $self->position( + $self->prefix . $line. $self->infix + . $self->_curr_line . $self->after + ); + } + + # Print current line info, indenting if necessary. + $self->_my_print_lineinfo($line, $self->position); + + my $i; + my $line_i = sub { return $DB::dbline[$i]; }; + + # Scan forward, stopping at either the end or the next + # unbreakable line. + for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i ) + { #{ vi + + # Drop out on null statements, block closers, and comments. + last if $line_i->() =~ /^\s*[\;\}\#\n]/; + + # Drop out if the user interrupted us. + last if $signal; + + # Append a newline if the line doesn't have one. Can happen + # in eval'ed text, for instance. + $self->after( $line_i->() =~ /\n$/ ? '' : "\n" ); + + # Next executable line. + my $incr_pos = $self->prefix . $i . $self->infix . $line_i->() + . $self->after; + $self->append_to_position($incr_pos); + $self->_my_print_lineinfo($i, $incr_pos); + } ## end for ($i = $line + 1 ; $i... + } ## end else [ if ($slave_editor) + + return; +} + +sub _handle_t_command { + my $self = shift; + + my $levels = $self->cmd_args(); + + if ((!length($levels)) or ($levels !~ /\D/)) { + $trace ^= 1; + local $\ = ''; + $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; + print {$OUT} "Trace = " + . ( ( $trace & 1 ) + ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" ) + : "off" ) . "\n"; + next CMD; + } + + return; +} + + +sub _handle_S_command { + my $self = shift; + + if (my ($print_all_subs, $should_reverse, $Spatt) + = $self->cmd_args =~ /\A((!)?(.+))?\z/) { + # $Spatt is the pattern (if any) to use. + # Reverse scan? + my $Srev = defined $should_reverse; + # No args - print all subs. + my $Snocheck = !defined $print_all_subs; + + # Need to make these sane here. + local $\ = ''; + local $, = ''; + + # Search through the debugger's magical hash of subs. + # If $nocheck is true, just print the sub name. + # Otherwise, check it against the pattern. We then use + # the XOR trick to reverse the condition as required. + foreach $subname ( sort( keys %sub ) ) { + if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) { + print $OUT $subname, "\n"; + } + } + next CMD; + } + + return; +} + +sub _handle_V_command_and_X_command { + my $self = shift; + + $DB::cmd =~ s/^X\b/V $DB::package/; + + # Bare V commands get the currently-being-debugged package + # added. + if ($self->_is_full('V')) { + $DB::cmd = "V $DB::package"; + } + + # V - show variables in package. + if (my ($new_packname, $new_vars_str) = + $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) { + + # Save the currently selected filehandle and + # force output to debugger's filehandle (dumpvar + # just does "print" for output). + my $savout = select($OUT); + + # Grab package name and variables to dump. + $packname = $new_packname; + my @vars = split( ' ', $new_vars_str ); + + # If main::dumpvar isn't here, get it. + do 'dumpvar.pl' || die $@ unless defined &main::dumpvar; + if ( defined &main::dumpvar ) { + + # We got it. Turn off subroutine entry/exit messages + # for the moment, along with return values. + local $frame = 0; + local $doret = -2; + + # must detect sigpipe failures - not catching + # then will cause the debugger to die. + eval { + main::dumpvar( + $packname, + defined $option{dumpDepth} + ? $option{dumpDepth} + : -1, # assume -1 unless specified + @vars + ); + }; + + # The die doesn't need to include the $@, because + # it will automatically get propagated for us. + if ($@) { + die unless $@ =~ /dumpvar print failed/; + } + } ## end if (defined &main::dumpvar) + else { + + # Couldn't load dumpvar. + print $OUT "dumpvar.pl not available.\n"; + } + + # Restore the output filehandle, and go round again. + select($savout); + next CMD; + } + + return; +} + +sub _handle_dash_command { + my $self = shift; + + if ($self->_is_full('-')) { + + # back up by a window; go to 1 if back too far. + $start -= $incr + $window + 1; + $start = 1 if $start <= 0; + $incr = $window - 1; + + # Generate and execute a "l +" command (handled below). + $DB::cmd = 'l ' . ($start) . '+'; + redo CMD; + } + return; +} + +sub _n_or_s_commands_generic { + my ($self, $new_val) = @_; + # n - next + next CMD if DB::_DB__is_finished(); + + # Single step, but don't enter subs. + $single = $new_val; + + # Save for empty command (repeat last). + $laststep = $DB::cmd; + last CMD; +} + +sub _n_or_s { + my ($self, $letter, $new_val) = @_; + + if ($self->_is_full($letter)) { + $self->_n_or_s_commands_generic($new_val); + } + else { + $self->_n_or_s_and_arg_commands_generic($letter, $new_val); + } + + return; +} + +sub _handle_n_command { + my $self = shift; + + return $self->_n_or_s('n', 2); +} + +sub _handle_s_command { + my $self = shift; + + return $self->_n_or_s('s', 1); +} + +sub _handle_r_command { + my $self = shift; + + # r - return from the current subroutine. + if ($self->_is_full('r')) { + + # Can't do anything if the program's over. + next CMD if DB::_DB__is_finished(); + + # Turn on stack trace. + $stack[$stack_depth] |= 1; + + # Print return value unless the stack is empty. + $doret = $option{PrintRet} ? $stack_depth - 1 : -2; + last CMD; + } + + return; +} + +sub _handle_T_command { + my $self = shift; + + if ($self->_is_full('T')) { + DB::print_trace( $OUT, 1 ); # skip DB + next CMD; + } + + return; +} + +sub _handle_w_command { + my $self = shift; + + DB::cmd_w( 'w', $self->cmd_args() ); + next CMD; + + return; +} + +sub _handle_W_command { + my $self = shift; + + if (my $arg = $self->cmd_args) { + DB::cmd_W( 'W', $arg ); + next CMD; + } + + return; +} + +sub _handle_rc_recall_command { + my $self = shift; + + # $rc - recall command. + if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) { + + # No arguments, take one thing off history. + pop(@hist) if length($DB::cmd) > 1; + + # Relative (- found)? + # Y - index back from most recent (by 1 if bare minus) + # N - go to that particular command slot or the last + # thing if nothing following. + + $self->cmd_verb( + scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist )) + ); + + # Pick out the command desired. + $DB::cmd = $hist[$self->cmd_verb]; + + # Print the command to be executed and restart the loop + # with that command in the buffer. + print {$OUT} $DB::cmd, "\n"; + redo CMD; + } + + return; +} + +sub _handle_rc_search_history_command { + my $self = shift; + + # $rc pattern $rc - find a command in the history. + if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) { + + # Create the pattern to use. + my $pat = "^$arg"; + $self->pat($pat); + + # Toss off last entry if length is >1 (and it always is). + pop(@hist) if length($DB::cmd) > 1; + + my $i; + + # Look backward through the history. + SEARCH_HIST: + for ( $i = $#hist ; $i ; --$i ) { + # Stop if we find it. + last SEARCH_HIST if $hist[$i] =~ /$pat/; + } + + if ( !$i ) { + + # Never found it. + print $OUT "No such command!\n\n"; + next CMD; + } + + # Found it. Put it in the buffer, print it, and process it. + $DB::cmd = $hist[$i]; + print $OUT $DB::cmd, "\n"; + redo CMD; + } + + return; +} + +sub _handle_H_command { + my $self = shift; + + if ($self->cmd_args =~ m#\A\*#) { + @hist = @truehist = (); + print $OUT "History cleansed\n"; + next CMD; + } + + if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) { + + # Anything other than negative numbers is ignored by + # the (incorrect) pattern, so this test does nothing. + $end = $num ? ( $#hist - $num ) : 0; + + # Set to the minimum if less than zero. + $hist = 0 if $hist < 0; + + # Start at the end of the array. + # Stay in while we're still above the ending value. + # Tick back by one each time around the loop. + my $i; + + for ( $i = $#hist ; $i > $end ; $i-- ) { + + # Print the command unless it has no arguments. + print $OUT "$i: ", $hist[$i], "\n" + unless $hist[$i] =~ /^.?$/; + } + + next CMD; + } + + return; +} + +sub _handle_doc_command { + my $self = shift; + + # man, perldoc, doc - show manual pages. + if (my ($man_page) + = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) { + DB::runman($man_page); + next CMD; + } + + return; +} + +sub _handle_p_command { + my $self = shift; + + my $print_cmd = 'print {$DB::OUT} '; + # p - print (no args): print $_. + if ($self->_is_full('p')) { + $DB::cmd = $print_cmd . '$_'; + } + else { + # p - print the given expression. + $DB::cmd =~ s/\Ap\b/$print_cmd /; + } + + return; +} + +sub _handle_equal_sign_command { + my $self = shift; + + if ($DB::cmd =~ s/\A=\s*//) { + my @keys; + if ( length $DB::cmd == 0 ) { + + # No args, get current aliases. + @keys = sort keys %alias; + } + elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) { + + # Creating a new alias. $k is alias name, $v is + # alias value. + + # can't use $_ or kill //g state + for my $x ( $k, $v ) { + + # Escape "alarm" characters. + $x =~ s/\a/\\a/g; + } + + # Substitute key for value, using alarm chars + # as separators (which is why we escaped them in + # the command). + $alias{$k} = "s\a$k\a$v\a"; + + # Turn off standard warn and die behavior. + local $SIG{__DIE__}; + local $SIG{__WARN__}; + + # Is it valid Perl? + unless ( eval "sub { s\a$k\a$v\a }; 1" ) { + + # Nope. Bad alias. Say so and get out. + print $OUT "Can't alias $k to $v: $@\n"; + delete $alias{$k}; + next CMD; + } + + # We'll only list the new one. + @keys = ($k); + } ## end elsif (my ($k, $v) = ($DB::cmd... + + # The argument is the alias to list. + else { + @keys = ($DB::cmd); + } + + # List aliases. + for my $k (@keys) { + + # Messy metaquoting: Trim the substitution code off. + # We use control-G as the delimiter because it's not + # likely to appear in the alias. + if ( ( my $v = $alias{$k} ) =~ ss\a$k\a(.*)\a$1 ) { + + # Print the alias. + print $OUT "$k\t= $1\n"; + } + elsif ( defined $alias{$k} ) { + + # Couldn't trim it off; just print the alias code. + print $OUT "$k\t$alias{$k}\n"; + } + else { + + # No such, dude. + print "No alias for $k\n"; + } + } ## end for my $k (@keys) + next CMD; + } + + return; +} + +sub _handle_source_command { + my $self = shift; + + # source - read commands from a file (or pipe!) and execute. + if (my $sourced_fn = $self->cmd_args) { + if ( open my $fh, $sourced_fn ) { + + # Opened OK; stick it in the list of file handles. + push @cmdfhs, $fh; + } + else { + + # Couldn't open it. + DB::_db_warn("Can't execute '$sourced_fn': $!\n"); + } + next CMD; + } + + return; +} + +sub _handle_enable_disable_commands { + my $self = shift; + + my $which_cmd = $self->cmd_verb; + my $position = $self->cmd_args; + + if ($position !~ /\s/) { + my ($fn, $line_num); + if ($position =~ m{\A\d+\z}) + { + $fn = $DB::filename; + $line_num = $position; + } + elsif (my ($new_fn, $new_line_num) + = $position =~ m{\A(.*):(\d+)\z}) { + ($fn, $line_num) = ($new_fn, $new_line_num); + } + else + { + DB::_db_warn("Wrong spec for enable/disable argument.\n"); + } + + if (defined($fn)) { + if (DB::_has_breakpoint_data_ref($fn, $line_num)) { + DB::_set_breakpoint_enabled_status($fn, $line_num, + ($which_cmd eq 'enable' ? 1 : '') + ); + } + else { + DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n"); + } + } + + next CMD; + } + + return; +} + +sub _handle_save_command { + my $self = shift; + + if (my $new_fn = $self->cmd_args) { + my $filename = $new_fn || '.perl5dbrc'; # default? + if ( open my $fh, '>', $filename ) { + + # chomp to remove extraneous newlines from source'd files + chomp( my @truelist = + map { m/\A\s*(save|source)/ ? "#$_" : $_ } + @truehist ); + print {$fh} join( "\n", @truelist ); + print "commands saved in $filename\n"; + } + else { + DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n"); + } + next CMD; + } + + return; +} + +sub _n_or_s_and_arg_commands_generic { + my ($self, $letter, $new_val) = @_; + + # s - single-step. Remember the last command was 's'. + if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) { + $laststep = $letter; + } + + return; +} + +sub _handle_sh_command { + my $self = shift; + + # $sh$sh - run a shell command (if it's all ASCII). + # Can't run shell commands with Unicode in the debugger, hmm. + my $my_cmd = $DB::cmd; + if ($my_cmd =~ m#\A$sh#gms) { + + if ($my_cmd =~ m#\G\z#cgms) { + # Run the user's shell. If none defined, run Bourne. + # We resume execution when the shell terminates. + DB::_db_system( $ENV{SHELL} || "/bin/sh" ); + next CMD; + } + elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) { + # System it. + DB::_db_system($1); + next CMD; + } + elsif ($my_cmd =~ m#\G\s*(.*)#cgms) { + DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); + next CMD; + } + } +} + +sub _handle_x_command { + my $self = shift; + + if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval() + $onetimeDump = 'dump'; # main::dumpvar shows the output + + # handle special "x 3 blah" syntax XXX propagate + # doc back to special variables. + if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) { + $onetimedumpDepth = $1; + } + } + + return; +} + +sub _handle_q_command { + my $self = shift; + + if ($self->_is_full('q')) { + $fall_off_end = 1; + DB::clean_ENV(); + exit $?; + } + + return; +} + +sub _handle_cmd_wrapper_commands { + my $self = shift; + + DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line ); + next CMD; +} + +sub _handle_special_char_cmd_wrapper_commands { + my $self = shift; + + # All of these commands were remapped in perl 5.8.0; + # we send them off to the secondary dispatcher (see below). + if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) { + DB::cmd_wrapper( $cmd_letter, $my_arg, $line ); + next CMD; + } + + return; +} + +} ## end DB::Obj + +package DB; + +# The following code may be executed now: +# BEGIN {warn 4} + + +use vars qw($deep); + +# We need to fully qualify the name ("DB::sub") to make "use strict;" +# happy. -- Shlomi Fish + +sub _indent_print_line_info { + my ($offset, $str) = @_; + + print_lineinfo( ' ' x ($stack_depth - $offset), $str); + + return; +} + +sub _print_frame_message { + my ($al) = @_; + + if ($frame) { + if ($frame & 4) { # Extended frame entry message + _indent_print_line_info(-1, "in "); + + # Why -1? But it works! :-( + # Because print_trace will call add 1 to it and then call + # dump_trace; this results in our skipping -1+1 = 0 stack frames + # in dump_trace. + # + # Now it's 0 because we extracted a function. + print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); + } + else { + _indent_print_line_info(-1, "entering $sub$al\n" ); + } + } + + return; +} + +sub DB::sub { + # lock ourselves under threads + lock($DBGR); + + # Whether or not the autoloader was running, a scalar to put the + # sub's return value in (if needed), and an array to put the sub's + # return value in (if needed). + my ( $al, $ret, @ret ) = ""; + if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) { + print "creating new thread\n"; + } + + # If the last ten characters are '::AUTOLOAD', note we've traced + # into AUTOLOAD for $sub. + if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + no strict 'refs'; + $al = " for $$sub" if defined $$sub; + } + + # We stack the stack pointer and then increment it to protect us + # from a situation that might unwind a whole bunch of call frames + # at once. Localizing the stack pointer means that it will automatically + # unwind the same amount when multiple stack frames are unwound. + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + + # Expand @stack. + $#stack = $stack_depth; + + # Save current single-step setting. + $stack[-1] = $single; + + # Turn off all flags except single-stepping. + $single &= 1; + + # If we've gotten really deeply recursed, turn on the flag that will + # make us stop with the 'deep recursion' message. + $single |= 4 if $stack_depth == $deep; + + # If frame messages are on ... + + _print_frame_message($al); + # standard frame entry message + + my $print_exit_msg = sub { + # Check for exit trace messages... + if ($frame & 2) + { + if ($frame & 4) # Extended exit message + { + _indent_print_line_info(0, "out "); + print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); + } + else + { + _indent_print_line_info(0, "exited $sub$al\n" ); + } + } + return; + }; + + # Determine the sub's return type, and capture appropriately. + if (wantarray) { + + # Called in array context. call sub and capture output. + # DB::DB will recursively get control again if appropriate; we'll come + # back here when the sub is finished. + { + no strict 'refs'; + @ret = &$sub; + } + + # Pop the single-step value back off the stack. + $single |= $stack[ $stack_depth-- ]; + + $print_exit_msg->(); + + # Print the return info if we need to. + if ( $doret eq $stack_depth or $frame & 16 ) { + + # Turn off output record separator. + local $\ = ''; + my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); + + # Indent if we're printing because of $frame tracing. + if ($frame & 16) + { + print {$fh} ' ' x $stack_depth; + } + + # Print the return value. + print {$fh} "list context return from $sub:\n"; + dumpit( $fh, \@ret ); + + # And don't print it again. + $doret = -2; + } ## end if ($doret eq $stack_depth... + # And we have to return the return value now. + @ret; + } ## end if (wantarray) + + # Scalar context. + else { + if ( defined wantarray ) { + no strict 'refs'; + # Save the value if it's wanted at all. + $ret = &$sub; + } + else { + no strict 'refs'; + # Void return, explicitly. + &$sub; + undef $ret; + } + + # Pop the single-step value off the stack. + $single |= $stack[ $stack_depth-- ]; + + # If we're doing exit messages... + $print_exit_msg->(); + + # If we are supposed to show the return value... same as before. + if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) { + local $\ = ''; + my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); + print $fh ( ' ' x $stack_depth ) if $frame & 16; + print $fh ( + defined wantarray + ? "scalar context return from $sub: " + : "void context return from $sub\n" + ); + dumpit( $fh, $ret ) if defined wantarray; + $doret = -2; + } ## end if ($doret eq $stack_depth... + + # Return the appropriate scalar value. + $ret; + } ## end else [ if (wantarray) +} ## end sub _sub + +sub lsub : lvalue { + + no strict 'refs'; + + # lock ourselves under threads + lock($DBGR); + + # Whether or not the autoloader was running, a scalar to put the + # sub's return value in (if needed), and an array to put the sub's + # return value in (if needed). + my ( $al, $ret, @ret ) = ""; + if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) { + print "creating new thread\n"; + } + + # If the last ten characters are C'::AUTOLOAD', note we've traced + # into AUTOLOAD for $sub. + if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) { + $al = " for $$sub"; + } + + # We stack the stack pointer and then increment it to protect us + # from a situation that might unwind a whole bunch of call frames + # at once. Localizing the stack pointer means that it will automatically + # unwind the same amount when multiple stack frames are unwound. + local $stack_depth = $stack_depth + 1; # Protect from non-local exits + + # Expand @stack. + $#stack = $stack_depth; + + # Save current single-step setting. + $stack[-1] = $single; + + # Turn off all flags except single-stepping. + # Use local so the single-step value is popped back off the + # stack for us. + local $single = $single & 1; + + # If we've gotten really deeply recursed, turn on the flag that will + # make us stop with the 'deep recursion' message. + $single |= 4 if $stack_depth == $deep; + + # If frame messages are on ... + _print_frame_message($al); + + # call the original lvalue sub. + &$sub; +} + +# Abstracting common code from multiple places elsewhere: +sub depth_print_lineinfo { + my $always_print = shift; + + print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth); +} + + +### The API section + +my %set = ( # + 'pre580' => { + 'a' => 'pre580_a', + 'A' => 'pre580_null', + 'b' => 'pre580_b', + 'B' => 'pre580_null', + 'd' => 'pre580_null', + 'D' => 'pre580_D', + 'h' => 'pre580_h', + 'M' => 'pre580_null', + 'O' => 'o', + 'o' => 'pre580_null', + 'v' => 'M', + 'w' => 'v', + 'W' => 'pre580_W', + }, + 'pre590' => { + '<' => 'pre590_prepost', + '<<' => 'pre590_prepost', + '>' => 'pre590_prepost', + '>>' => 'pre590_prepost', + '{' => 'pre590_prepost', + '{{' => 'pre590_prepost', + }, +); + +my %breakpoints_data; + +sub _has_breakpoint_data_ref { + my ($filename, $line) = @_; + + return ( + exists( $breakpoints_data{$filename} ) + and + exists( $breakpoints_data{$filename}{$line} ) + ); +} + +sub _get_breakpoint_data_ref { + my ($filename, $line) = @_; + + return ($breakpoints_data{$filename}{$line} ||= +{}); +} + +sub _delete_breakpoint_data_ref { + my ($filename, $line) = @_; + + delete($breakpoints_data{$filename}{$line}); + if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) { + delete($breakpoints_data{$filename}); + } + + return; +} + +sub _set_breakpoint_enabled_status { + my ($filename, $line, $status) = @_; + + _get_breakpoint_data_ref($filename, $line)->{'enabled'} = + ($status ? 1 : '') + ; + + return; +} + +sub _enable_breakpoint_temp_enabled_status { + my ($filename, $line) = @_; + + _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1; + + return; +} + +sub _cancel_breakpoint_temp_enabled_status { + my ($filename, $line) = @_; + + my $ref = _get_breakpoint_data_ref($filename, $line); + + delete ($ref->{'temp_enabled'}); + + if (! %$ref) { + _delete_breakpoint_data_ref($filename, $line); + } + + return; +} + +sub _is_breakpoint_enabled { + my ($filename, $line) = @_; + + my $data_ref = _get_breakpoint_data_ref($filename, $line); + return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'}); +} + + +sub cmd_wrapper { + my $cmd = shift; + my $line = shift; + my $dblineno = shift; + + # Assemble the command subroutine's name by looking up the + # command set and command name in %set. If we can't find it, + # default to the older version of the command. + my $call = 'cmd_' + . ( $set{$CommandSet}{$cmd} + || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) ); + + # Call the command subroutine, call it by name. + return __PACKAGE__->can($call)->( $cmd, $line, $dblineno ); +} ## end sub cmd_wrapper + + +sub cmd_a { + my $cmd = shift; + my $line = shift || ''; # [.|line] expr + my $dbline = shift; + + # If it's dot (here), or not all digits, use the current line. + $line =~ s/\A\./$dbline/; + + # Should be a line number followed by an expression. + if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) { + + if (! length($lineno)) { + $lineno = $dbline; + } + + # If we have an expression ... + if ( length $expr ) { + + # ... but the line isn't breakable, complain. + if ( $dbline[$lineno] == 0 ) { + print $OUT + "Line $lineno($dbline[$lineno]) does not have an action?\n"; + } + else { + + # It's executable. Record that the line has an action. + $had_breakpoints{$filename} |= 2; + + # Remove any action, temp breakpoint, etc. + $dbline{$lineno} =~ s/\0[^\0]*//; + + # Add the action to the line. + $dbline{$lineno} .= "\0" . action($expr); + + _set_breakpoint_enabled_status($filename, $lineno, 1); + } + } ## end if (length $expr) + } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/) + else { + + # Syntax wrong. + print $OUT + "Adding an action requires an optional lineno and an expression\n" + ; # hint + } +} ## end sub cmd_a + + +sub cmd_A { + my $cmd = shift; + my $line = shift || ''; + my $dbline = shift; + + # Dot is this line. + $line =~ s/^\./$dbline/; + + # Call delete_action with a null param to delete them all. + # The '1' forces the eval to be true. It'll be false only + # if delete_action blows up for some reason, in which case + # we print $@ and get out. + if ( $line eq '*' ) { + if (! eval { _delete_all_actions(); 1 }) { + print {$OUT} $@; + return; + } + } + + # There's a real line number. Pass it to delete_action. + # Error trapping is as above. + elsif ( $line =~ /^(\S.*)/ ) { + if (! eval { delete_action($1); 1 }) { + print {$OUT} $@; + return; + } + } + + # Swing and a miss. Bad syntax. + else { + print $OUT + "Deleting an action requires a line number, or '*' for all\n" ; # hint + } +} ## end sub cmd_A + + +sub _remove_action_from_dbline { + my $i = shift; + + $dbline{$i} =~ s/\0[^\0]*//; # \^a + delete $dbline{$i} if $dbline{$i} eq ''; + + return; +} + +sub _delete_all_actions { + print {$OUT} "Deleting all actions...\n"; + + for my $file ( keys %had_breakpoints ) { + local *dbline = $main::{ '_<' . $file }; + $max = $#dbline; + my $was; + for my $i (1 .. $max) { + if ( defined $dbline{$i} ) { + _remove_action_from_dbline($i); + } + } + + unless ( $had_breakpoints{$file} &= ~2 ) { + delete $had_breakpoints{$file}; + } + } + + return; +} + +sub delete_action { + my $i = shift; + + if ( defined($i) ) { + # Can there be one? + die "Line $i has no action .\n" if $dbline[$i] == 0; + + # Nuke whatever's there. + _remove_action_from_dbline($i); + } + else { + _delete_all_actions(); + } +} + + +sub cmd_b { + my $cmd = shift; + my $line = shift; # [.|line] [cond] + my $dbline = shift; + + my $default_cond = sub { + my $cond = shift; + return length($cond) ? $cond : '1'; + }; + + # Make . the current line number if it's there.. + $line =~ s/^\.(\s|\z)/$dbline$1/; + + # No line number, no condition. Simple break on current line. + if ( $line =~ /^\s*$/ ) { + cmd_b_line( $dbline, 1 ); + } + + # Break on load for a file. + elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) { + $file =~ s/\s+\z//; + cmd_b_load($file); + } + + # b compile|postpone [] + # The interpreter actually traps this one for us; we just put the + # necessary condition in the %postponed hash. + elsif ( my ($action, $subname, $cond) + = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { + + # De-Perl4-ify the name - ' separators to ::. + $subname =~ s/'/::/g; + + # Qualify it into the current package unless it's already qualified. + $subname = "${package}::" . $subname unless $subname =~ /::/; + + # Add main if it starts with ::. + $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; + + # Save the break type for this sub. + $postponed{$subname} = (($action eq 'postpone') + ? ( "break +0 if " . $default_cond->($cond) ) + : "compile"); + } ## end elsif ($line =~ ... + # b : [] + elsif (my ($filename, $line_num, $cond) + = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) { + cmd_b_filename_line( + $filename, + $line_num, + (length($cond) ? $cond : '1'), + ); + } + # b [] + elsif ( my ($new_subname, $new_cond) = + $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { + + # + $subname = $new_subname; + cmd_b_sub( $subname, $default_cond->($new_cond) ); + } + + # b []. + elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) { + + # Capture the line. If none, it's the current line. + $line = $line_n || $dbline; + + # Break on line. + cmd_b_line( $line, $default_cond->($cond) ); + } + + # Line didn't make sense. + else { + print "confused by line($line)?\n"; + } + + return; +} ## end sub cmd_b + + +sub break_on_load { + my $file = shift; + $break_on_load{$file} = 1; + $had_breakpoints{$file} |= 1; +} + + +sub report_break_on_load { + sort keys %break_on_load; +} + + +sub cmd_b_load { + my $file = shift; + my @files; + + # This is a block because that way we can use a redo inside it + # even without there being any looping structure at all outside it. + { + + # Save short name and full path if found. + push @files, $file; + push @files, $::INC{$file} if $::INC{$file}; + + # Tack on .pm and do it again unless there was a '.' in the name + # already. + $file .= '.pm', redo unless $file =~ /\./; + } + + # Do the real work here. + break_on_load($_) for @files; + + # All the files that have break-on-load breakpoints. + @files = report_break_on_load; + + # Normalize for the purposes of our printing this. + local $\ = ''; + local $" = ' '; + print $OUT "Will stop on load of '@files'.\n"; +} ## end sub cmd_b_load + + +use vars qw($filename_error); +$filename_error = ''; + + +sub breakable_line { + + my ( $from, $to ) = @_; + + # $i is the start point. (Where are the FORTRAN programs of yesteryear?) + my $i = $from; + + # If there are at least 2 arguments, we're trying to search a range. + if ( @_ >= 2 ) { + + # $delta is positive for a forward search, negative for a backward one. + my $delta = $from < $to ? +1 : -1; + + # Keep us from running off the ends of the file. + my $limit = $delta > 0 ? $#dbline : 1; + + # Clever test. If you're a mathematician, it's obvious why this + # test works. If not: + # If $delta is positive (going forward), $limit will be $#dbline. + # If $to is less than $limit, ($limit - $to) will be positive, times + # $delta of 1 (positive), so the result is > 0 and we should use $to + # as the stopping point. + # + # If $to is greater than $limit, ($limit - $to) is negative, + # times $delta of 1 (positive), so the result is < 0 and we should + # use $limit ($#dbline) as the stopping point. + # + # If $delta is negative (going backward), $limit will be 1. + # If $to is zero, ($limit - $to) will be 1, times $delta of -1 + # (negative) so the result is > 0, and we use $to as the stopping + # point. + # + # If $to is less than zero, ($limit - $to) will be positive, + # times $delta of -1 (negative), so the result is not > 0, and + # we use $limit (1) as the stopping point. + # + # If $to is 1, ($limit - $to) will zero, times $delta of -1 + # (negative), still giving zero; the result is not > 0, and + # we use $limit (1) as the stopping point. + # + # if $to is >1, ($limit - $to) will be negative, times $delta of -1 + # (negative), giving a positive (>0) value, so we'll set $limit to + # $to. + + $limit = $to if ( $limit - $to ) * $delta > 0; + + # The real search loop. + # $i starts at $from (the point we want to start searching from). + # We move through @dbline in the appropriate direction (determined + # by $delta: either -1 (back) or +1 (ahead). + # We stay in as long as we haven't hit an executable line + # ($dbline[$i] == 0 means not executable) and we haven't reached + # the limit yet (test similar to the above). + $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0; + + } ## end if (@_ >= 2) + + # If $i points to a line that is executable, return that. + return $i unless $dbline[$i] == 0; + + # Format the message and print it: no breakable lines in range. + my ( $pl, $upto ) = ( '', '' ); + ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to; + + # If there's a filename in filename_error, we'll see it. + # If not, not. + die "Line$pl $from$upto$filename_error not breakable\n"; +} ## end sub breakable_line + + +sub breakable_line_in_filename { + + # Capture the file name. + my ($f) = shift; + + # Swap the magic line array over there temporarily. + local *dbline = $main::{ '_<' . $f }; + + # If there's an error, it's in this other file. + local $filename_error = " of '$f'"; + + # Find the breakable line. + breakable_line(@_); + + # *dbline and $filename_error get restored when this block ends. + +} ## end sub breakable_line_in_filename + + +sub break_on_line { + my $i = shift; + my $cond = @_ ? shift(@_) : 1; + + my $inii = $i; + my $after = ''; + my $pl = ''; + + # Woops, not a breakable line. $filename_error allows us to say + # if it was in a different file. + die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0; + + # Mark this file as having breakpoints in it. + $had_breakpoints{$filename} |= 1; + + # If there is an action or condition here already ... + if ( $dbline{$i} ) { + + # ... swap this condition for the existing one. + $dbline{$i} =~ s/^[^\0]*/$cond/; + } + else { + + # Nothing here - just add the condition. + $dbline{$i} = $cond; + + _set_breakpoint_enabled_status($filename, $i, 1); + } + + return; +} ## end sub break_on_line + + +sub cmd_b_line { + if (not eval { break_on_line(@_); 1 }) { + local $\ = ''; + print $OUT $@ and return; + } + + return; +} ## end sub cmd_b_line + + +sub cmd_b_filename_line { + if (not eval { break_on_filename_line(@_); 1 }) { + local $\ = ''; + print $OUT $@ and return; + } + + return; +} + + +sub break_on_filename_line { + my $f = shift; + my $i = shift; + my $cond = @_ ? shift(@_) : 1; + + # Switch the magical hash temporarily. + local *dbline = $main::{ '_<' . $f }; + + # Localize the variables that break_on_line uses to make its message. + local $filename_error = " of '$f'"; + local $filename = $f; + + # Add the breakpoint. + break_on_line( $i, $cond ); + + return; +} ## end sub break_on_filename_line + + +sub break_on_filename_line_range { + my $f = shift; + my $from = shift; + my $to = shift; + my $cond = @_ ? shift(@_) : 1; + + # Find a breakable line if there is one. + my $i = breakable_line_in_filename( $f, $from, $to ); + + # Add the breakpoint. + break_on_filename_line( $f, $i, $cond ); + + return; +} ## end sub break_on_filename_line_range + + +sub subroutine_filename_lines { + my ( $subname ) = @_; + + # Returned value from find_sub() is fullpathname:startline-endline. + # The match creates the list (fullpathname, start, end). + return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/); +} ## end sub subroutine_filename_lines + + +sub break_subroutine { + my $subname = shift; + + # Get filename, start, and end. + my ( $file, $s, $e ) = subroutine_filename_lines($subname) + or die "Subroutine $subname not found.\n"; + + + # Null condition changes to '1' (always true). + my $cond = @_ ? shift(@_) : 1; + + # Put a break the first place possible in the range of lines + # that make up this subroutine. + break_on_filename_line_range( $file, $s, $e, $cond ); + + return; +} ## end sub break_subroutine + + +sub cmd_b_sub { + my $subname = shift; + my $cond = @_ ? shift : 1; + + # If the subname isn't a code reference, qualify it so that + # break_subroutine() will work right. + if ( ref($subname) ne 'CODE' ) { + + # Not Perl 4. + $subname =~ s/'/::/g; + my $s = $subname; + + # Put it in this package unless it's already qualified. + if ($subname !~ /::/) + { + $subname = $package . '::' . $subname; + }; + + # Requalify it into CORE::GLOBAL if qualifying it into this + # package resulted in its not being defined, but only do so + # if it really is in CORE::GLOBAL. + my $core_name = "CORE::GLOBAL::$s"; + if ((!defined(&$subname)) + and ($s !~ /::/) + and (defined &{$core_name})) + { + $subname = $core_name; + } + + # Put it in package 'main' if it has a leading ::. + if ($subname =~ /\A::/) + { + $subname = "main" . $subname; + } + } ## end if ( ref($subname) ne 'CODE' ) { + + # Try to set the breakpoint. + if (not eval { break_subroutine( $subname, $cond ); 1 }) { + local $\ = ''; + print {$OUT} $@; + return; + } + + return; +} ## end sub cmd_b_sub + + +sub cmd_B { + my $cmd = shift; + + # No line spec? Use dbline. + # If there is one, use it if it's non-zero, or wipe it out if it is. + my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || ''); + my $dbline = shift; + + # If the line was dot, make the line the current one. + $line =~ s/^\./$dbline/; + + # If it's * we're deleting all the breakpoints. + if ( $line eq '*' ) { + if (not eval { delete_breakpoint(); 1 }) { + print {$OUT} $@; + } + } + + # If there is a line spec, delete the breakpoint on that line. + elsif ( $line =~ /\A(\S.*)/ ) { + if (not eval { delete_breakpoint( $line || $dbline ); 1 }) { + local $\ = ''; + print {$OUT} $@; + } + } ## end elsif ($line =~ /^(\S.*)/) + + # No line spec. + else { + print {$OUT} + "Deleting a breakpoint requires a line number, or '*' for all\n" + ; # hint + } + + return; +} ## end sub cmd_B + + +sub _remove_breakpoint_entry { + my ($fn, $i) = @_; + + delete $dbline{$i}; + _delete_breakpoint_data_ref($fn, $i); + + return; +} + +sub _delete_all_breakpoints { + print {$OUT} "Deleting all breakpoints...\n"; + + # %had_breakpoints lists every file that had at least one + # breakpoint in it. + for my $fn ( keys %had_breakpoints ) { + + # Switch to the desired file temporarily. + local *dbline = $main::{ '_<' . $fn }; + + $max = $#dbline; + + # For all lines in this file ... + for my $i (1 .. $max) { + + # If there's a breakpoint or action on this line ... + if ( defined $dbline{$i} ) { + + # ... remove the breakpoint. + $dbline{$i} =~ s/\A[^\0]+//; + if ( $dbline{$i} =~ s/\A\0?\z// ) { + # Remove the entry altogether if no action is there. + _remove_breakpoint_entry($fn, $i); + } + } ## end if (defined $dbline{$i... + } ## end for $i (1 .. $max) + + # If, after we turn off the "there were breakpoints in this file" + # bit, the entry in %had_breakpoints for this file is zero, + # we should remove this file from the hash. + if ( not $had_breakpoints{$fn} &= (~1) ) { + delete $had_breakpoints{$fn}; + } + } ## end for my $fn (keys %had_breakpoints) + + # Kill off all the other breakpoints that are waiting for files that + # haven't been loaded yet. + undef %postponed; + undef %postponed_file; + undef %break_on_load; + + return; +} + +sub _delete_breakpoint_from_line { + my ($i) = @_; + + # Woops. This line wasn't breakable at all. + die "Line $i not breakable.\n" if $dbline[$i] == 0; + + # Kill the condition, but leave any action. + $dbline{$i} =~ s/\A[^\0]*//; + + # Remove the entry entirely if there's no action left. + if ($dbline{$i} eq '') { + _remove_breakpoint_entry($filename, $i); + } + + return; +} + +sub delete_breakpoint { + my $i = shift; + + # If we got a line, delete just that one. + if ( defined($i) ) { + _delete_breakpoint_from_line($i); + } + # No line; delete them all. + else { + _delete_all_breakpoints(); + } + + return; +} + + +sub cmd_stop { # As on ^C, but not signal-safy. + $signal = 1; +} + + +sub cmd_e { + my $cmd = shift; + my $line = shift; + unless (exists($INC{'threads.pm'})) { + print "threads not loaded($ENV{PERL5DB_THREADED}) + please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; + } else { + my $tid = threads->tid; + print "thread id: $tid\n"; + } +} ## end sub cmd_e + + +sub cmd_E { + my $cmd = shift; + my $line = shift; + unless (exists($INC{'threads.pm'})) { + print "threads not loaded($ENV{PERL5DB_THREADED}) + please run the debugger with PERL5DB_THREADED=1 set in the environment\n"; + } else { + my $tid = threads->tid; + print "thread ids: ".join(', ', + map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list + )."\n"; + } +} ## end sub cmd_E + + +use vars qw($help); +use vars qw($summary); + +sub cmd_h { + my $cmd = shift; + + # If we have no operand, assume null. + my $line = shift || ''; + + # 'h h'. Print the long-format help. + if ( $line =~ /\Ah\s*\z/ ) { + print_help($help); + } + + # 'h '. Search for the command and print only its help. + elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) { + + # support long commands; otherwise bogus errors + # happen when you ask for h on for example + my $qasked = quotemeta($asked); # for searching; we don't + # want to use it as a pattern. + # XXX: finds CR but not + + # Search the help string for the command. + if ( + $help =~ /^ # Start of a line + is not a debugger command.\n"); + } + } ## end elsif ($line =~ /^(\S.*)$/) + + # 'h' - print the summary help. + else { + print_help($summary); + } +} ## end sub cmd_h + + +sub cmd_i { + my $cmd = shift; + my $line = shift; + foreach my $isa ( split( /\s+/, $line ) ) { + $evalarg = $isa; + # The &-call is here to ascertain the mutability of @_. + ($isa) = &DB::eval; + no strict 'refs'; + print join( + ', ', + map { + "$_" + . ( + defined( ${"$_\::VERSION"} ) + ? ' ' . ${"$_\::VERSION"} + : undef ) + } @{mro::get_linear_isa(ref($isa) || $isa)} + ); + print "\n"; + } +} ## end sub cmd_i + + +sub _min { + my $min = shift; + foreach my $v (@_) { + if ($min > $v) { + $min = $v; + } + } + return $min; +} + +sub _max { + my $max = shift; + foreach my $v (@_) { + if ($max < $v) { + $max = $v; + } + } + return $max; +} + +sub _minify_to_max { + my $ref = shift; + + $$ref = _min($$ref, $max); + + return; +} + +sub _cmd_l_handle_var_name { + my $var_name = shift; + + $evalarg = $var_name; + + my ($s) = DB::eval(); + + # Ooops. Bad scalar. + if ($@) { + print {$OUT} "Error: $@\n"; + next CMD; + } + + # Good scalar. If it's a reference, find what it points to. + $s = CvGV_name($s); + print {$OUT} "Interpreted as: $1 $s\n"; + $line = "$1 $s"; + + # Call self recursively to really do the command. + return _cmd_l_main( $s ); +} + +sub _cmd_l_handle_subname { + + my $s = $subname; + + # De-Perl4. + $subname =~ s/\'/::/; + + # Put it in this package unless it starts with ::. + $subname = $package . "::" . $subname unless $subname =~ /::/; + + # Put it in CORE::GLOBAL if t doesn't start with :: and + # it doesn't live in this package and it lives in CORE::GLOBAL. + $subname = "CORE::GLOBAL::$s" + if not defined &$subname + and $s !~ /::/ + and defined &{"CORE::GLOBAL::$s"}; + + # Put leading '::' names into 'main::'. + $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; + + # Get name:start-stop from find_sub, and break this up at + # colons. + my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); + + # Pull off start-stop. + my $subrange = pop @pieces; + + # If the name contained colons, the split broke it up. + # Put it back together. + $file = join( ':', @pieces ); + + # If we're not in that file, switch over to it. + if ( $file ne $filename ) { + if (! $slave_editor) { + print {$OUT} "Switching to file '$file'.\n"; + } + + # Switch debugger's magic structures. + *dbline = $main::{ '_<' . $file }; + $max = $#dbline; + $filename = $file; + } ## end if ($file ne $filename) + + # Subrange is 'start-stop'. If this is less than a window full, + # swap it to 'start+', which will list a window from the start point. + if ($subrange) { + if ( eval($subrange) < -$window ) { + $subrange =~ s/-.*/+/; + } + + # Call self recursively to list the range. + return _cmd_l_main( $subrange ); + } ## end if ($subrange) + + # Couldn't find it. + else { + print {$OUT} "Subroutine $subname not found.\n"; + return; + } +} + +sub _cmd_l_empty { + # Compute new range to list. + $incr = $window - 1; + + # Recurse to do it. + return _cmd_l_main( $start . '-' . ( $start + $incr ) ); +} + +sub _cmd_l_plus { + my ($new_start, $new_incr) = @_; + + # Don't reset start for 'l +nnn'. + $start = $new_start if $new_start; + + # Increment for list. Use window size if not specified. + # (Allows 'l +' to work.) + $incr = $new_incr || ($window - 1); + + # Create a line range we'll understand, and recurse to do it. + return _cmd_l_main( $start . '-' . ( $start + $incr ) ); +} + +sub _cmd_l_calc_initial_end_and_i { + my ($spec, $start_match, $end_match) = @_; + + # Determine end point; use end of file if not specified. + my $end = ( !defined $start_match ) ? $max : + ( $end_match ? $end_match : $start_match ); + + # Go on to the end, and then stop. + _minify_to_max(\$end); + + # Determine start line. + my $i = $start_match; + + if ($i eq '.') { + $i = $spec; + } + + $i = _max($i, 1); + + $incr = $end - $i; + + return ($end, $i); +} + +sub _cmd_l_range { + my ($spec, $current_line, $start_match, $end_match) = @_; + + my ($end, $i) = + _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match); + + # If we're running under a slave editor, force it to show the lines. + if ($slave_editor) { + print {$OUT} "\032\032$filename:$i:0\n"; + $i = $end; + } + # We're doing it ourselves. We want to show the line and special + # markers for: + # - the current line in execution + # - whether a line is breakable or not + # - whether a line has a break or not + # - whether a line has an action or not + else { + I_TO_END: + for ( ; $i <= $end ; $i++ ) { + + # Check for breakpoints and actions. + my ( $stop, $action ); + if ($dbline{$i}) { + ( $stop, $action ) = split( /\0/, $dbline{$i} ); + } + + # ==> if this is the current line in execution, + # : if it's breakable. + my $arrow = + ( $i == $current_line and $filename eq $filename_ini ) + ? '==>' + : ( $dbline[$i] + 0 ? ':' : ' ' ); + + # Add break and action indicators. + $arrow .= 'b' if $stop; + $arrow .= 'a' if $action; + + # Print the line. + print {$OUT} "$i$arrow\t", $dbline[$i]; + + # Move on to the next line. Drop out on an interrupt. + if ($signal) { + $i++; + last I_TO_END; + } + } ## end for (; $i <= $end ; $i++) + + # Line the prompt up; print a newline if the last line listed + # didn't have a newline. + if ($dbline[ $i - 1 ] !~ /\n\z/) { + print {$OUT} "\n"; + } + } ## end else [ if ($slave_editor) + + # Save the point we last listed to in case another relative 'l' + # command is desired. Don't let it run off the end. + $start = $i; + _minify_to_max(\$start); + + return; +} + +sub _cmd_l_main { + my $spec = shift; + + # If this is '-something', delete any spaces after the dash. + $spec =~ s/\A-\s*\z/-/; + + # If the line is '$something', assume this is a scalar containing a + # line number. + # Set up for DB::eval() - evaluate in *user* context. + if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) { + return _cmd_l_handle_var_name($var_name); + } + # l name. Try to find a sub by that name. + elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) { + return _cmd_l_handle_subname(); + } + # Bare 'l' command. + elsif ( $spec !~ /\S/ ) { + return _cmd_l_empty(); + } + # l [start]+number_of_lines + elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) { + return _cmd_l_plus($new_start, $new_incr); + } + # l start-stop or l start,stop + elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) { + return _cmd_l_range($spec, $line, $s, $e); + } + + return; +} ## end sub cmd_l + +sub cmd_l { + my (undef, $line) = @_; + + return _cmd_l_main($line); +} + + +sub _cmd_L_calc_arg { + # If no argument, list everything. Pre-5.8.0 version always lists + # everything + my $arg = shift || 'abw'; + if ($CommandSet ne '580') + { + $arg = 'abw'; + } + + return $arg; +} + +sub _cmd_L_calc_wanted_flags { + my $arg = _cmd_L_calc_arg(shift); + + return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w)); +} + + +sub _cmd_L_handle_breakpoints { + my ($handle_db_line) = @_; + + BREAKPOINTS_SCAN: + # Look in all the files with breakpoints... + for my $file ( keys %had_breakpoints ) { + + # Temporary switch to this file. + local *dbline = $main::{ '_<' . $file }; + + # Set up to look through the whole file. + $max = $#dbline; + my $was; # Flag: did we print something + # in this file? + + # For each line in the file ... + for my $i (1 .. $max) { + + # We've got something on this line. + if ( defined $dbline{$i} ) { + + # Print the header if we haven't. + if (not $was++) { + print {$OUT} "$file:\n"; + } + + # Print the line. + print {$OUT} " $i:\t", $dbline[$i]; + + $handle_db_line->($dbline{$i}); + + # Quit if the user hit interrupt. + if ($signal) { + last BREAKPOINTS_SCAN; + } + } ## end if (defined $dbline{$i... + } ## end for my $i (1 .. $max) + } ## end for my $file (keys %had_breakpoints) + + return; +} + +sub _cmd_L_handle_postponed_breakpoints { + my ($handle_db_line) = @_; + + print {$OUT} "Postponed breakpoints in files:\n"; + + POSTPONED_SCANS: + for my $file ( keys %postponed_file ) { + my $db = $postponed_file{$file}; + print {$OUT} " $file:\n"; + for my $line ( sort { $a <=> $b } keys %$db ) { + print {$OUT} " $line:\n"; + + $handle_db_line->($db->{$line}); + + if ($signal) { + last POSTPONED_SCANS; + } + } + if ($signal) { + last POSTPONED_SCANS; + } + } + + return; +} + + +sub cmd_L { + my $cmd = shift; + + my ($action_wanted, $break_wanted, $watch_wanted) = + _cmd_L_calc_wanted_flags(shift); + + my $handle_db_line = sub { + my ($l) = @_; + + my ( $stop, $action ) = split( /\0/, $l ); + + if ($stop and $break_wanted) { + print {$OUT} " break if (", $stop, ")\n" + } + + if ($action && $action_wanted) { + print {$OUT} " action: ", $action, "\n" + } + + return; + }; + + # Breaks and actions are found together, so we look in the same place + # for both. + if ( $break_wanted or $action_wanted ) { + _cmd_L_handle_breakpoints($handle_db_line); + } + + # Look for breaks in not-yet-compiled subs: + if ( %postponed and $break_wanted ) { + print {$OUT} "Postponed breakpoints in subroutines:\n"; + my $subname; + SUBS_SCAN: + for $subname ( keys %postponed ) { + print {$OUT} " $subname\t$postponed{$subname}\n"; + if ($signal) { + last SUBS_SCAN; + } + } + } ## end if (%postponed and $break_wanted) + + # Find files that have not-yet-loaded breaks: + my @have = map { # Combined keys + keys %{ $postponed_file{$_} } + } keys %postponed_file; + + # If there are any, list them. + if ( @have and ( $break_wanted or $action_wanted ) ) { + _cmd_L_handle_postponed_breakpoints($handle_db_line); + } ## end if (@have and ($break_wanted... + + if ( %break_on_load and $break_wanted ) { + print {$OUT} "Breakpoints on load:\n"; + BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) { + print {$OUT} " $filename\n"; + last BREAK_ON_LOAD if $signal; + } + } ## end if (%break_on_load and... + + if ($watch_wanted and ( $trace & 2 )) { + print {$OUT} "Watch-expressions:\n" if @to_watch; + TO_WATCH: for my $expr (@to_watch) { + print {$OUT} " $expr\n"; + last TO_WATCH if $signal; + } + } + + return; +} ## end sub cmd_L + + +sub cmd_M { + list_modules(); + + return; +} + + +sub cmd_o { + my $cmd = shift; + my $opt = shift || ''; # opt[=val] + + # Nonblank. Try to parse and process. + if ( $opt =~ /^(\S.*)/ ) { + parse_options($1); + } + + # Blank. List the current option settings. + else { + for (@options) { + dump_option($_); + } + } +} ## end sub cmd_o + + +sub cmd_O { + print $OUT "The old O command is now the o command.\n"; # hint + print $OUT "Use 'h' to get current command help synopsis or\n"; # + print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; # +} + + +use vars qw($preview); + +sub cmd_v { + my $cmd = shift; + my $line = shift; + + # Extract the line to list around. (Astute readers will have noted that + # this pattern will match whether or not a numeric line is specified, + # which means that we'll always enter this loop (though a non-numeric + # argument results in no action at all)). + if ( $line =~ /^(\d*)$/ ) { + + # Total number of lines to list (a windowful). + $incr = $window - 1; + + # Set the start to the argument given (if there was one). + $start = $1 if $1; + + # Back up by the context amount. + $start -= $preview; + + # Put together a linespec that cmd_l will like. + $line = $start . '-' . ( $start + $incr ); + + # List the lines. + cmd_l( 'l', $line ); + } ## end if ($line =~ /^(\d*)$/) +} ## end sub cmd_v + + +sub _add_watch_expr { + my $expr = shift; + + # ... save it. + push @to_watch, $expr; + + # Parameterize DB::eval and call it to get the expression's value + # in the user's context. This version can handle expressions which + # return a list value. + $evalarg = $expr; + # The &-call is here to ascertain the mutability of @_. + my ($val) = join( ' ', &DB::eval); + $val = ( defined $val ) ? "'$val'" : 'undef'; + + # Save the current value of the expression. + push @old_watch, $val; + + # We are now watching expressions. + $trace |= 2; + + return; +} + +sub cmd_w { + my $cmd = shift; + + # Null expression if no arguments. + my $expr = shift || ''; + + # If expression is not null ... + if ( $expr =~ /\A\S/ ) { + _add_watch_expr($expr); + } ## end if ($expr =~ /^(\S.*)/) + + # You have to give one to get one. + else { + print $OUT "Adding a watch-expression requires an expression\n"; # hint + } + + return; +} + + +sub cmd_W { + my $cmd = shift; + my $expr = shift || ''; + + # Delete them all. + if ( $expr eq '*' ) { + + # Not watching now. + $trace &= ~2; + + print $OUT "Deleting all watch expressions ...\n"; + + # And all gone. + @to_watch = @old_watch = (); + } + + # Delete one of them. + elsif ( $expr =~ /^(\S.*)/ ) { + + # Where we are in the list. + my $i_cnt = 0; + + # For each expression ... + foreach (@to_watch) { + my $val = $to_watch[$i_cnt]; + + # Does this one match the command argument? + if ( $val eq $expr ) { # =~ m/^\Q$i$/) { + # Yes. Turn it off, and its value too. + splice( @to_watch, $i_cnt, 1 ); + splice( @old_watch, $i_cnt, 1 ); + } + $i_cnt++; + } ## end foreach (@to_watch) + + # We don't bother to turn watching off because + # a) we don't want to stop calling watchfunction() if it exists + # b) foreach over a null list doesn't do anything anyway + + } ## end elsif ($expr =~ /^(\S.*)/) + + # No command arguments entered. + else { + print $OUT + "Deleting a watch-expression requires an expression, or '*' for all\n" + ; # hint + } +} ## end sub cmd_W + +### END of the API section + + +sub save { + + # Save eval failure, command failure, extended OS error, output field + # separator, input record separator, output record separator and + # the warning setting. + @saved = ( $@, $!, $^E, $,, $/, $\, $^W ); + + $, = ""; # output field separator is null string + $/ = "\n"; # input record separator is newline + $\ = ""; # output record separator is null string + $^W = 0; # warnings are off +} ## end sub save + + +sub print_lineinfo { + + # Make the terminal sensible if we're not the primary debugger. + resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; + local $\ = ''; + local $, = ''; + # $LINEINFO may be undef if $noTTY is set or some other issue. + if ($LINEINFO) + { + print {$LINEINFO} @_; + } +} ## end sub print_lineinfo + + +# The following takes its argument via $evalarg to preserve current @_ + +sub postponed_sub { + + # Get the subroutine name. + my $subname = shift; + + # If this is a 'break + if ' ... + if ( $postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s// ) { + + # If there's no offset, use '+0'. + my $offset = $1 || 0; + + # find_sub's value is 'fullpath-filename:start-stop'. It's + # possible that the filename might have colons in it too. + my ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(\d+)-.*$/ ); + if ($i) { + + # We got the start line. Add the offset '+' from + # $postponed{subname}. + $i += $offset; + + # Switch to the file this sub is in, temporarily. + local *dbline = $main::{ '_<' . $file }; + + # No warnings, please. + local $^W = 0; # != 0 is magical below + + # This file's got a breakpoint in it. + $had_breakpoints{$file} |= 1; + + # Last line in file. + $max = $#dbline; + + # Search forward until we hit a breakable line or get to + # the end of the file. + ++$i until $dbline[$i] != 0 or $i >= $max; + + # Copy the breakpoint in and delete it from %postponed. + $dbline{$i} = delete $postponed{$subname}; + } ## end if ($i) + + # find_sub didn't find the sub. + else { + local $\ = ''; + print $OUT "Subroutine $subname not found.\n"; + } + return; + } ## end if ($postponed{$subname... + elsif ( $postponed{$subname} eq 'compile' ) { $signal = 1 } + + #print $OUT "In postponed_sub for '$subname'.\n"; +} ## end sub postponed_sub + + +sub postponed { + + # If there's a break, process it. + if ($ImmediateStop) { + + # Right, we've stopped. Turn it off. + $ImmediateStop = 0; + + # Enter the command loop when DB::DB gets called. + $signal = 1; + } + + # If this is a subroutine, let postponed_sub() deal with it. + if (ref(\$_[0]) ne 'GLOB') { + return postponed_sub(@_); + } + + # Not a subroutine. Deal with the file. + local *dbline = shift; + my $filename = $dbline; + $filename =~ s/^_ $maxtrace; + + # Get the file name. + my $file = $sub[$i]{file}; + + # Put in a filename header if short is off. + $file = $file eq '-e' ? $file : "file '$file'" unless $short; + + # Get the actual sub's name, and shorten to $maxtrace's requirement. + $s = $sub[$i]{'sub'}; + $s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace; + + # Short report uses trimmed file and sub names. + if ($short) { + my $sub = @_ >= 4 ? $_[3] : $s; + print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n"; + } ## end if ($short) + + # Non-short report includes full names. + else { + print $fh "$sub[$i]{context} = $s$args" + . " called from $file" + . " line $sub[$i]{line}\n"; + } + } ## end for my $i (0 .. $#sub) +} ## end sub print_trace + + +sub _dump_trace_calc_saved_single_arg +{ + my ($nothard, $arg) = @_; + + my $type; + if ( not defined $arg ) { # undefined parameter + return "undef"; + } + + elsif ( $nothard and tied $arg ) { # tied parameter + return "tied"; + } + elsif ( $nothard and $type = ref $arg ) { # reference + return "ref($type)"; + } + else { # can be stringified + local $_ = + "$arg"; # Safe to stringify now - should not call f(). + + # Backslash any single-quotes or backslashes. + s/([\'\\])/\\$1/g; + + # Single-quote it unless it's a number or a colon-separated + # name. + s/(.*)/'$1'/s + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + + # Turn high-bit characters into meta-whatever, and controls into like + # '^D'. + require 'meta_notation.pm'; + $_ = _meta_notation($_) if /[[:^print:]]/a; + + return $_; + } +} + +sub _dump_trace_calc_save_args { + my ($nothard) = @_; + + return [ + map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args + ]; +} + +sub dump_trace { + + # How many levels to skip. + my $skip = shift; + + # How many levels to show. (1e9 is a cheap way of saying "all of them"; + # it's unlikely that we'll have more than a billion stack frames. If you + # do, you've got an awfully big machine...) + my $count = shift || 1e9; + + # We increment skip because caller(1) is the first level *back* from + # the current one. Add $skip to the count of frames so we have a + # simple stop criterion, counting from $skip to $count+$skip. + $skip++; + $count += $skip; + + # These variables are used to capture output from caller(); + my ( $p, $file, $line, $sub, $h, $context ); + + my ( $e, $r, @sub, $args ); + + # XXX Okay... why'd we do that? + my $nothard = not $frame & 8; + local $frame = 0; + + # Do not want to trace this. + my $otrace = $trace; + $trace = 0; + + # Start out at the skip count. + # If we haven't reached the number of frames requested, and caller() is + # still returning something, stay in the loop. (If we pass the requested + # number of stack frames, or we run out - caller() returns nothing - we + # quit. + # Up the stack frame index to go back one more level each time. + for ( + my $i = $skip ; + $i < $count + and ( $p, $file, $line, $sub, $h, $context, $e, $r ) = caller($i) ; + $i++ + ) + { + # if the sub has args ($h true), make an anonymous array of the + # dumped args. + my $args = $h ? _dump_trace_calc_save_args($nothard) : undef; + + # If context is true, this is array (@)context. + # If context is false, this is scalar ($) context. + # If neither, context isn't defined. (This is apparently a 'can't + # happen' trap.) + $context = $context ? '@' : ( defined $context ? "\$" : '.' ); + + # remove trailing newline-whitespace-semicolon-end of line sequence + # from the eval text, if any. + $e =~ s/\n\s*\;\s*\Z// if $e; + + # Escape backslashed single-quotes again if necessary. + $e =~ s/([\\\'])/\\$1/g if $e; + + # if the require flag is true, the eval text is from a require. + if ($r) { + $sub = "require '$e'"; + } + + # if it's false, the eval text is really from an eval. + elsif ( defined $r ) { + $sub = "eval '$e'"; + } + + # If the sub is '(eval)', this is a block eval, meaning we don't + # know what the eval'ed text actually was. + elsif ( $sub eq '(eval)' ) { + $sub = "eval {...}"; + } + + # Stick the collected information into @sub as an anonymous hash. + push( + @sub, + { + context => $context, + sub => $sub, + args => $args, + file => $file, + line => $line + } + ); + + # Stop processing frames if the user hit control-C. + last if $signal; + } ## end for ($i = $skip ; $i < ... + + # Restore the trace value again. + $trace = $otrace; + @sub; +} ## end sub dump_trace + + +sub action { + my $action = shift; + + while ( $action =~ s/\\$// ) { + + # We have a backslash on the end. Read more. + $action .= gets(); + } ## end while ($action =~ s/\\$//) + + # Return the assembled action. + $action; +} ## end sub action + + +use vars qw($balanced_brace_re); + +sub unbalanced { + + # I hate using globals! + $balanced_brace_re ||= qr{ + ^ \{ + (?: + (?> [^{}] + ) # Non-parens without backtracking + | + (??{ $balanced_brace_re }) # Group with matching parens + ) * + \} $ + }x; + return $_[0] !~ m/$balanced_brace_re/; +} ## end sub unbalanced + + +sub gets { + return DB::readline("cont: "); +} + + +sub _db_system { + + # We save, change, then restore STDIN and STDOUT to avoid fork() since + # some non-Unix systems can do system() but have problems with fork(). + open( SAVEIN, "<&STDIN" ) || _db_warn("Can't save STDIN"); + open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT"); + open( STDIN, "<&IN" ) || _db_warn("Can't redirect STDIN"); + open( STDOUT, ">&OUT" ) || _db_warn("Can't redirect STDOUT"); + + # XXX: using csh or tcsh destroys sigint retvals! + system(@_); + open( STDIN, "<&SAVEIN" ) || _db_warn("Can't restore STDIN"); + open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT"); + close(SAVEIN); + close(SAVEOUT); + + # most of the $? crud was coping with broken cshisms + if ( $? >> 8 ) { + _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" ); + } + elsif ($?) { + _db_warn( + "(Command died of SIG#", + ( $? & 127 ), + ( ( $? & 128 ) ? " -- core dumped" : "" ), + ")", "\n" + ); + } ## end elsif ($?) + + return $?; + +} ## end sub system + +*system = \&_db_system; + + +use vars qw($ornaments); +use vars qw($rl_attribs); + +sub setterm { + + # Load Term::Readline, but quietly; don't debug it and don't trace it. + local $frame = 0; + local $doret = -2; + require Term::ReadLine; + + # If noTTY is set, but we have a TTY name, go ahead and hook up to it. + if ($notty) { + if ($tty) { + my ( $i, $o ) = split $tty, /,/; + $o = $i unless defined $o; + open( IN, '<', $i ) or die "Cannot open TTY '$i' for read: $!"; + open( OUT, '>', $o ) or die "Cannot open TTY '$o' for write: $!"; + $IN = \*IN; + $OUT = \*OUT; + _autoflush($OUT); + } ## end if ($tty) + + # We don't have a TTY - try to find one via Term::Rendezvous. + else { + require Term::Rendezvous; + + # See if we have anything to pass to Term::Rendezvous. + # Use $HOME/.perldbtty$$ if not. + my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$"; + + # Rendezvous and get the filehandles. + my $term_rv = Term::Rendezvous->new( $rv ); + $IN = $term_rv->IN; + $OUT = $term_rv->OUT; + } ## end else [ if ($tty) + } ## end if ($notty) + + # We're a daughter debugger. Try to fork off another TTY. + if ( $term_pid eq '-1' ) { # In a TTY with another debugger + resetterm(2); + } + + # If we shouldn't use Term::ReadLine, don't. + if ( !$rl ) { + $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); + } + + # We're using Term::ReadLine. Get all the attributes for this terminal. + else { + $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); + + $rl_attribs = $term->Attribs; + $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}' + if defined $rl_attribs->{basic_word_break_characters} + and index( $rl_attribs->{basic_word_break_characters}, ":" ) == -1; + $rl_attribs->{special_prefixes} = '$@&%'; + $rl_attribs->{completer_word_break_characters} .= '$@&%'; + $rl_attribs->{completion_function} = \&db_complete; + } ## end else [ if (!$rl) + + # Set up the LINEINFO filehandle. + $LINEINFO = $OUT unless defined $LINEINFO; + $lineinfo = $console unless defined $lineinfo; + + $term->MinLine(2); + + load_hist(); + + if ( $term->Features->{setHistory} and "@hist" ne "?" ) { + $term->SetHistory(@hist); + } + + # XXX Ornaments are turned on unconditionally, which is not + # always a good thing. + ornaments($ornaments) if defined $ornaments; + $term_pid = $$; +} ## end sub setterm + +sub load_hist { + $histfile //= option_val("HistFile", undef); + return unless defined $histfile; + open my $fh, "<", $histfile or return; + local $/ = "\n"; + @hist = (); + while (<$fh>) { + chomp; + push @hist, $_; + } + close $fh; +} + +sub save_hist { + return unless defined $histfile; + eval { require File::Path } or return; + eval { require File::Basename } or return; + File::Path::mkpath(File::Basename::dirname($histfile)); + open my $fh, ">", $histfile or die "Could not open '$histfile': $!"; + $histsize //= option_val("HistSize",100); + my @copy = grep { $_ ne '?' } @hist; + my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0; + for ($start .. $#copy) { + print $fh "$copy[$_]\n"; + } + close $fh or die "Could not write '$histfile': $!"; +} + + +sub connect_remoteport { + require IO::Socket; + + my $socket = IO::Socket::INET->new( + Timeout => '10', + PeerAddr => $remoteport, + Proto => 'tcp', + ); + if ( ! $socket ) { + die "Unable to connect to remote host: $remoteport\n"; + } + return $socket; +} + +sub socket_get_fork_TTY { + $tty = $LINEINFO = $IN = $OUT = connect_remoteport(); + + # Do I need to worry about setting $term? + + reset_IN_OUT( $IN, $OUT ); + return ''; +} + + +sub xterm_get_fork_TTY { + ( my $name = $0 ) =~ s,^.*[/\\],,s; + open XT, +qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\ + sleep 10000000' |]; + + # Get the output from 'tty' and clean it up a little. + my $tty = ; + chomp $tty; + + $pidprompt = ''; # Shown anyway in titlebar + + # We need $term defined or we can not switch to the newly created xterm + if ($tty ne '' && !defined $term) { + require Term::ReadLine; + if ( !$rl ) { + $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); + } + else { + $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); + } + } + # There's our new TTY. + return $tty; +} ## end sub xterm_get_fork_TTY + + +# This example function resets $IN, $OUT itself +my $c_pipe = 0; +sub os2_get_fork_TTY { # A simplification of the following (and works without): + local $\ = ''; + ( my $name = $0 ) =~ s,^.*[/\\],,s; + my %opt = ( title => "Daughter Perl debugger $pids $name", + ($rl ? (read_by_key => 1) : ()) ); + require OS2::Process; + my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) } + or return; + $pidprompt = ''; # Shown anyway in titlebar + reset_IN_OUT($in, $out); + $tty = '*reset*'; + return ''; # Indicate that reset_IN_OUT is called +} ## end sub os2_get_fork_TTY + + +# Notes about Terminal.app's AppleScript support, +# (aka things that might break in future OS versions). +# +# The "do script" command doesn't return a reference to the new window +# it creates, but since it appears frontmost and windows are enumerated +# front to back, we can use "first window" === "window 1". +# +# Since "do script" is implemented by supplying the argument (plus a +# return character) as terminal input, there's a potential race condition +# where the debugger could beat the shell to reading the command. +# To prevent this, we wait for the screen to clear before proceeding. +# +# 10.3 and 10.4: +# There's no direct accessor for the tty device name, so we fiddle +# with the window title options until it says what we want. +# +# 10.5: +# There _is_ a direct accessor for the tty device name, _and_ there's +# a new possible component of the window title (the name of the settings +# set). A separate version is needed. + +my @script_versions= + + ([237, <<'__LEOPARD__'], +tell application "Terminal" + do script "clear;exec sleep 100000" + tell first tab of first window + copy tty to thetty + set custom title to "forked perl debugger" + set title displays custom title to true + repeat while (length of first paragraph of (get contents)) > 0 + delay 0.1 + end repeat + end tell +end tell +thetty +__LEOPARD__ + + [100, <<'__JAGUAR_TIGER__'], +tell application "Terminal" + do script "clear;exec sleep 100000" + tell first window + set title displays shell path to false + set title displays window size to false + set title displays file name to false + set title displays device name to true + set title displays custom title to true + set custom title to "" + copy "/dev/" & name to thetty + set custom title to "forked perl debugger" + repeat while (length of first paragraph of (get contents)) > 0 + delay 0.1 + end repeat + end tell +end tell +thetty +__JAGUAR_TIGER__ + +); + +sub macosx_get_fork_TTY +{ + my($version,$script,$pipe,$tty); + + return unless $version=$ENV{TERM_PROGRAM_VERSION}; + foreach my $entry (@script_versions) { + if ($version>=$entry->[0]) { + $script=$entry->[1]; + last; + } + } + return unless defined($script); + return unless open($pipe,'-|','/usr/bin/osascript','-e',$script); + $tty=readline($pipe); + close($pipe); + return unless defined($tty) && $tty =~ m(^/dev/); + chomp $tty; + return $tty; +} + + +sub tmux_get_fork_TTY { + return unless $ENV{TMUX}; + + my $pipe; + + my $status = open $pipe, '-|', 'tmux', 'split-window', + '-P', '-F', '#{pane_tty}', 'sleep 100000'; + + if ( !$status ) { + return; + } + + my $tty = <$pipe>; + close $pipe; + + if ( $tty ) { + chomp $tty; + + if ( !defined $term ) { + require Term::ReadLine; + if ( !$rl ) { + $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT ); + } + else { + $term = Term::ReadLine->new( 'perldb', $IN, $OUT ); + } + } + } + + return $tty; +} + + +use vars qw($fork_TTY); + +sub create_IN_OUT { # Create a window with IN/OUT handles redirected there + + # If we know how to get a new TTY, do it! $in will have + # the TTY name if get_fork_TTY works. + my $in = get_fork_TTY(@_) if defined &get_fork_TTY; + + # It used to be that + $in = $fork_TTY if defined $fork_TTY; # Backward compatibility + + if ( not defined $in ) { + my $why = shift; + + # We don't know how. + print_help(< Forked, but do not know how to create a new B. I<#########> +EOP + + # Forked debugger. + print_help(< Daughter session, do not know how to change a B. I<#########> + This may be an asynchronous session, so the parent debugger may be active. +EOP + + # Note that both debuggers are fighting over the same input. + print_help(< in B<\$DB::fork_TTY>, or define a function + B returning this. + + On I-like systems one can get the name of a I for the given window + by typing B, and disconnect the I from I by B. + +EOP + } ## end if (not defined $in) + elsif ( $in ne '' ) { + TTY($in); + } + else { + $console = ''; # Indicate no need to open-from-the-console + } + undef $fork_TTY; +} ## end sub create_IN_OUT + + +sub resetterm { # We forked, so we need a different TTY + + # Needs to be passed to create_IN_OUT() as well. + my $in = shift; + + # resetterm(2): got in here because of a system() starting a debugger. + # resetterm(1): just forked. + my $systemed = $in > 1 ? '-' : ''; + + # If there's already a list of pids, add this to the end. + if ($pids) { + $pids =~ s/\]/$systemed->$$]/; + } + + # No pid list. Time to make one. + else { + $pids = "[$term_pid->$$]"; + } + + # The prompt we're going to be using for this debugger. + $pidprompt = $pids; + + # We now 0wnz this terminal. + $term_pid = $$; + + # Just return if we're not supposed to try to create a new TTY. + return unless $CreateTTY & $in; + + # Try to create a new IN/OUT pair. + create_IN_OUT($in); +} ## end sub resetterm + + +sub readline { + + # Localize to prevent it from being smashed in the program being debugged. + local $.; + + # If there are stacked filehandles to read from ... + # (Handle it before the typeahead, because we may call source/etc. from + # the typeahead.) + while (@cmdfhs) { + + # Read from the last one in the stack. + my $line = CORE::readline( $cmdfhs[-1] ); + + # If we got a line ... + defined $line + ? ( print $OUT ">> $line" and return $line ) # Echo and return + : close pop @cmdfhs; # Pop and close + } ## end while (@cmdfhs) + + # Pull a line out of the typeahead if there's stuff there. + if (@typeahead) { + + # How many lines left. + my $left = @typeahead; + + # Get the next line. + my $got = shift @typeahead; + + # Print a message saying we got input from the typeahead. + local $\ = ''; + print $OUT "auto(-$left)", shift, $got, "\n"; + + # Add it to the terminal history (if possible). + $term->AddHistory($got) + if length($got) > 1 + and defined $term->Features->{addHistory}; + return $got; + } ## end if (@typeahead) + + # We really need to read some input. Turn off entry/exit trace and + # return value printing. + local $frame = 0; + local $doret = -2; + + # Nothing on the filehandle stack. Socket? + if ( ref $OUT and UNIVERSAL::isa( $OUT, 'IO::Socket::INET' ) ) { + + # Send anything we have to send. + $OUT->write( join( '', @_ ) ); + + # Receive anything there is to receive. + my $stuff = ''; + my $buf; + my $first_time = 1; + + while ($first_time or (length($buf) && ($stuff .= $buf) !~ /\n/)) + { + $first_time = 0; + $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?" + # XXX Don't know. You tell me. + } + + # What we got. + return $stuff; + } ## end if (ref $OUT and UNIVERSAL::isa... + + # No socket. Just read from the terminal. + else { + return $term->readline(@_); + } +} ## end sub readline + + +sub dump_option { + my ( $opt, $val ) = @_; + $val = option_val( $opt, 'N/A' ); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} ## end sub dump_option + +sub options2remember { + foreach my $k (@RememberOnROptions) { + $option{$k} = option_val( $k, 'N/A' ); + } + return %option; +} + + +sub option_val { + my ( $opt, $default ) = @_; + my $val; + + # Does this option exist, and is it a variable? + # If so, retrieve the value via the value in %optionVars. + if ( defined $optionVars{$opt} + and defined ${ $optionVars{$opt} } ) + { + $val = ${ $optionVars{$opt} }; + } + + # Does this option exist, and it's a subroutine? + # If so, call the subroutine via the ref in %optionAction + # and capture the value. + elsif ( defined $optionAction{$opt} + and defined &{ $optionAction{$opt} } ) + { + $val = &{ $optionAction{$opt} }(); + } + + # If there's an action or variable for the supplied option, + # but no value was set, use the default. + elsif (defined $optionAction{$opt} and not defined $option{$opt} + or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} } ) + { + $val = $default; + } + + # Otherwise, do the simple hash lookup. + else { + $val = $option{$opt}; + } + + # If the value isn't defined, use the default. + # Then return whatever the value is. + $val = $default unless defined $val; + $val; +} ## end sub option_val + + +sub parse_options { + my ($s) = @_; + local $\ = ''; + + my $option; + + # These options need a value. Don't allow them to be clobbered by accident. + my %opt_needs_val = map { ( $_ => 1 ) } qw{ + dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize + pager quote ReadLine recallCommand RemotePort ShellBang TTY CommandSet + }; + + while (length($s)) { + my $val_defaulted; + + # Clean off excess leading whitespace. + $s =~ s/^\s+// && next; + + # Options are always all word characters, followed by a non-word + # separator. + if ($s !~ s/^(\w+)(\W?)//) { + print {$OUT} "Invalid option '$s'\n"; + last; + } + my ( $opt, $sep ) = ( $1, $2 ); + + # Make sure that such an option exists. + my $matches = ( grep { /^\Q$opt/ && ( $option = $_ ) } @options ) + || ( grep { /^\Q$opt/i && ( $option = $_ ) } @options ); + + unless ($matches) { + print {$OUT} "Unknown option '$opt'\n"; + next; + } + if ($matches > 1) { + print {$OUT} "Ambiguous option '$opt'\n"; + next; + } + my $val; + + # '?' as separator means query, but must have whitespace after it. + if ( "?" eq $sep ) { + if ($s =~ /\A\S/) { + print {$OUT} "Option query '$opt?' followed by non-space '$s'\n" ; + + last; + } + + #&dump_option($opt); + } ## end if ("?" eq $sep) + + # Separator is whitespace (or just a carriage return). + # They're going for a default, which we assume is 1. + elsif ( $sep !~ /\S/ ) { + $val_defaulted = 1; + $val = "1"; # this is an evil default; make 'em set it! + } + + # Separator is =. Trying to set a value. + elsif ( $sep eq "=" ) { + + # If quoted, extract a quoted string. + if ($s =~ s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) { + my $quote = $1; + ( $val = $2 ) =~ s/\\([$quote\\])/$1/g; + } + + # Not quoted. Use the whole thing. Warn about 'option='. + else { + $s =~ s/^(\S*)//; + $val = $1; + print OUT qq(Option better cleared using $opt=""\n) + unless length $val; + } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) + + } ## end elsif ($sep eq "=") + + # "Quoted" with [], <>, or {}. + else { #{ to "let some poor schmuck bounce on the % key in B." + my ($end) = + "\\" . substr( ")]>}$sep", index( "([<{", $sep ), 1 ); #} + $s =~ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// + or print( $OUT "Unclosed option value '$opt$sep$_'\n" ), last; + ( $val = $1 ) =~ s/\\([\\$end])/$1/g; + } ## end else [ if ("?" eq $sep) + + # Exclude non-booleans from getting set to 1 by default. + if ( $opt_needs_val{$option} && $val_defaulted ) { + my $cmd = ( $CommandSet eq '580' ) ? 'o' : 'O'; + print {$OUT} +"Option '$opt' is non-boolean. Use '$cmd $option=VAL' to set, '$cmd $option?' to query\n"; + next; + } ## end if ($opt_needs_val{$option... + + # Save the option value. + $option{$option} = $val if defined $val; + + # Load any module that this option requires. + if ( defined($optionRequire{$option}) && defined($val) ) { + eval qq{ + local \$frame = 0; + local \$doret = -2; + require '$optionRequire{$option}'; + 1; + } || die $@ # XXX: shouldn't happen + } + + # Set it. + # Stick it in the proper variable if it goes in a variable. + if (defined($optionVars{$option}) && defined($val)) { + ${ $optionVars{$option} } = $val; + } + + # Call the appropriate sub if it gets set via sub. + if (defined($optionAction{$option}) + && defined (&{ $optionAction{$option} }) + && defined ($val)) + { + &{ $optionAction{$option} }($val); + } + + # Not initialization - echo the value we set it to. + dump_option($option) if ($OUT ne \*STDERR); + } ## end while (length) +} ## end sub parse_options + + +sub set_list { + my ( $stem, @list ) = @_; + my $val; + + # VAR_n: how many we have. Scalar assignment gets the number of items. + $ENV{"${stem}_n"} = @list; + + # Grab each item in the list, escape the backslashes, encode the non-ASCII + # as hex, and then save in the appropriate VAR_0, VAR_1, etc. + for my $i ( 0 .. $#list ) { + $val = $list[$i]; + $val =~ s/\\/\\\\/g; + no warnings 'experimental::regex_sets'; + $val =~ s/ ( (?[ [\000-\xFF] & [:^print:] ]) ) / + "\\0x" . unpack('H2',$1)/xaeg; + $ENV{"${stem}_$i"} = $val; + } ## end for $i (0 .. $#list) +} ## end sub set_list + + +sub get_list { + my $stem = shift; + my @list; + my $n = delete $ENV{"${stem}_n"}; + my $val; + for my $i ( 0 .. $n - 1 ) { + $val = delete $ENV{"${stem}_$i"}; + $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge; + push @list, $val; + } + @list; +} ## end sub get_list + + +sub catch { + $signal = 1; + return; # Put nothing on the stack - malloc/free land! +} + + +sub _db_warn { + my ($msg) = join( "", @_ ); + $msg .= ": $!\n" unless $msg =~ /\n$/; + local $\ = ''; + print $OUT $msg; +} ## end sub warn + +*warn = \&_db_warn; + + +sub reset_IN_OUT { + my $switch_li = $LINEINFO eq $OUT; + + # If there's a term and it's able to get a new tty, try to get one. + if ( $term and $term->Features->{newTTY} ) { + ( $IN, $OUT ) = ( shift, shift ); + $term->newTTY( $IN, $OUT ); + } + + # This term can't get a new tty now. Better luck later. + elsif ($term) { + _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n"); + } + + # Set the filehndles up as they were. + else { + ( $IN, $OUT ) = ( shift, shift ); + } + + # Unbuffer the output filehandle. + _autoflush($OUT); + + # Point LINEINFO to the same output filehandle if it was there before. + $LINEINFO = $OUT if $switch_li; +} ## end sub reset_IN_OUT + + +sub TTY { + + if ( @_ and $term and $term->Features->{newTTY} ) { + + # This terminal supports switching to a new TTY. + # Can be a list of two files, or on string containing both names, + # comma-separated. + # XXX Should this perhaps be an assignment from @_? + my ( $in, $out ) = shift; + if ( $in =~ /,/ ) { + + # Split list apart if supplied. + ( $in, $out ) = split /,/, $in, 2; + } + else { + + # Use the same file for both input and output. + $out = $in; + } + + # Open file onto the debugger's filehandles, if you can. + open IN, '<', $in or die "cannot open '$in' for read: $!"; + open OUT, '>', $out or die "cannot open '$out' for write: $!"; + + # Swap to the new filehandles. + reset_IN_OUT( \*IN, \*OUT ); + + # Save the setting for later. + return $tty = $in; + } ## end if (@_ and $term and $term... + + # Terminal doesn't support new TTY, or doesn't support readline. + # Can't do it now, try restarting. + if ($term and @_) { + _db_warn("Too late to set TTY, enabled on next 'R'!\n"); + } + + # Useful if done through PERLDB_OPTS: + $console = $tty = shift if @_; + + # Return whatever the TTY is. + $tty or $console; +} ## end sub TTY + + +sub noTTY { + if ($term) { + _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_; + } + $notty = shift if @_; + $notty; +} ## end sub noTTY + + +sub ReadLine { + if ($term) { + _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_; + } + $rl = shift if @_; + $rl; +} ## end sub ReadLine + + +sub RemotePort { + if ($term) { + _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + } + $remoteport = shift if @_; + $remoteport; +} ## end sub RemotePort + + +sub tkRunning { + if ( ${ $term->Features }{tkRunning} ) { + return $term->tkRunning(@_); + } + else { + local $\ = ''; + print $OUT "tkRunning not supported by current ReadLine package.\n"; + 0; + } +} ## end sub tkRunning + + +sub NonStop { + if ($term) { + _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n") + if @_; + } + $runnonstop = shift if @_; + $runnonstop; +} ## end sub NonStop + +sub DollarCaretP { + if ($term) { + _db_warn("Some flag changes could not take effect until next 'R'!\n") + if @_; + } + $^P = parse_DollarCaretP_flags(shift) if @_; + expand_DollarCaretP_flags($^P); +} + + +sub pager { + if (@_) { + $pager = shift; + $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/; + } + $pager; +} ## end sub pager + + +sub shellBang { + + # If we got an argument, meta-quote it, and add '\b' if it + # ends in a word character. + if (@_) { + $sh = quotemeta shift; + $sh .= "\\b" if $sh =~ /\w$/; + } + + # Generate the printable version for the help: + $psh = $sh; # copy it + $psh =~ s/\\b$//; # Take off trailing \b if any + $psh =~ s/\\(.)/$1/g; # De-escape + $psh; # return the printable version +} ## end sub shellBang + + +sub ornaments { + if ( defined $term ) { + + # We don't want to show warning backtraces, but we do want die() ones. + local $warnLevel = 0; + local $dieLevel = 1; + + # No ornaments if the terminal doesn't support them. + if (not $term->Features->{ornaments}) { + return ''; + } + + return (eval { $term->ornaments(@_) } || ''); + } + + # Use what was passed in if we can't determine it ourselves. + else { + $ornaments = shift; + + return $ornaments; + } + +} ## end sub ornaments + + +sub recallCommand { + + # If there is input, metaquote it. Add '\b' if it ends with a word + # character. + if (@_) { + $rc = quotemeta shift; + $rc .= "\\b" if $rc =~ /\w$/; + } + + # Build it into a printable version. + $prc = $rc; # Copy it + $prc =~ s/\\b$//; # Remove trailing \b + $prc =~ s/\\(.)/$1/g; # Remove escapes + return $prc; # Return the printable version +} ## end sub recallCommand + + +sub LineInfo { + if (@_) { + $lineinfo = shift; + + # If this is a valid "thing to be opened for output", tack a + # '>' onto the front. + my $stream = ( $lineinfo =~ /^(\+?\>|\|)/ ) ? $lineinfo : ">$lineinfo"; + + # If this is a pipe, the stream points to a slave editor. + $slave_editor = ( $stream =~ /^\|/ ); + + my $new_lineinfo_fh; + # Open it up and unbuffer it. + open ($new_lineinfo_fh , $stream ) + or _db_warn("Cannot open '$stream' for write"); + $LINEINFO = $new_lineinfo_fh; + _autoflush($LINEINFO); + } + + return $lineinfo; +} ## end sub LineInfo + + +sub list_modules { # versions + my %version; + my $file; + + # keys are the "as-loaded" name, values are the fully-qualified path + # to the file itself. + for ( keys %INC ) { + $file = $_; # get the module name + s,\.p[lm]$,,i; # remove '.pl' or '.pm' + s,/,::,g; # change '/' to '::' + s/^perl5db$/DB/; # Special case: debugger + # moves to package DB + s/^Term::ReadLine::readline$/readline/; # simplify readline + + # If the package has a $VERSION package global (as all good packages + # should!) decode it and save as partial message. + my $pkg_version = do { no strict 'refs'; ${ $_ . '::VERSION' } }; + if ( defined $pkg_version ) { + $version{$file} = "$pkg_version from "; + } + + # Finish up the message with the file the package came from. + $version{$file} .= $INC{$file}; + } ## end for (keys %INC) + + # Hey, dumpit() formats a hash nicely, so why not use it? + dumpit( $OUT, \%version ); +} ## end sub list_modules + + +use vars qw($pre580_help); +use vars qw($pre580_summary); + +sub sethelp { + + # XXX: make sure there are tabs between the command and explanation, + # or print_help will screw up your formatting if you have + # eeevil ornaments enabled. This is an insane mess. + + $help = " +Help is currently only available for the new 5.8 command set. +No help is available for the old command set. +We assume you know what you're doing if you switch to it. + +B Stack trace. +B [I] Single step [in I]. +B [I] Next, steps over subroutine calls [in I]. +> Repeat last B or B command. +B Return from current subroutine. +B [I|I] Continue; optionally inserts a one-time-only breakpoint + at the specified position. +B IB<+>I List I+1 lines starting at I. +B IB<->I List lines I through I. +B I List single I. +B I List first window of lines from subroutine. +B I<\$var> List first window of lines from subroutine referenced by I<\$var>. +B List next window of lines. +B<-> List previous window of lines. +B [I] View window around I. +B<.> Return to the executed line. +B I Switch to viewing I. File must be already loaded. + I may be either the full name of the file, or a regular + expression matching the full file name: + B I and B I may access the same file. + Evals (with saved bodies) are considered to be filenames: + B I<(eval 7)> and B I access the body of the 7th eval + (in the order of execution). +BIB Search forwards for I; final B is optional. +BIB Search backwards for I; final B is optional. +B [I] List actions and or breakpoints and or watch-expressions. +B [[B]I] List subroutine names [not] matching I. +B [I] Toggle trace mode (to max I levels below current stack depth). +B [I] I Trace through execution of I. +B Sets breakpoint on current line) +B [I] [I] + Set breakpoint; I defaults to the current execution line; + I breaks if it evaluates to true, defaults to '1'. +B I [I] + Set breakpoint at first line of subroutine. +B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. +B B I Set breakpoint on 'require'ing the given file. +B B I [I] + Set breakpoint at first line of subroutine after + it is compiled. +B B I + Stop after the subroutine is compiled. +B [I] Delete the breakpoint for I. +B I<*> Delete all breakpoints. +B [I] I + Set an action to be done before the I is executed; + I defaults to the current execution line. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute line. +B Does nothing +B [I] Delete the action for I. +B I<*> Delete all actions. +B I Add a global watch-expression. +B Does nothing +B I Delete a global watch-expression. +B I<*> Delete all watch-expressions. +B [I [I]] List some (default all) variables in package (default current). + Use B<~>I and BI for positive and negative regexps. +B [I] Same as \"B I [I]\". +B I Evals expression in list context, dumps the result. +B I Evals expression in list context, prints methods callable + on the first element of the result. +B I Prints methods callable via the given class. +B Show versions of loaded modules. +B I Prints nested parents of given class. +B Display current thread id. +B Display all thread ids the current one will be identified: . +B [I [I]] List lexicals in higher scope . Vars same as B. + +B<<> ? List Perl commands to run before each prompt. +B<<> I Define Perl command to run before each prompt. +B<<<> I Add to the list of Perl commands to run before each prompt. +B<< *> Delete the list of perl commands to run before each prompt. +B<>> ? List Perl commands to run after each prompt. +B<>> I Define Perl command to run after each prompt. +B<>>B<>> I Add to the list of Perl commands to run after each prompt. +B<>>B< *> Delete the list of Perl commands to run after each prompt. +B<{> I Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<{{> I Add to the list of debugger commands to run before each prompt. +B<{ *> Delete the list of debugger commands to run before each prompt. +B<$prc> I Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I Redo last command that started with I. + See 'B I' too. +B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + . ( + $rc eq $sh + ? "" + : " +B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." + ) . " + See 'B I' too. +B I Execute I containing debugger commands (may nest). +B I Save current debugger session (actual history) to I. +B Rerun session to current position. +B I Rerun session to numbered command. +B I<-n> Rerun session to number'th-to-last command. +B I<-number> Display last number commands (default all). +B I<*> Delete complete history. +B

I Print expression (uses script's current package). + B [[B]I] List subroutine names [not] matching pattern + B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. + B [I] Same as \"B I [I]\". B I inheritance tree. + B [I [I]] List lexicals in higher scope . Vars same as B. + B Display thread id B Display all thread ids. +For more help, type B I, or run B<$doccmd perldebug> for all docs. +END_SUM + + # ')}}; # Fix balance of vi % matching + + # and this is really numb... + $pre580_help = " +B Stack trace. +B [I] Single step [in I]. +B [I] Next, steps over subroutine calls [in I]. +B> Repeat last B or B command. +B Return from current subroutine. +B [I|I] Continue; optionally inserts a one-time-only breakpoint + at the specified position. +B IB<+>I List I+1 lines starting at I. +B IB<->I List lines I through I. +B I List single I. +B I List first window of lines from subroutine. +B I<\$var> List first window of lines from subroutine referenced by I<\$var>. +B List next window of lines. +B<-> List previous window of lines. +B [I] List window around I. +B<.> Return to the executed line. +B I Switch to viewing I. File must be already loaded. + I may be either the full name of the file, or a regular + expression matching the full file name: + B I and B I may access the same file. + Evals (with saved bodies) are considered to be filenames: + B I<(eval 7)> and B I access the body of the 7th eval + (in the order of execution). +BIB Search forwards for I; final B is optional. +BIB Search backwards for I; final B is optional. +B List all breakpoints and actions. +B [[B]I] List subroutine names [not] matching I. +B [I] Toggle trace mode (to max I levels below current stack depth) . +B [I] I Trace through execution of I. +B [I] [I] + Set breakpoint; I defaults to the current execution line; + I breaks if it evaluates to true, defaults to '1'. +B I [I] + Set breakpoint at first line of subroutine. +B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. +B B I Set breakpoint on 'require'ing the given file. +B B I [I] + Set breakpoint at first line of subroutine after + it is compiled. +B B I + Stop after the subroutine is compiled. +B [I] Delete the breakpoint for I. +B Delete all breakpoints. +B [I] I + Set an action to be done before the I is executed; + I defaults to the current execution line. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute line. +B [I] Delete the action for I. +B Delete all actions. +B I Add a global watch-expression. +B Delete all watch-expressions. +B [I [I]] List some (default all) variables in package (default current). + Use B<~>I and BI for positive and negative regexps. +B [I] Same as \"B I [I]\". +B I Evals expression in list context, dumps the result. +B I Evals expression in list context, prints methods callable + on the first element of the result. +B I Prints methods callable via the given class. + +B<<> ? List Perl commands to run before each prompt. +B<<> I Define Perl command to run before each prompt. +B<<<> I Add to the list of Perl commands to run before each prompt. +B<>> ? List Perl commands to run after each prompt. +B<>> I Define Perl command to run after each prompt. +B<>>B<>> I Add to the list of Perl commands to run after each prompt. +B<{> I Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<{{> I Add to the list of debugger commands to run before each prompt. +B<$prc> I Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I Redo last command that started with I. + See 'B I' too. +B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + . ( + $rc eq $sh + ? "" + : " +B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." + ) . " + See 'B I' too. +B I Execute I containing debugger commands (may nest). +B I<-number> Display last number commands (default all). +B

I Same as \"I\" in current package. +B<|>I Run debugger command, piping DB::OUT to current pager. +B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. +B<\=> [I I] Define a command alias, or list current aliases. +I Execute as a perl statement in current package. +B Show versions of loaded modules. +B Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following settings are preserved: + history, breakpoints and actions, debugger Bptions + and the following command-line options: I<-w>, I<-I>, I<-e>. + +B [I] ... Set boolean option to true +B [IB] Query options +B [IB<=>I] [I=B<\">IB<\">] ... + Set options. Use quotes if spaces in value. + I, I chars used to recall command or spawn shell; + I program for output of \"|cmd\"; + I run Tk while prompting (with ReadLine); + I I I level of verbosity; + I Allows stepping off the end of the script. + I Debugger should stop as early as possible. + I Remote hostname:port for remote debugging + The following options affect what happens with B, B, and B commands: + I, I print only first N elements ('' for all); + I, I change style of array and hash dump; + I whether to print contents of globs; + I dump arrays holding debugged files; + I dump symbol tables of packages; + I dump contents of \"reused\" addresses; + I, I, I change style of string dump; + I Do not print the overload-stringified value; + Other options include: + I affects printing of return value after B command, + I affects printing messages on subroutine entry/exit. + I affects printing messages on possible breaking points. + I gives max length of evals/args listed in stack trace. + I affects screen appearance of the command line. + I bits control attempts to create a new TTY on events: + 1: on fork() 2: debugger is started inside debugger + 4: on startup + During startup options are initialized from \$ENV{PERLDB_OPTS}. + You can put additional initialization options I, I, + I, I, and I there (or use + B after you set them). + +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. +B [I] Get help [on a specific debugger command], enter B<|h> to page. +B Summary of debugger commands. +B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the + named Perl I, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. + +Type '|h' for a paged display if this was too hard to read. + +"; # Fix balance of vi % matching: }}}} + + # note: tabs in the following section are not-so-helpful + $pre580_summary = <<"END_SUM"; +I I + B [I|I] List source code B Stack trace + B<-> or B<.> List previous/current line B [I] Single step [in expr] + B [I] List around line B [I] Next, steps over subs + B I View source in file /B> Repeat last B or B + BIB BIB Search forw/backw B Return from subroutine + B Show versions of modules B [I|I] Continue until position +I B List break/watch/actions + B [...] Set debugger options B [I] Toggle trace [trace expr] + B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint + B<$prc> [I|I] Redo a previous command B [I] or B Delete a/all breakpoints + B [I<-num>] Display last num commands B [I] I Do cmd before line + B<=> [I I] Define/list an alias B I Add a watch expression + B [I] Get help on command B or B Delete all actions/watch + B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess + B or B<^D> Quit B Attempt a restart +I B Execute perl code, also see: B,B,B I + B|B I Evals expr in list context, dumps the result or lists methods. + B

I Print expression (uses script's current package). + B [[B]I] List subroutine names [not] matching pattern + B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. + B [I] Same as \"B I [I]\". + B [I [I]] List lexicals in higher scope . Vars same as B. +For more help, type B I, or run B<$doccmd perldebug> for all docs. +END_SUM + + # ')}}; # Fix balance of vi % matching + +} ## end sub sethelp + + +sub print_help { + my $help_str = shift; + + # Restore proper alignment destroyed by eeevil I<> and B<> + # ornaments: A pox on both their houses! + # + # A help command will have everything up to and including + # the first tab sequence padded into a field 16 (or if indented 20) + # wide. If it's wider than that, an extra space will be added. + $help_str =~ s{ + ^ # only matters at start of line + ( \ {4} | \t )* # some subcommands are indented + ( < ? # so works + [BI] < [^\t\n] + ) # find an eeevil ornament + ( \t+ ) # original separation, discarded + ( .* ) # this will now start (no earlier) than + # column 16 + } { + my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4); + my $clean = $command; + $clean =~ s/[BI]<([^>]*)>/$1/g; + + # replace with this whole string: + ($leadwhite ? " " x 4 : "") + . $command + . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") + . $text; + + }mgex; + + $help_str =~ s{ # handle bold ornaments + B < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[2] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[3] + }gex; + + $help_str =~ s{ # handle italic ornaments + I < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[0] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[1] + }gex; + + local $\ = ''; + print {$OUT} $help_str; + + return; +} ## end sub print_help + + +use vars qw($fixed_less); + +sub _calc_is_less { + if ($pager =~ /\bless\b/) + { + return 1; + } + elsif ($pager =~ /\bmore\b/) + { + # Nope, set to more. See what's out there. + my @st_more = stat('/usr/bin/more'); + my @st_less = stat('/usr/bin/less'); + + # is it really less, pretending to be more? + return ( + @st_more + && @st_less + && $st_more[0] == $st_less[0] + && $st_more[1] == $st_less[1] + ); + } + else { + return; + } +} + +sub fix_less { + + # We already know if this is set. + return if $fixed_less; + + # changes environment! + # 'r' added so we don't do (slow) stats again. + $fixed_less = 1 if _calc_is_less(); + + return; +} ## end sub fix_less + + +sub diesignal { + + # No entry/exit messages. + local $frame = 0; + + # No return value prints. + local $doret = -2; + + # set the abort signal handling to the default (just terminate). + $SIG{'ABRT'} = 'DEFAULT'; + + # If we enter the signal handler recursively, kill myself with an + # abort signal (so we just terminate). + kill 'ABRT', $$ if $panic++; + + # If we can show detailed info, do so. + if ( defined &Carp::longmess ) { + + # Don't recursively enter the warn handler, since we're carping. + local $SIG{__WARN__} = ''; + + # Skip two levels before reporting traceback: we're skipping + # mydie and confess. + local $Carp::CarpLevel = 2; # mydie + confess + + # Tell us all about it. + _db_warn( Carp::longmess("Signal @_") ); + } + + # No Carp. Tell us about the signal as best we can. + else { + local $\ = ''; + print $DB::OUT "Got signal @_\n"; + } + + # Drop dead. + kill 'ABRT', $$; +} ## end sub diesignal + + +sub dbwarn { + + # No entry/exit trace. + local $frame = 0; + + # No return value printing. + local $doret = -2; + + # Turn off warn and die handling to prevent recursive entries to this + # routine. + local $SIG{__WARN__} = ''; + local $SIG{__DIE__} = ''; + + # Load Carp if we can. If $^S is false (current thing being compiled isn't + # done yet), we may not be able to do a require. + eval { require Carp } + if defined $^S; # If error/warning during compilation, + # require may be broken. + + # Use the core warn() unless Carp loaded OK. + CORE::warn( @_, + "\nCannot print stack trace, load with -MCarp option to see stack" ), + return + unless defined &Carp::longmess; + + # Save the current values of $single and $trace, and then turn them off. + my ( $mysingle, $mytrace ) = ( $single, $trace ); + $single = 0; + $trace = 0; + + # We can call Carp::longmess without its being "debugged" (which we + # don't want - we just want to use it!). Capture this for later. + my $mess = Carp::longmess(@_); + + # Restore $single and $trace to their original values. + ( $single, $trace ) = ( $mysingle, $mytrace ); + + # Use the debugger's own special way of printing warnings to print + # the stack trace message. + _db_warn($mess); +} ## end sub dbwarn + + +sub dbdie { + local $frame = 0; + local $doret = -2; + local $SIG{__DIE__} = ''; + local $SIG{__WARN__} = ''; + if ( $dieLevel > 2 ) { + local $SIG{__WARN__} = \&dbwarn; + _db_warn(@_); # Yell no matter what + return; + } + if ( $dieLevel < 2 ) { + die @_ if $^S; # in eval propagate + } + + # The code used to check $^S to see if compilation of the current thing + # hadn't finished. We don't do it anymore, figuring eval is pretty stable. + eval { require Carp }; + + die( @_, + "\nCannot print stack trace, load with -MCarp option to see stack" ) + unless defined &Carp::longmess; + + # We do not want to debug this chunk (automatic disabling works + # inside DB::DB, but not in Carp). Save $single and $trace, turn them off, + # get the stack trace from Carp::longmess (if possible), restore $signal + # and $trace, and then die with the stack trace. + my ( $mysingle, $mytrace ) = ( $single, $trace ); + $single = 0; + $trace = 0; + my $mess = "@_"; + { + + package Carp; # Do not include us in the list + eval { $mess = Carp::longmess(@_); }; + } + ( $single, $trace ) = ( $mysingle, $mytrace ); + die $mess; +} ## end sub dbdie + + +sub warnLevel { + if (@_) { + my $prevwarn = $SIG{__WARN__} unless $warnLevel; + $warnLevel = shift; + if ($warnLevel) { + $SIG{__WARN__} = \&DB::dbwarn; + } + elsif ($prevwarn) { + $SIG{__WARN__} = $prevwarn; + } else { + undef $SIG{__WARN__}; + } + } ## end if (@_) + $warnLevel; +} ## end sub warnLevel + + +sub dieLevel { + local $\ = ''; + if (@_) { + my $prevdie = $SIG{__DIE__} unless $dieLevel; + $dieLevel = shift; + if ($dieLevel) { + + # Always set it to dbdie() for non-zero values. + $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2; + + # No longer exists, so don't try to use it. + #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2; + + # If we've finished initialization, mention that stack dumps + # are enabled, If dieLevel is 1, we won't stack dump if we die + # in an eval(). + print $OUT "Stack dump during die enabled", + ( $dieLevel == 1 ? " outside of evals" : "" ), ".\n" + if $I_m_init; + + # XXX This is probably obsolete, given that diehard() is gone. + print $OUT "Dump printed too.\n" if $dieLevel > 2; + } ## end if ($dieLevel) + + # Put the old one back if there was one. + elsif ($prevdie) { + $SIG{__DIE__} = $prevdie; + print $OUT "Default die handler restored.\n"; + } else { + undef $SIG{__DIE__}; + print $OUT "Die handler removed.\n"; + } + } ## end if (@_) + $dieLevel; +} ## end sub dieLevel + + +sub signalLevel { + if (@_) { + my $prevsegv = $SIG{SEGV} unless $signalLevel; + my $prevbus = $SIG{BUS} unless $signalLevel; + $signalLevel = shift; + if ($signalLevel) { + $SIG{SEGV} = \&DB::diesignal; + $SIG{BUS} = \&DB::diesignal; + } + else { + $SIG{SEGV} = $prevsegv; + $SIG{BUS} = $prevbus; + } + } ## end if (@_) + $signalLevel; +} ## end sub signalLevel + + +sub CvGV_name { + my $in = shift; + my $name = CvGV_name_or_bust($in); + defined $name ? $name : $in; +} + + +use vars qw($skipCvGV); + +sub CvGV_name_or_bust { + my $in = shift; + return if $skipCvGV; # Backdoor to avoid problems if XS broken... + return unless ref $in; + $in = \&$in; # Hard reference... + eval { require Devel::Peek; 1 } or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} ## end sub CvGV_name_or_bust + + +sub _find_sub_helper { + my $subr = shift; + + return unless defined &$subr; + my $name = CvGV_name_or_bust($subr); + my $data; + $data = $sub{$name} if defined $name; + return $data if defined $data; + + # Old stupid way... + $subr = \&$subr; # Hard reference + my $s; + for ( keys %sub ) { + $s = $_, last if $subr eq \&$_; + } + if ($s) + { + return $sub{$s}; + } + else + { + return; + } + +} + +sub find_sub { + my $subr = shift; + return ( $sub{$subr} || _find_sub_helper($subr) ); +} ## end sub find_sub + + +use vars qw(%seen); + +sub methods { + + # Figure out the class - either this is the class or it's a reference + # to something blessed into that class. + my $class = shift; + $class = ref $class if ref $class; + + local %seen; + + # Show the methods that this class has. + methods_via( $class, '', 1 ); + + # Show the methods that UNIVERSAL has. + methods_via( 'UNIVERSAL', 'UNIVERSAL', 0 ); +} ## end sub methods + + +sub methods_via { + + # If we've processed this class already, just quit. + my $class = shift; + return if $seen{$class}++; + + # This is a package that is contributing the methods we're about to print. + my $prefix = shift; + my $prepend = $prefix ? "via $prefix: " : ''; + my @to_print; + + # Extract from all the symbols in this class. + my $class_ref = do { no strict "refs"; \%{$class . '::'} }; + while (my ($name, $glob) = each %$class_ref) { + # references directly in the symbol table are Proxy Constant + # Subroutines, and are by their very nature defined + # Otherwise, check if the thing is a typeglob, and if it is, it decays + # to a subroutine reference, which can be tested by defined. + # $glob might also be the value -1 (from sub foo;) + # or (say) '$$' (from sub foo ($$);) + # \$glob will be SCALAR in both cases. + if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob)) + && !$seen{$name}++) { + push @to_print, "$prepend$name\n"; + } + } + + { + local $\ = ''; + local $, = ''; + print $DB::OUT $_ foreach sort @to_print; + } + + # If the $crawl_upward argument is false, just quit here. + return unless shift; + + # $crawl_upward true: keep going up the tree. + # Find all the classes this one is a subclass of. + my $class_ISA_ref = do { no strict "refs"; \@{"${class}::ISA"} }; + for my $name ( @$class_ISA_ref ) { + + # Set up the new prefix. + $prepend = $prefix ? $prefix . " -> $name" : $name; + + # Crawl up the tree and keep trying to crawl up. + methods_via( $name, $prepend, 1 ); + } +} ## end sub methods_via + + +sub setman { + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s + ? "man" # O Happy Day! + : "perldoc"; # Alas, poor unfortunates +} ## end sub setman + + +sub runman { + my $page = shift; + unless ($page) { + _db_system("$doccmd $doccmd"); + return; + } + + # this way user can override, like with $doccmd="man -Mwhatever" + # or even just "man " to disable the path check. + if ( $doccmd ne 'man' ) { + _db_system("$doccmd $page"); + return; + } + + $page = 'perl' if lc($page) eq 'help'; + + require Config; + my $man1dir = $Config::Config{man1direxp}; + my $man3dir = $Config::Config{man3direxp}; + for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ } + my $manpath = ''; + $manpath .= "$man1dir:" if $man1dir =~ /\S/; + $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir; + chop $manpath if $manpath; + + # harmless if missing, I figure + local $ENV{MANPATH} = $manpath if $manpath; + my $nopathopt = $^O =~ /dunno what goes here/; + if ( + CORE::system( + $doccmd, + + # I just *know* there are men without -M + ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), + split ' ', $page + ) + ) + { + unless ( $page =~ /^perl\w/ ) { + # Previously the debugger contained a list which it slurped in, + # listing the known "perl" manpages. However, it was out of date, + # with errors both of omission and inclusion. This approach is + # considerably less complex. The failure mode on a butchered + # install is simply that the user has to run man or perldoc + # "manually" with the full manpage name. + + # There is a list of $^O values in installperl to determine whether + # the directory is 'pods' or 'pod'. However, we can avoid tight + # coupling to that by simply checking the "non-standard" 'pods' + # first. + my $pods = "$Config::Config{privlibexp}/pods"; + $pods = "$Config::Config{privlibexp}/pod" + unless -d $pods; + if (-f "$pods/perl$page.pod") { + CORE::system( $doccmd, + ( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ), + "perl$page" ); + } + } + } ## end if (CORE::system($doccmd... +} ## end sub runman + +#use Carp; # This did break, left for debugging + + +# The following BEGIN is very handy if debugger goes havoc, debugging debugger? + +use vars qw($db_stop); + +BEGIN { # This does not compile, alas. (XXX eh?) + $IN = \*STDIN; # For bugs before DB::OUT has been opened + $OUT = \*STDERR; # For errors before DB::OUT has been opened + + # Define characters used by command parsing. + $sh = '!'; # Shell escape (does not work) + $rc = ','; # Recall command (does not work) + @hist = ('?'); # Show history (does not work) + @truehist = (); # Can be saved for replay (per session) + + # This defines the point at which you get the 'deep recursion' + # warning. It MUST be defined or the debugger will not load. + $deep = 1000; + + # Number of lines around the current one that are shown in the + # 'w' command. + $window = 10; + + # How much before-the-current-line context the 'v' command should + # use in calculating the start of the window it will display. + $preview = 3; + + # We're not in any sub yet, but we need this to be a defined value. + $sub = ''; + + # Set up the debugger's interrupt handler. It simply sets a flag + # ($signal) that DB::DB() will check before each command is executed. + $SIG{INT} = \&DB::catch; + + # The following lines supposedly, if uncommented, allow the debugger to + # debug itself. Perhaps we can try that someday. + # This may be enabled to debug debugger: + #$warnLevel = 1 unless defined $warnLevel; + #$dieLevel = 1 unless defined $dieLevel; + #$signalLevel = 1 unless defined $signalLevel; + + # This is the flag that says "a debugger is running, please call + # DB::DB and DB::sub". We will turn it on forcibly before we try to + # execute anything in the user's context, because we always want to + # get control back. + $db_stop = 0; # Compiler warning ... + $db_stop = 1 << 30; # ... because this is only used in an eval() later. + + # This variable records how many levels we're nested in debugging. Used + # Used in the debugger prompt, and in determining whether it's all over or + # not. + $level = 0; # Level of recursive debugging + + # "Triggers bug (?) in perl if we postpone this until runtime." + # XXX No details on this yet, or whether we should fix the bug instead + # of work around it. Stay tuned. + @stack = (0); + + # Used to track the current stack depth using the auto-stacked-variable + # trick. + $stack_depth = 0; # Localized repeatedly; simple way to track $#stack + + # Don't print return values on exiting a subroutine. + $doret = -2; + + # No extry/exit tracing. + $frame = 0; + +} ## end BEGIN + +BEGIN { $^W = $ini_warn; } # Switch warnings back + + +sub db_complete { + + # Specific code for b c l V m f O, &blah, $blah, @blah, %blah + # $text is the text to be completed. + # $line is the incoming line typed by the user. + # $start is the start of the text to be completed in the incoming line. + my ( $text, $line, $start ) = @_; + + # Save the initial text. + # The search pattern is current package, ::, extract the next qualifier + # Prefix and pack are set to undef. + my ( $itext, $search, $prefix, $pack ) = + ( $text, "^\Q${package}::\E([^:]+)\$" ); + + + return sort grep /^\Q$text/, ( keys %sub ), + qw(postpone load compile), # subroutines + ( map { /$search/ ? ($1) : () } keys %sub ) + if ( substr $line, 0, $start ) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/; + + + return sort grep /^\Q$text/, values %INC # files + if ( substr $line, 0, $start ) =~ /^\|*b\s+load\s+$/; + + + return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } + grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages + if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/; + + + return sort map { ( $_, db_complete( $_ . "::", "V ", 2 ) ) } + grep !/^main::/, grep /^\Q$text/, + map { /^(.*)::$/ ? ( $prefix . "::$1" ) : () } + do { no strict 'refs'; keys %{ $prefix . '::' } } + if ( substr $line, 0, $start ) =~ /^\|*[Vm]\s+$/ + and $text =~ /^(.*[^:])::?(\w*)$/ + and $prefix = $1; + + + if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files + # We might possibly want to switch to an eval (which has a "filename" + # like '(eval 9)'), so we may need to clean up the completion text + # before proceeding. + $prefix = length($1) - length($text); + $text = $1; + + + return sort + map { substr $_, 2 + $prefix } grep /^_<\Q$text/, ( keys %main:: ), + $0; + } ## end if ($line =~ /^\|*f\s+(.*)/) + + + if ( ( substr $text, 0, 1 ) eq '&' ) { # subroutines + $text = substr $text, 1; + $prefix = "&"; + return sort map "$prefix$_", grep /^\Q$text/, ( keys %sub ), + ( + map { /$search/ ? ($1) : () } + keys %sub + ); + } ## end if ((substr $text, 0, ... + + + if ( $text =~ /^[\$@%](.*)::(.*)/ ) { # symbols in a package + + + $pack = ( $1 eq 'main' ? '' : $1 ) . '::'; + + + $prefix = ( substr $text, 0, 1 ) . $1 . '::'; + $text = $2; + + + my @out = do { + no strict 'refs'; + map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, + keys %$pack; + }; + + + if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { + return db_complete( $out[0], $line, $start ); + } + + # Return the list of possibles. + return sort @out; + + } ## end if ($text =~ /^[\$@%](.*)::(.*)/) + + + if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main) + + $pack = ( $package eq 'main' ? '' : $package ) . '::'; + + + $prefix = substr $text, 0, 1; + $text = substr $text, 1; + + my @out; + + + if (not $text =~ /::/ and eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require PadWalker } ) { + my $level = 1; + while (1) { + my @info = caller($level); + $level++; + $level = -1, last + if not @info; + last if $info[3] eq 'DB::DB'; + } + if ($level > 0) { + my $lexicals = PadWalker::peek_my($level); + push @out, grep /^\Q$prefix$text/, keys %$lexicals; + } + } + + + push @out, map "$prefix$_", grep /^\Q$text/, + ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ), + ( $pack eq '::' ? () : ( grep /::$/, keys %:: ) ); + + + if ( @out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext ) { + return db_complete( $out[0], $line, $start ); + } + + # Return the list of possibles. + return sort @out; + } ## end if ($text =~ /^[\$@%]/) + + + if ( ( substr $line, 0, $start ) =~ /^\|*[oO]\b.*\s$/ ) + { # Options after space + # We look for the text to be matched in the list of possible options, + # and fetch the current value. + my @out = grep /^\Q$text/, @options; + my $val = option_val( $out[0], undef ); + + # Set up a 'query option's value' command. + my $out = '? '; + if ( not defined $val or $val =~ /[\n\r]/ ) { + + # There's really nothing else we can do. + } + + # We have a value. Create a proper option-setting command. + elsif ( $val =~ /\s/ ) { + + # XXX This may be an extraneous variable. + my $found; + + # We'll want to quote the string (because of the embedded + # whtespace), but we want to make sure we don't end up with + # mismatched quote characters. We try several possibilities. + foreach my $l ( split //, qq/\"\'\#\|/ ) { + + # If we didn't find this quote character in the value, + # quote it using this quote character. + $out = "$l$val$l ", last if ( index $val, $l ) == -1; + } + } ## end elsif ($val =~ /\s/) + + # Don't need any quotes. + else { + $out = "=$val "; + } + + # If there were multiple possible values, return '? ', which + # makes the command into a query command. If there was just one, + # have readline append that. + $rl_attribs->{completer_terminator_character} = + ( @out == 1 ? $out : '? ' ); + + # Return list of possibilities. + return sort @out; + } ## end if ((substr $line, 0, ... + + + return $term->filename_list($text); # filenames + +} ## end sub db_complete + + +sub end_report { + local $\ = ''; + print $OUT "Use 'q' to quit or 'R' to restart. 'h q' for details.\n"; +} + + +sub clean_ENV { + if ( defined($ini_pids) ) { + $ENV{PERLDB_PIDS} = $ini_pids; + } + else { + delete( $ENV{PERLDB_PIDS} ); + } +} ## end sub clean_ENV + +# PERLDBf_... flag names from perl.h +our ( %DollarCaretP_flags, %DollarCaretP_flags_r ); + +BEGIN { + %DollarCaretP_flags = ( + PERLDBf_SUB => 0x01, # Debug sub enter/exit + PERLDBf_LINE => 0x02, # Keep line # + PERLDBf_NOOPT => 0x04, # Switch off optimizations + PERLDBf_INTER => 0x08, # Preserve more data + PERLDBf_SUBLINE => 0x10, # Keep subr source lines + PERLDBf_SINGLE => 0x20, # Start with single-step on + PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr + PERLDBf_GOTO => 0x80, # Report goto: call DB::goto + PERLDBf_NAMEEVAL => 0x100, # Informative names for evals + PERLDBf_NAMEANON => 0x200, # Informative names for anon subs + PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"} + PERLDB_ALL => 0x33f, # No _NONAME, _GOTO + ); + # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger + # doesn't need to set it. It's provided for the benefit of profilers and + # other code analysers. + + %DollarCaretP_flags_r = reverse %DollarCaretP_flags; +} + +sub parse_DollarCaretP_flags { + my $flags = shift; + $flags =~ s/^\s+//; + $flags =~ s/\s+$//; + my $acu = 0; + foreach my $f ( split /\s*\|\s*/, $flags ) { + my $value; + if ( $f =~ /^0x([[:xdigit:]]+)$/ ) { + $value = hex $1; + } + elsif ( $f =~ /^(\d+)$/ ) { + $value = int $1; + } + elsif ( $f =~ /^DEFAULT$/i ) { + $value = $DollarCaretP_flags{PERLDB_ALL}; + } + else { + $f =~ /^(?:PERLDBf_)?(.*)$/i; + $value = $DollarCaretP_flags{ 'PERLDBf_' . uc($1) }; + unless ( defined $value ) { + print $OUT ( + "Unrecognized \$^P flag '$f'!\n", + "Acceptable flags are: " + . join( ', ', sort keys %DollarCaretP_flags ), + ", and hexadecimal and decimal numbers.\n" + ); + return undef; + } + } + $acu |= $value; + } + $acu; +} + +sub expand_DollarCaretP_flags { + my $DollarCaretP = shift; + my @bits = ( + map { + my $n = ( 1 << $_ ); + ( $DollarCaretP & $n ) + ? ( $DollarCaretP_flags_r{$n} + || sprintf( '0x%x', $n ) ) + : () + } 0 .. 31 + ); + return @bits ? join( '|', @bits ) : 0; +} + + +sub rerun { + my $i = shift; + my @args; + pop(@truehist); # strim + unless (defined $truehist[$i]) { + print "Unable to return to non-existent command: $i\n"; + } else { + $#truehist = ($i < 0 ? $#truehist + $i : $i > 0 ? $i : $#truehist); + my @temp = @truehist; # store + push(@DB::typeahead, @truehist); # saved + @truehist = @hist = (); # flush + @args = restart(); # setup + get_list("PERLDB_HIST"); # clean + set_list("PERLDB_HIST", @temp); # reset + } + return @args; +} + + +sub restart { + # I may not be able to resurrect you, but here goes ... + print $OUT +"Warning: some settings and command-line options may be lost!\n"; + my ( @script, @flags, $cl ); + + # If warn was on before, turn it on again. + push @flags, '-w' if $ini_warn; + + # Rebuild the -I flags that were on the initial + # command line. + for (@ini_INC) { + push @flags, '-I', $_; + } + + # Turn on taint if it was on before. + push @flags, '-T' if ${^TAINT}; + + # Arrange for setting the old INC: + # Save the current @init_INC in the environment. + set_list( "PERLDB_INC", @ini_INC ); + + # If this was a perl one-liner, go to the "file" + # corresponding to the one-liner read all the lines + # out of it (except for the first one, which is going + # to be added back on again when 'perl -d' runs: that's + # the 'require perl5db.pl;' line), and add them back on + # to the command line to be executed. + if ( $0 eq '-e' ) { + my $lines = *{$main::{'_<-e'}}{ARRAY}; + for ( 1 .. $#$lines ) { # The first line is PERL5DB + chomp( $cl = $lines->[$_] ); + push @script, '-e', $cl; + } + } ## end if ($0 eq '-e') + + # Otherwise we just reuse the original name we had + # before. + else { + @script = $0; + } + + + # If the terminal supported history, grab it and + # save that in the environment. + set_list( "PERLDB_HIST", + $term->Features->{getHistory} + ? $term->GetHistory + : @hist ); + + # Find all the files that were visited during this + # session (i.e., the debugger had magic hashes + # corresponding to them) and stick them in the environment. + my @had_breakpoints = keys %had_breakpoints; + set_list( "PERLDB_VISITED", @had_breakpoints ); + + # Save the debugger options we chose. + set_list( "PERLDB_OPT", %option ); + # set_list( "PERLDB_OPT", options2remember() ); + + # Save the break-on-loads. + set_list( "PERLDB_ON_LOAD", %break_on_load ); + + + # Go through all the breakpoints and make sure they're + # still valid. + my @hard; + for ( 0 .. $#had_breakpoints ) { + + # We were in this file. + my $file = $had_breakpoints[$_]; + + # Grab that file's magic line hash. + *dbline = $main::{ '_<' . $file }; + + # Skip out if it doesn't exist, or if the breakpoint + # is in a postponed file (we'll do postponed ones + # later). + next unless %dbline or $postponed_file{$file}; + + # In an eval. This is a little harder, so we'll + # do more processing on that below. + ( push @hard, $file ), next + if $file =~ /^\(\w*eval/; + + # XXX I have no idea what this is doing. Yet. + my @add; + @add = %{ $postponed_file{$file} } + if $postponed_file{$file}; + + # Save the list of all the breakpoints for this file. + set_list( "PERLDB_FILE_$_", %dbline, @add ); + + # Serialize the extra data %breakpoints_data hash. + # That's a bug fix. + set_list( "PERLDB_FILE_ENABLED_$_", + map { _is_breakpoint_enabled($file, $_) ? 1 : 0 } + sort { $a <=> $b } keys(%dbline) + ) + } ## end for (0 .. $#had_breakpoints) + + # The breakpoint was inside an eval. This is a little + # more difficult. XXX and I don't understand it. + foreach my $hard_file (@hard) { + # Get over to the eval in question. + *dbline = $main::{ '_<' . $hard_file }; + my $quoted = quotemeta $hard_file; + my %subs; + for my $sub ( keys %sub ) { + if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) { + $subs{$sub} = [ $n1, $n2 ]; + } + } + unless (%subs) { + print {$OUT} + "No subroutines in $hard_file, ignoring breakpoints.\n"; + next; + } + LINES: foreach my $line ( keys %dbline ) { + + # One breakpoint per sub only: + my ( $offset, $found ); + SUBS: foreach my $sub ( keys %subs ) { + if ( + $subs{$sub}->[1] >= $line # Not after the subroutine + and ( + not defined $offset # Not caught + or $offset < 0 + ) + ) + { # or badly caught + $found = $sub; + $offset = $line - $subs{$sub}->[0]; + if ($offset >= 0) { + $offset = "+$offset"; + last SUBS; + } + } ## end if ($subs{$sub}->[1] >=... + } ## end for $sub (keys %subs) + if ( defined $offset ) { + $postponed{$found} = + "break $offset if $dbline{$line}"; + } + else { + print {$OUT} + ("Breakpoint in ${hard_file}:$line ignored:" + . " after all the subroutines.\n"); + } + } ## end for $line (keys %dbline) + } ## end for (@hard) + + # Save the other things that don't need to be + # processed. + set_list( "PERLDB_POSTPONE", %postponed ); + set_list( "PERLDB_PRETYPE", @$pretype ); + set_list( "PERLDB_PRE", @$pre ); + set_list( "PERLDB_POST", @$post ); + set_list( "PERLDB_TYPEAHEAD", @typeahead ); + + # We are officially restarting. + $ENV{PERLDB_RESTART} = 1; + + # We are junking all child debuggers. + delete $ENV{PERLDB_PIDS}; # Restore ini state + + # Set this back to the initial pid. + $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids; + + + # And run Perl again. Add the "-d" flag, all the + # flags we built up, the script (whether a one-liner + # or a file), add on the -emacs flag for a slave editor, + # and then the old arguments. + + return ($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS); + +}; # end restart + + +END { + $finished = 1 if $inhibit_exit; # So that some commands may be disabled. + $fall_off_end = 1 unless $inhibit_exit; + + # Do not stop in at_exit() and destructors on exit: + if ($fall_off_end or $runnonstop) { + save_hist(); + } else { + $DB::single = 1; + DB::fake::at_exit(); + } +} ## end END + + +sub cmd_pre580_null { + + # do nothing... +} + + +sub cmd_pre580_a { + my $xcmd = shift; + my $cmd = shift; + + # Argument supplied. Add the action. + if ( $cmd =~ /^(\d*)\s*(.*)/ ) { + + # If the line isn't there, use the current line. + my $i = $1 || $line; + my $j = $2; + + # If there is an action ... + if ( length $j ) { + + # ... but the line isn't breakable, skip it. + if ( $dbline[$i] == 0 ) { + print $OUT "Line $i may not have an action.\n"; + } + else { + + # ... and the line is breakable: + # Mark that there's an action in this file. + $had_breakpoints{$filename} |= 2; + + # Delete any current action. + $dbline{$i} =~ s/\0[^\0]*//; + + # Add the new action, continuing the line as needed. + $dbline{$i} .= "\0" . action($j); + } + } ## end if (length $j) + + # No action supplied. + else { + + # Delete the action. + $dbline{$i} =~ s/\0[^\0]*//; + + # Mark as having no break or action if nothing's left. + delete $dbline{$i} if $dbline{$i} eq ''; + } + } ## end if ($cmd =~ /^(\d*)\s*(.*)/) +} ## end sub cmd_pre580_a + + +sub cmd_pre580_b { + my $xcmd = shift; + my $cmd = shift; + my $dbline = shift; + + # Break on load. + if ( $cmd =~ /^load\b\s*(.*)/ ) { + my $file = $1; + $file =~ s/\s+$//; + cmd_b_load($file); + } + + # b compile|postpone [] + # The interpreter actually traps this one for us; we just put the + # necessary condition in the %postponed hash. + elsif ( $cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) { + + # Capture the condition if there is one. Make it true if none. + my $cond = length $3 ? $3 : '1'; + + # Save the sub name and set $break to 1 if $1 was 'postpone', 0 + # if it was 'compile'. + my ( $subname, $break ) = ( $2, $1 eq 'postpone' ); + + # De-Perl4-ify the name - ' separators to ::. + $subname =~ s/\'/::/g; + + # Qualify it into the current package unless it's already qualified. + $subname = "${package}::" . $subname + unless $subname =~ /::/; + + # Add main if it starts with ::. + $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; + + # Save the break type for this sub. + $postponed{$subname} = $break ? "break +0 if $cond" : "compile"; + } ## end elsif ($cmd =~ ... + + # b [] + elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { + my $subname = $1; + my $cond = length $2 ? $2 : '1'; + cmd_b_sub( $subname, $cond ); + } + # b []. + elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) { + my $i = $1 || $dbline; + my $cond = length $2 ? $2 : '1'; + cmd_b_line( $i, $cond ); + } +} ## end sub cmd_pre580_b + + +sub cmd_pre580_D { + my $xcmd = shift; + my $cmd = shift; + if ( $cmd =~ /^\s*$/ ) { + print $OUT "Deleting all breakpoints...\n"; + + # %had_breakpoints lists every file that had at least one + # breakpoint in it. + my $file; + for $file ( keys %had_breakpoints ) { + + # Switch to the desired file temporarily. + local *dbline = $main::{ '_<' . $file }; + + $max = $#dbline; + my $was; + + # For all lines in this file ... + for my $i (1 .. $max) { + + # If there's a breakpoint or action on this line ... + if ( defined $dbline{$i} ) { + + # ... remove the breakpoint. + $dbline{$i} =~ s/^[^\0]+//; + if ( $dbline{$i} =~ s/^\0?$// ) { + + # Remove the entry altogether if no action is there. + delete $dbline{$i}; + } + } ## end if (defined $dbline{$i... + } ## end for my $i (1 .. $max) + + # If, after we turn off the "there were breakpoints in this file" + # bit, the entry in %had_breakpoints for this file is zero, + # we should remove this file from the hash. + if ( not $had_breakpoints{$file} &= ~1 ) { + delete $had_breakpoints{$file}; + } + } ## end for $file (keys %had_breakpoints) + + # Kill off all the other breakpoints that are waiting for files that + # haven't been loaded yet. + undef %postponed; + undef %postponed_file; + undef %break_on_load; + } ## end if ($cmd =~ /^\s*$/) +} ## end sub cmd_pre580_D + + +sub cmd_pre580_h { + my $xcmd = shift; + my $cmd = shift; + + # Print the *right* help, long format. + if ( $cmd =~ /^\s*$/ ) { + print_help($pre580_help); + } + + # 'h h' - explicitly-requested summary. + elsif ( $cmd =~ /^h\s*/ ) { + print_help($pre580_summary); + } + + # Find and print a command's help. + elsif ( $cmd =~ /^h\s+(\S.*)$/ ) { + my $asked = $1; # for proper errmsg + my $qasked = quotemeta($asked); # for searching + # XXX: finds CR but not + if ( + $pre580_help =~ /^ + is not a debugger command.\n"); + } + } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) +} ## end sub cmd_pre580_h + + +sub cmd_pre580_W { + my $xcmd = shift; + my $cmd = shift; + + # Delete all watch expressions. + if ( $cmd =~ /^$/ ) { + + # No watching is going on. + $trace &= ~2; + + # Kill all the watch expressions and values. + @to_watch = @old_watch = (); + } + + # Add a watch expression. + elsif ( $cmd =~ /^(.*)/s ) { + + # add it to the list to be watched. + push @to_watch, $1; + + # Get the current value of the expression. + # Doesn't handle expressions returning list values! + $evalarg = $1; + # The &-call is here to ascertain the mutability of @_. + my ($val) = &DB::eval; + $val = ( defined $val ) ? "'$val'" : 'undef'; + + # Save it. + push @old_watch, $val; + + # We're watching stuff. + $trace |= 2; + + } ## end elsif ($cmd =~ /^(.*)/s) +} ## end sub cmd_pre580_W + + +sub cmd_pre590_prepost { + my $cmd = shift; + my $line = shift || '*'; + my $dbline = shift; + + return cmd_prepost( $cmd, $line, $dbline ); +} ## end sub cmd_pre590_prepost + + +sub cmd_prepost { + my $cmd = shift; + + # No action supplied defaults to 'list'. + my $line = shift || '?'; + + # Figure out what to put in the prompt. + my $which = ''; + + # Make sure we have some array or another to address later. + # This means that if for some reason the tests fail, we won't be + # trying to stash actions or delete them from the wrong place. + my $aref = []; + + # < - Perl code to run before prompt. + if ( $cmd =~ /^\ - Perl code to run after prompt. + elsif ( $cmd =~ /^\>/o ) { + $which = 'post-perl'; + $aref = $post; + } + + # { - first check for properly-balanced braces. + elsif ( $cmd =~ /^\{/o ) { + if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) { + print $OUT +"$cmd is now a debugger command\nuse ';$cmd' if you mean Perl code\n"; + } + + # Properly balanced. Pre-prompt debugger actions. + else { + $which = 'pre-debugger'; + $aref = $pretype; + } + } ## end elsif ( $cmd =~ /^\{/o ) + + # Did we find something that makes sense? + unless ($which) { + print $OUT "Confused by command: $cmd\n"; + } + + # Yes. + else { + + # List actions. + if ( $line =~ /^\s*\?\s*$/o ) { + unless (@$aref) { + + # Nothing there. Complain. + print $OUT "No $which actions.\n"; + } + else { + + # List the actions in the selected list. + print $OUT "$which commands:\n"; + foreach my $action (@$aref) { + print $OUT "\t$cmd -- $action\n"; + } + } ## end else + } ## end if ( $line =~ /^\s*\?\s*$/o) + + # Might be a delete. + else { + if ( length($cmd) == 1 ) { + if ( $line =~ /^\s*\*\s*$/o ) { + + # It's a delete. Get rid of the old actions in the + # selected list.. + @$aref = (); + print $OUT "All $cmd actions cleared.\n"; + } + else { + + # Replace all the actions. (This is a <, >, or {). + @$aref = action($line); + } + } ## end if ( length($cmd) == 1) + elsif ( length($cmd) == 2 ) { + + # Add the action to the line. (This is a <<, >>, or {{). + push @$aref, action($line); + } + else { + + # <<<, >>>>, {{{{{{ ... something not a command. + print $OUT + "Confused by strange length of $which command($cmd)...\n"; + } + } ## end else [ if ( $line =~ /^\s*\?\s*$/o) + } ## end else +} ## end sub cmd_prepost + + +package DB::fake; + +sub at_exit { + "Debugged program terminated. Use 'q' to quit or 'R' to restart."; +} + +package DB; # Do not trace this 1; below! + +1; + + +package if; + +$VERSION = '0.0608'; + +sub work { + my $method = shift() ? 'import' : 'unimport'; + unless (@_ >= 2) { + my $type = ($method eq 'import') ? 'use' : 'no'; + die "Too few arguments to '$type if' (some code returning an empty list in list context?)" + } + return unless shift; # CONDITION + + my $p = $_[0]; # PACKAGE + (my $file = "$p.pm") =~ s!::!/!g; + require $file; # Works even if $_[0] is a keyword (like open) + my $m = $p->can($method); + goto &$m if $m; +} + +sub import { shift; unshift @_, 1; goto &work } +sub unimport { shift; unshift @_, 0; goto &work } + +1; +__END__ + +package FileCache; + +our $VERSION = '1.10'; + + +require 5.006; +use Carp; +use strict; +no strict 'refs'; + +# These are not C for legacy reasons. +# Previous versions requested the user set $cacheout_maxopen by hand. +# Some authors fiddled with %saw to overcome the clobber on initial open. +our %saw; +our $cacheout_maxopen = 16; + +use parent 'Exporter'; +our @EXPORT = qw[cacheout cacheout_close]; + + +my %isopen; +my $cacheout_seq = 0; + +sub import { + my ($pkg,%args) = @_; + + # Use Exporter. %args are for us, not Exporter. + # Make sure to up export_to_level, or we will import into ourselves, + # rather than our calling package; + + __PACKAGE__->export_to_level(1); + Exporter::import( $pkg ); + + # Truth is okay here because setting maxopen to 0 would be bad + return $cacheout_maxopen = $args{maxopen} if $args{maxopen}; + + # XXX This code is crazy. Why is it a one element foreach loop? + # Why is it using $param both as a filename and filehandle? + foreach my $param ( '/usr/include/sys/param.h' ){ + if (open($param, '<', $param)) { + local ($_, $.); + while (<$param>) { + if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){ + $cacheout_maxopen = $1 - 4; + close($param); + last; + } + } + close $param; + } + } + $cacheout_maxopen ||= 16; +} + +# Open in their package. +sub cacheout_open { + return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1]; +} + +# Close in their package. +sub cacheout_close { + # Short-circuit in case the filehandle disappeared + my $pkg = caller($_[1]||0); + defined fileno(*{$pkg . '::' . $_[0]}) && + CORE::close(*{$pkg . '::' . $_[0]}); + delete $isopen{$_[0]}; +} + +# But only this sub name is visible to them. +sub cacheout { + my($mode, $file, $class, $ret, $ref, $narg); + croak "Not enough arguments for cacheout" unless $narg = scalar @_; + croak "Too many arguments for cacheout" if $narg > 2; + + ($mode, $file) = @_; + ($file, $mode) = ($mode, $file) if $narg == 1; + croak "Invalid mode for cacheout" if $mode && + ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ ); + + # Mode changed? + if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){ + &cacheout_close($file, 1); + } + + if( $isopen{$file}) { + $ret = $file; + $isopen{$file}->[0]++; + } + else{ + if( scalar keys(%isopen) > $cacheout_maxopen -1 ) { + my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen); + $cacheout_seq = 0; + $isopen{$_}->[0] = $cacheout_seq++ for + splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen); + &cacheout_close($_, 1) for @lru; + } + + unless( $ref ){ + $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>'); + } + #XXX should we just return the value from cacheout_open, no croak? + $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!"); + + $isopen{$file} = [++$cacheout_seq, $mode]; + } + return $ret; +} +1; +package Digest; + +use strict; +use vars qw($VERSION %MMAP $AUTOLOAD); + +$VERSION = "1.17_01"; + +%MMAP = ( + "SHA-1" => [["Digest::SHA", 1], "Digest::SHA1", ["Digest::SHA2", 1]], + "SHA-224" => [["Digest::SHA", 224]], + "SHA-256" => [["Digest::SHA", 256], ["Digest::SHA2", 256]], + "SHA-384" => [["Digest::SHA", 384], ["Digest::SHA2", 384]], + "SHA-512" => [["Digest::SHA", 512], ["Digest::SHA2", 512]], + "HMAC-MD5" => "Digest::HMAC_MD5", + "HMAC-SHA-1" => "Digest::HMAC_SHA1", + "CRC-16" => [["Digest::CRC", type => "crc16"]], + "CRC-32" => [["Digest::CRC", type => "crc32"]], + "CRC-CCITT" => [["Digest::CRC", type => "crcccitt"]], + "RIPEMD-160" => "Crypt::RIPEMD160", +); + +sub new +{ + shift; # class ignored + my $algorithm = shift; + my $impl = $MMAP{$algorithm} || do { + $algorithm =~ s/\W+//g; + "Digest::$algorithm"; + }; + $impl = [$impl] unless ref($impl); + local $@; # don't clobber it for our caller + my $err; + for (@$impl) { + my $class = $_; + my @args; + ($class, @args) = @$class if ref($class); + no strict 'refs'; + unless (exists ${"$class\::"}{"VERSION"}) { + my $pm_file = $class . ".pm"; + $pm_file =~ s{::}{/}g; + eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require $pm_file + }; + if ($@) { + $err ||= $@; + next; + } + } + return $class->new(@args, @_); + } + die $err; +} + +sub AUTOLOAD +{ + my $class = shift; + my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); + $class->new($algorithm, @_); +} + +1; + +__END__ + +package utf8; + +$utf8::hint_bits = 0x00800000; + +our $VERSION = '1.21'; + +sub import { + $^H |= $utf8::hint_bits; +} + +sub unimport { + $^H &= ~$utf8::hint_bits; +} + +sub AUTOLOAD { + require "utf8_heavy.pl"; + goto &$AUTOLOAD if defined &$AUTOLOAD; + require Carp; + Carp::croak("Undefined subroutine $AUTOLOAD called"); +} + +1; +__END__ + +package overloading; +use warnings; + +our $VERSION = '0.02'; + +my $HINT_NO_AMAGIC = 0x01000000; # see perl.h + +require 5.010001; + +sub _ops_to_nums { + require overload::numbers; + + map { exists $overload::numbers::names{"($_"} + ? $overload::numbers::names{"($_"} + : do { require Carp; Carp::croak("'$_' is not a valid overload") } + } @_; +} + +sub import { + my ( $class, @ops ) = @_; + + if ( @ops ) { + if ( $^H{overloading} ) { + vec($^H{overloading} , $_, 1) = 0 for _ops_to_nums(@ops); + } + + if ( $^H{overloading} !~ /[^\0]/ ) { + delete $^H{overloading}; + $^H &= ~$HINT_NO_AMAGIC; + } + } else { + delete $^H{overloading}; + $^H &= ~$HINT_NO_AMAGIC; + } +} + +sub unimport { + my ( $class, @ops ) = @_; + + if ( exists $^H{overloading} or not $^H & $HINT_NO_AMAGIC ) { + if ( @ops ) { + vec($^H{overloading} ||= '', $_, 1) = 1 for _ops_to_nums(@ops); + } else { + delete $^H{overloading}; + } + } + + $^H |= $HINT_NO_AMAGIC; +} + +1; +__END__ + +package SelectSaver; + +our $VERSION = '1.02'; + + +require 5.000; +use Carp; +use Symbol; + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: SelectSaver->new( [FILEHANDLE] )'; + my $fh = select; + my $self = bless \$fh, $_[0]; + select qualify($_[1], caller) if @_ > 1; + $self; +} + +sub DESTROY { + my $self = $_[0]; + select $$self; +} + +1; +package bytes; + +our $VERSION = '1.06'; + +$bytes::hint_bits = 0x00000008; + +sub import { + $^H |= $bytes::hint_bits; +} + +sub unimport { + $^H &= ~$bytes::hint_bits; +} + +sub AUTOLOAD { + require "bytes_heavy.pl"; + goto &$AUTOLOAD if defined &$AUTOLOAD; + require Carp; + Carp::croak("Undefined subroutine $AUTOLOAD called"); +} + +sub length (_); +sub chr (_); +sub ord (_); +sub substr ($$;$$); +sub index ($$;$); +sub rindex ($$;$); + +1; +__END__ + +package experimental; +$experimental::VERSION = '0.019'; +use strict; +use warnings; +use version (); + +BEGIN { eval { require feature } }; +use Carp qw/croak carp/; + +my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets; +my %features = map { $_ => 1 } $] > 5.015006 ? keys %feature::feature : do { + my @features; + if ($] >= 5.010) { + push @features, qw/switch say state/; + push @features, 'unicode_strings' if $] > 5.011002; + } + @features; +}; + +my %min_version = ( + array_base => '5', + autoderef => '5.14.0', + bitwise => '5.22.0', + const_attr => '5.22.0', + current_sub => '5.16.0', + evalbytes => '5.16.0', + fc => '5.16.0', + lexical_topic => '5.10.0', + lexical_subs => '5.18.0', + postderef => '5.20.0', + postderef_qq => '5.20.0', + refaliasing => '5.22.0', + regex_sets => '5.18.0', + say => '5.10.0', + smartmatch => '5.10.0', + signatures => '5.20.0', + state => '5.10.0', + switch => '5.10.0', + unicode_eval => '5.16.0', + unicode_strings => '5.12.0', +); +my %max_version = ( + autoderef => '5.23.1', + lexical_topic => '5.23.4', +); + +$_ = version->new($_) for values %min_version; +$_ = version->new($_) for values %max_version; + +my %additional = ( + postderef => ['postderef_qq'], + switch => ['smartmatch'], +); + +sub _enable { + my $pragma = shift; + if ($warnings{"experimental::$pragma"}) { + warnings->unimport("experimental::$pragma"); + feature->import($pragma) if exists $features{$pragma}; + _enable(@{ $additional{$pragma} }) if $additional{$pragma}; + } + elsif ($features{$pragma}) { + feature->import($pragma); + _enable(@{ $additional{$pragma} }) if $additional{$pragma}; + } + elsif (not exists $min_version{$pragma}) { + croak "Can't enable unknown feature $pragma"; + } + elsif ($] < $min_version{$pragma}) { + my $stable = $min_version{$pragma}; + if ($stable->{version}[1] % 2) { + $stable = version->new( + "5.".($stable->{version}[1]+1).'.0' + ); + } + croak "Need perl $stable or later for feature $pragma"; + } + elsif ($] >= ($max_version{$pragma} || 7)) { + croak "Experimental feature $pragma has been removed from perl in version $max_version{$pragma}"; + } +} + +sub import { + my ($self, @pragmas) = @_; + + for my $pragma (@pragmas) { + _enable($pragma); + } + return; +} + +sub _disable { + my $pragma = shift; + if ($warnings{"experimental::$pragma"}) { + warnings->import("experimental::$pragma"); + feature->unimport($pragma) if exists $features{$pragma}; + _disable(@{ $additional{$pragma} }) if $additional{$pragma}; + } + elsif ($features{$pragma}) { + feature->unimport($pragma); + _disable(@{ $additional{$pragma} }) if $additional{$pragma}; + } + elsif (not exists $min_version{$pragma}) { + carp "Can't disable unknown feature $pragma, ignoring"; + } +} + +sub unimport { + my ($self, @pragmas) = @_; + + for my $pragma (@pragmas) { + _disable($pragma); + } + return; +} + +1; + +#ABSTRACT: Experimental features made easy + +__END__ + +package Test2; +use strict; +use warnings; + +our $VERSION = '1.302133'; + + +1; + +__END__ + +package utf8; +use strict; +use warnings; +use re "/aa"; # So we won't even try to look at above Latin1, potentially + # resulting in a recursive call + +sub DEBUG () { 0 } +$|=1 if DEBUG; + +sub DESTROY {} + +my %Cache; + +sub croak { require Carp; Carp::croak(@_) } + +sub _loose_name ($) { + # Given a lowercase property or property-value name, return its + # standardized version that is expected for look-up in the 'loose' hashes + # in Heavy.pl (hence, this depends on what mktables does). This squeezes + # out blanks, underscores and dashes. The complication stems from the + # grandfathered-in 'L_', which retains a single trailing underscore. + + (my $loose = $_[0]) =~ s/[-_ \t]//g; + + return $loose if $loose !~ / ^ (?: is | to )? l $/x; + return 'l_' if $_[0] =~ / l .* _ /x; # If original had a trailing '_' + return $loose; +} + +## +## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape. +## It's a data structure that encodes a set of Unicode characters. +## + +{ + # If a floating point number is within this distance from the value of a + # fraction, it is considered to be that fraction, even if many more digits + # are specified that don't exactly match. + my $min_floating_slop; + + # To guard against this program calling something that in turn ends up + # calling this program with the same inputs, and hence infinitely + # recursing, we keep a stack of the properties that are currently in + # progress, pushed upon entry, popped upon return. + my @recursed; + + sub SWASHNEW { + my ($class, $type, $list, $minbits, $none) = @_; + my $user_defined = 0; + local $^D = 0 if $^D; + + $class = "" unless defined $class; + print STDERR __LINE__, ": class=$class, type=$type, list=", + (defined $list) ? $list : ':undef:', + ", minbits=$minbits, none=$none\n" if DEBUG; + + ## + ## Get the list of codepoints for the type. + ## Called from swash_init (see utf8.c) or SWASHNEW itself. + ## + ## Callers of swash_init: + ## op.c:pmtrans -- for tr/// and y/// + ## regexec.c:regclass_swash -- for /[]/, \p, and \P + ## utf8.c:is_utf8_common -- for common Unicode properties + ## utf8.c:S__to_utf8_case -- for lc, uc, ucfirst, etc. and //i + ## Unicode::UCD::prop_invlist + ## Unicode::UCD::prop_invmap + ## + ## Given a $type, our goal is to fill $list with the set of codepoint + ## ranges. If $type is false, $list passed is used. + ## + ## $minbits: + ## For binary properties, $minbits must be 1. + ## For character mappings (case and transliteration), $minbits must + ## be a number except 1. + ## + ## $list (or that filled according to $type): + ## Refer to perlunicode.pod, "User-Defined Character Properties." + ## + ## For binary properties, only characters with the property value + ## of True should be listed. The 3rd column, if any, will be ignored + ## + ## $none is undocumented, so I'm (khw) trying to do some documentation + ## of it now. It appears to be if there is a mapping in an input file + ## that maps to 'XXXX', then that is replaced by $none+1, expressed in + ## hexadecimal. It is used somehow in tr///. + ## + ## To make the parsing of $type clear, this code takes the a rather + ## unorthodox approach of last'ing out of the block once we have the + ## info we need. Were this to be a subroutine, the 'last' would just + ## be a 'return'. + ## + # If a problem is found $type is returned; + # Upon success, a new (or cached) blessed object is returned with + # keys TYPE, BITS, EXTRAS, LIST, and NONE with values having the + # same meanings as the input parameters. + # SPECIALS contains a reference to any special-treatment hash in the + # property. + # INVERT_IT is non-zero if the result should be inverted before use + # USER_DEFINED is non-zero if the result came from a user-defined + my $file; ## file to load data from, and also part of the %Cache key. + + # Change this to get a different set of Unicode tables + my $unicore_dir = 'unicore'; + my $invert_it = 0; + my $list_is_from_mktables = 0; # Is $list returned from a mktables + # generated file? If so, we know it's + # well behaved. + + if ($type) + { + # Verify that this isn't a recursive call for this property. + # Can't use croak, as it may try to recurse to here itself. + my $class_type = $class . "::$type"; + if (grep { $_ eq $class_type } @recursed) { + CORE::die "panic: Infinite recursion in SWASHNEW for '$type'\n"; + } + push @recursed, $class_type; + + $type =~ s/^\s+//; + $type =~ s/\s+$//; + + # regcomp.c surrounds the property name with '__" and '_i' if this + # is to be caseless matching. + my $caseless = $type =~ s/^(.*)__(.*)_i$/$1$2/; + + print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG; + + GETFILE: + { + ## + ## It could be a user-defined property. Look in current + ## package if no package given + ## + + + my $caller0 = caller(0); + my $caller1 = $type =~ s/(.+)::// + ? $1 + : $caller0 eq 'main' + ? 'main' + : caller(1); + + if (defined $caller1 && $type =~ /^I[ns]\w+$/) { + my $prop = "${caller1}::$type"; + if (exists &{$prop}) { + # stolen from Scalar::Util::PP::tainted() + my $tainted; + { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + local $^W = 0; + no warnings; + eval { kill 0 * $prop }; + $tainted = 1 if $@ =~ /^Insecure/; + } + die "Insecure user-defined property \\p{$prop}\n" + if $tainted; + no strict 'refs'; + $list = &{$prop}($caseless); + $user_defined = 1; + last GETFILE; + } + } + + # During Perl's compilation, this routine may be called before + # the tables are constructed. If so, we have a chicken/egg + # problem. If we die, the tables never get constructed, so + # keep going, but return an empty table so only what the code + # has compiled in internally (currently ASCII/Latin1 range + # matching) will work. + BEGIN { + # Poor man's constant, to avoid a run-time check. + $utf8::{miniperl} + = \! defined &DynaLoader::boot_DynaLoader; + } + if (miniperl) { + eval "require '$unicore_dir/Heavy.pl'"; + if ($@) { + print STDERR __LINE__, ": '$@'\n" if DEBUG; + pop @recursed if @recursed; + return $type; + } + } + else { + require "$unicore_dir/Heavy.pl"; + } + BEGIN { delete $utf8::{miniperl} } + + # All property names are matched caselessly + my $property_and_table = CORE::lc $type; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + + # See if is of the compound form 'property=value', where the + # value indicates the table we should use. + my ($property, $table, @remainder) = + split /\s*[:=]\s*/, $property_and_table, -1; + if (@remainder) { + pop @recursed if @recursed; + return $type; + } + + my $prefix; + if (! defined $table) { + + # Here, is the single form. The property becomes empty, and + # the whole value is the table. + $table = $property; + $prefix = $property = ""; + } else { + print STDERR __LINE__, ": $property\n" if DEBUG; + + # Here it is the compound property=table form. The property + # name is always loosely matched, and always can have an + # optional 'is' prefix (which isn't true in the single + # form). + $property = _loose_name($property) =~ s/^is//r; + + # And convert to canonical form. Quit if not valid. + $property = $utf8::loose_property_name_of{$property}; + if (! defined $property) { + pop @recursed if @recursed; + return $type; + } + + $prefix = "$property="; + + # If the rhs looks like it is a number... + print STDERR __LINE__, ": table=$table\n" if DEBUG; + if ($table =~ m{ ^ [ \s 0-9 _ + / . -]+ $ }x) { + print STDERR __LINE__, ": table=$table\n" if DEBUG; + + # Don't allow leading nor trailing slashes + if ($table =~ / ^ \/ | \/ $ /x) { + pop @recursed if @recursed; + return $type; + } + + # Split on slash, in case it is a rational, like \p{1/5} + my @parts = split m{ \s* / \s* }x, $table, -1; + print __LINE__, ": $type\n" if @parts > 2 && DEBUG; + + # Can have maximum of one slash + if (@parts > 2) { + pop @recursed if @recursed; + return $type; + } + + foreach my $part (@parts) { + print __LINE__, ": part=$part\n" if DEBUG; + + $part =~ s/^\+\s*//; # Remove leading plus + $part =~ s/^-\s*/-/; # Remove blanks after unary + # minus + + # Remove underscores between digits. + $part =~ s/(?<= [0-9] ) _ (?= [0-9] ) //xg; + + # No leading zeros (but don't make a single '0' + # into a null string) + $part =~ s/ ^ ( -? ) 0+ /$1/x; + $part .= '0' if $part eq '-' || $part eq ""; + + # No trailing zeros after a decimal point + $part =~ s/ ( \. .*? ) 0+ $ /$1/x; + + # Begin with a 0 if a leading decimal point + $part =~ s/ ^ ( -? ) \. /${1}0./x; + + # Ensure not a trailing decimal point: turn into an + # integer + $part =~ s/ \. $ //x; + + print STDERR __LINE__, ": part=$part\n" if DEBUG; + #return $type if $part eq ""; + + # Result better look like a number. (This test is + # needed because, for example could have a plus in + # the middle.) + if ($part !~ / ^ -? [0-9]+ ( \. [0-9]+)? $ /x) { + pop @recursed if @recursed; + return $type; + } + } + + # If a rational... + if (@parts == 2) { + + # If denominator is negative, get rid of it, and ... + if ($parts[1] =~ s/^-//) { + + # If numerator is also negative, convert the + # whole thing to positive, else move the minus + # to the numerator + if ($parts[0] !~ s/^-//) { + $parts[0] = '-' . $parts[0]; + } + } + $table = join '/', @parts; + } + elsif ($property ne 'nv' || $parts[0] !~ /\./) { + + # Here is not numeric value, or doesn't have a + # decimal point. No further manipulation is + # necessary. (Note the hard-coded property name. + # This could fail if other properties eventually + # had fractions as well; perhaps the cjk ones + # could evolve to do that. This hard-coding could + # be fixed by mktables generating a list of + # properties that could have fractions.) + $table = $parts[0]; + } else { + + # Here is a floating point numeric_value. Try to + # convert to rational. First see if is in the list + # of known ones. + if (exists $utf8::nv_floating_to_rational{$parts[0]}) { + $table = $utf8::nv_floating_to_rational{$parts[0]}; + } else { + + # Here not in the list. See if is close + # enough to something in the list. First + # determine what 'close enough' means. It has + # to be as tight as what mktables says is the + # maximum slop, and as tight as how many + # digits we were passed. That is, if the user + # said .667, .6667, .66667, etc. we match as + # many digits as they passed until get to + # where it doesn't matter any more due to the + # machine's precision. If they said .6666668, + # we fail. + (my $fraction = $parts[0]) =~ s/^.*\.//; + my $epsilon = 10 ** - (length($fraction)); + if ($epsilon > $utf8::max_floating_slop) { + $epsilon = $utf8::max_floating_slop; + } + + # But it can't be tighter than the minimum + # precision for this machine. If haven't + # already calculated that minimum, do so now. + if (! defined $min_floating_slop) { + + # Keep going down an order of magnitude + # until find that adding this quantity to + # 1 remains 1; but put an upper limit on + # this so in case this algorithm doesn't + # work properly on some platform, that we + # won't loop forever. + my $count = 0; + $min_floating_slop = 1; + while (1+ $min_floating_slop != 1 + && $count++ < 50) + { + my $next = $min_floating_slop / 10; + last if $next == 0; # If underflows, + # use previous one + $min_floating_slop = $next; + print STDERR __LINE__, ": min_float_slop=$min_floating_slop\n" if DEBUG; + } + + # Back off a couple orders of magnitude, + # just to be safe. + $min_floating_slop *= 100; + } + + if ($epsilon < $min_floating_slop) { + $epsilon = $min_floating_slop; + } + print STDERR __LINE__, ": fraction=.$fraction; epsilon=$epsilon\n" if DEBUG; + + undef $table; + + # And for each possible rational in the table, + # see if it is within epsilon of the input. + foreach my $official + (keys %utf8::nv_floating_to_rational) + { + print STDERR __LINE__, ": epsilon=$epsilon, official=$official, diff=", abs($parts[0] - $official), "\n" if DEBUG; + if (abs($parts[0] - $official) < $epsilon) { + $table = + $utf8::nv_floating_to_rational{$official}; + last; + } + } + + # Quit if didn't find one. + if (! defined $table) { + pop @recursed if @recursed; + return $type; + } + } + } + print STDERR __LINE__, ": $property=$table\n" if DEBUG; + } + } + + # Combine lhs (if any) and rhs to get something that matches + # the syntax of the lookups. + $property_and_table = "$prefix$table"; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + + # First try stricter matching. + $file = $utf8::stricter_to_file_of{$property_and_table}; + + # If didn't find it, try again with looser matching by editing + # out the applicable characters on the rhs and looking up + # again. + my $strict_property_and_table; + if (! defined $file) { + + # This isn't used unless the name begins with 'to' + $strict_property_and_table = $property_and_table =~ s/^to//r; + $table = _loose_name($table); + $property_and_table = "$prefix$table"; + print STDERR __LINE__, ": $property_and_table\n" if DEBUG; + $file = $utf8::loose_to_file_of{$property_and_table}; + } + + # Add the constant and go fetch it in. + if (defined $file) { + + # If the file name contains a !, it means to invert. The + # 0+ makes sure result is numeric + $invert_it = 0 + $file =~ s/!//; + + if ($utf8::why_deprecated{$file}) { + warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};"); + } + + if ($caseless + && exists $utf8::caseless_equivalent{$property_and_table}) + { + $file = $utf8::caseless_equivalent{$property_and_table}; + } + + # The pseudo-directory '#' means that there really isn't a + # file to read, the data is in-line as part of the string; + # we extract it below. + $file = "$unicore_dir/lib/$file.pl" unless $file =~ m!^#/!; + last GETFILE; + } + print STDERR __LINE__, ": didn't find $property_and_table\n" if DEBUG; + + ## + ## Last attempt -- see if it's a standard "To" name + ## (e.g. "ToLower") ToTitle is used by ucfirst(). + ## The user-level way to access ToDigit() and ToFold() + ## is to use Unicode::UCD. + ## + # Only check if caller wants non-binary + if ($minbits != 1) { + if ($property_and_table =~ s/^to//) { + # Look input up in list of properties for which we have + # mapping files. First do it with the strict approach + if (defined ($file = $utf8::strict_property_to_file_of{ + $strict_property_and_table})) + { + $type = $utf8::file_to_swash_name{$file}; + print STDERR __LINE__, ": type set to $type\n" + if DEBUG; + $file = "$unicore_dir/$file.pl"; + last GETFILE; + } + elsif (defined ($file = + $utf8::loose_property_to_file_of{$property_and_table})) + { + $type = $utf8::file_to_swash_name{$file}; + print STDERR __LINE__, ": type set to $type\n" + if DEBUG; + $file = "$unicore_dir/$file.pl"; + last GETFILE; + } # If that fails see if there is a corresponding binary + # property file + elsif (defined ($file = + $utf8::loose_to_file_of{$property_and_table})) + { + + # Here, there is no map file for the property we + # are trying to get the map of, but this is a + # binary property, and there is a file for it that + # can easily be translated to a mapping, so use + # that, treating this as a binary property. + # Setting 'minbits' here causes it to be stored as + # such in the cache, so if someone comes along + # later looking for just a binary, they get it. + $minbits = 1; + + # The 0+ makes sure is numeric + $invert_it = 0 + $file =~ s/!//; + $file = "$unicore_dir/lib/$file.pl" + unless $file =~ m!^#/!; + last GETFILE; + } + } + } + + ## + ## If we reach this line, it's because we couldn't figure + ## out what to do with $type. Ouch. + ## + + pop @recursed if @recursed; + return $type; + } # end of GETFILE block + + if (defined $file) { + print STDERR __LINE__, ": found it (file='$file')\n" if DEBUG; + + ## + ## If we reach here, it was due to a 'last GETFILE' above + ## (exception: user-defined properties and mappings), so we + ## have a filename, so now we load it if we haven't already. + + # The pseudo-directory '#' means the result isn't really a + # file, but is in-line, with semi-colons to be turned into + # new-lines. Since it is in-line there is no advantage to + # caching the result + if ($file =~ s!^#/!!) { + $list = $utf8::inline_definitions[$file]; + } + else { + # Here, we have an actual file to read in and load, but it + # may already have been read-in and cached. The cache key + # is the class and file to load, and whether the results + # need to be inverted. + my $found = $Cache{$class, $file, $invert_it}; + if ($found and ref($found) eq $class) { + print STDERR __LINE__, ": Returning cached swash for '$class,$file,$invert_it' for \\p{$type}\n" if DEBUG; + pop @recursed if @recursed; + return $found; + } + + local $@; + local $!; + $list = do $file; die $@ if $@; + } + + $list_is_from_mktables = 1; + } + } # End of $type is non-null + + # Here, either $type was null, or we found the requested property and + # read it into $list + + my $extras = ""; + + my $bits = $minbits; + + # mktables lists don't have extras, like '&utf8::prop', so don't need + # to separate them; also lists are already sorted, so don't need to do + # that. + if ($list && ! $list_is_from_mktables) { + my $taint = substr($list,0,0); # maintain taint + + # Separate the extras from the code point list, and make sure + # user-defined properties and tr/// are well-behaved for + # downstream code. + if ($user_defined || $none) { + my @tmp = split(/^/m, $list); + my %seen; + no warnings; + + # The extras are anything that doesn't begin with a hex digit. + $extras = join '', $taint, grep /^[^0-9a-fA-F]/, @tmp; + + # Remove the extras, and sort the remaining entries by the + # numeric value of their beginning hex digits, removing any + # duplicates. + $list = join '', $taint, + map { $_->[1] } + sort { $a->[0] <=> $b->[0] } + map { /^([0-9a-fA-F]+)/ && !$seen{$1}++ ? [ CORE::hex($1), $_ ] : () } + @tmp; # XXX doesn't do ranges right + } + else { + # mktables has gone to some trouble to make non-user defined + # properties well-behaved, so we can skip the effort we do for + # user-defined ones. Any extras are at the very beginning of + # the string. + + # This regex splits out the first lines of $list into $1 and + # strips them off from $list, until we get one that begins + # with a hex number, alone on the line, or followed by a tab. + # Either portion may be empty. + $list =~ s/ \A ( .*? ) + (?: \z | (?= ^ [0-9a-fA-F]+ (?: \t | $) ) ) + //msx; + + $extras = "$taint$1"; + } + } + + if ($none) { + my $hextra = sprintf "%04x", $none + 1; + $list =~ s/\tXXXX$/\t$hextra/mg; + } + + if ($minbits != 1 && $minbits < 32) { # not binary property + my $top = 0; + while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { + my $min = CORE::hex $1; + my $max = defined $2 ? CORE::hex $2 : $min; + my $val = defined $3 ? CORE::hex $3 : 0; + $val += $max - $min if defined $3; + $top = $val if $val > $top; + } + my $topbits = + $top > 0xffff ? 32 : + $top > 0xff ? 16 : 8; + $bits = $topbits if $bits < $topbits; + } + + my @extras; + if ($extras) { + for my $x ($extras) { + my $taint = substr($x,0,0); # maintain taint + pos $x = 0; + while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { + my $char = "$1$taint"; + my $name = "$2$taint"; + print STDERR __LINE__, ": char [$char] => name [$name]\n" + if DEBUG; + if ($char =~ /[-+!&]/) { + my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really + my $subobj; + if ($c eq 'utf8') { + $subobj = utf8->SWASHNEW($t, "", $minbits, 0); + } + elsif (exists &$name) { + $subobj = utf8->SWASHNEW($name, "", $minbits, 0); + } + elsif ($c =~ /^([0-9a-fA-F]+)/) { + $subobj = utf8->SWASHNEW("", $c, $minbits, 0); + } + print STDERR __LINE__, ": returned from getting sub object for $name\n" if DEBUG; + if (! ref $subobj) { + pop @recursed if @recursed && $type; + return $subobj; + } + push @extras, $name => $subobj; + $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; + $user_defined = $subobj->{USER_DEFINED} + if $subobj->{USER_DEFINED}; + } + } + } + } + + if (DEBUG) { + print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none, INVERT_IT => $invert_it, USER_DEFINED => $user_defined"; + print STDERR "\nLIST =>\n$list" if defined $list; + print STDERR "\nEXTRAS =>\n$extras" if defined $extras; + print STDERR "\n"; + } + + my $SWASH = bless { + TYPE => $type, + BITS => $bits, + EXTRAS => $extras, + LIST => $list, + NONE => $none, + USER_DEFINED => $user_defined, + @extras, + } => $class; + + if ($file) { + $Cache{$class, $file, $invert_it} = $SWASH; + if ($type + && exists $utf8::SwashInfo{$type} + && exists $utf8::SwashInfo{$type}{'specials_name'}) + { + my $specials_name = $utf8::SwashInfo{$type}{'specials_name'}; + no strict "refs"; + print STDERR "\nspecials_name => $specials_name\n" if DEBUG; + $SWASH->{'SPECIALS'} = \%$specials_name; + } + $SWASH->{'INVERT_IT'} = $invert_it; + } + + pop @recursed if @recursed && $type; + + return $SWASH; + } +} + +# Now SWASHGET is recasted into a C function S_swatch_get (see utf8.c). + +1; +use 5.006_001; # for (defined ref) and $#$v and our +package Dumpvalue; +use strict; +our $VERSION = '1.18'; +our(%address, $stab, @stab, %stab, %subs); + +sub ASCII { return ord('A') == 65; } + +# This module will give incorrect results for some inputs on EBCDIC platforms +# before v5.8 +*to_native = ($] lt "5.008") + ? sub { return shift } + : sub { return utf8::unicode_to_native(shift) }; + +my $APC = chr to_native(0x9F); +my $backslash_c_question = (ASCII) ? '\177' : $APC; + +# documentation nits, handle complex data structures better by chromatic +# translate control chars to ^X - Randal Schwartz +# Modifications to print types by Peter Gordon v1.0 + +# Ilya Zakharevich -- patches after 5.001 (and some before ;-) + +# Won't dump symbol tables and contents of debugged files by default + +# (IZ) changes for objectification: +# c) quote() renamed to method set_quote(); +# d) unctrlSet() renamed to method set_unctrl(); +# f) Compiles with 'use strict', but in two places no strict refs is needed: +# maybe more problems are waiting... + +my %defaults = ( + globPrint => 0, + printUndef => 1, + tick => "auto", + unctrl => 'quote', + subdump => 1, + dumpReused => 0, + bareStringify => 1, + hashDepth => '', + arrayDepth => '', + dumpDBFiles => '', + dumpPackages => '', + quoteHighBit => '', + usageOnly => '', + compactDump => '', + veryCompact => '', + stopDbSignal => '', + ); + +sub new { + my $class = shift; + my %opt = (%defaults, @_); + bless \%opt, $class; +} + +sub set { + my $self = shift; + my %opt = @_; + @$self{keys %opt} = values %opt; +} + +sub get { + my $self = shift; + wantarray ? @$self{@_} : $$self{pop @_}; +} + +sub dumpValue { + my $self = shift; + die "usage: \$dumper->dumpValue(value)" unless @_ == 1; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + (print $self->stringify($_[0]), "\n"), return unless ref $_[0]; + $self->unwrap($_[0],0); +} + +sub dumpValues { + my $self = shift; + local %address; + local $^W=0; + (print "undef\n"), return unless defined $_[0]; + $self->unwrap(\@_,0); +} + +# This one is good for variable names: + +sub unctrl { + local($_) = @_; + + return \$_ if ref \$_ eq "GLOB"; + s/([\000-\037])/'^' . chr(to_native(ord($1)^64))/eg; + s/ $backslash_c_question /^?/xg; + $_; +} + +sub stringify { + my $self = shift; + local $_ = shift; + my $noticks = shift; + my $tick = $self->{tick}; + + return 'undef' unless defined $_ or not $self->{printUndef}; + return $_ . "" if ref \$_ eq 'GLOB'; + { no strict 'refs'; + $_ = &{'overload::StrVal'}($_) + if $self->{bareStringify} and ref $_ + and %overload:: and defined &{'overload::StrVal'}; + } + if ($tick eq 'auto') { + if (/[^[:^cntrl:]\n]/) { # All ASCII controls but \n get '"' + $tick = '"'; + } else { + $tick = "'"; + } + } + if ($tick eq "'") { + s/([\'\\])/\\$1/g; + } elsif ($self->{unctrl} eq 'unctrl') { + s/([\"\\])/\\$1/g ; + $_ = &unctrl($_); + s/([[:^ascii:]])/'\\0x'.sprintf('%2X',ord($1))/eg + if $self->{quoteHighBit}; + } elsif ($self->{unctrl} eq 'quote') { + s/([\"\\\$\@])/\\$1/g if $tick eq '"'; + s/\e/\\e/g; + s/([\000-\037$backslash_c_question])/'\\c'._escaped_ord($1)/eg; + } + s/([[:^ascii:]])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit}; + ($noticks || /^\d+(\.\d*)?\Z/) + ? $_ + : $tick . $_ . $tick; +} + +# Ensure a resulting \ is escaped to be \\ +sub _escaped_ord { + my $chr = shift; + if ($chr eq $backslash_c_question) { + $chr = '?'; + } + else { + $chr = chr(to_native(ord($chr)^64)); + $chr =~ s{\\}{\\\\}g; + } + return $chr; +} + +sub DumpElem { + my ($self, $v) = (shift, shift); + my $short = $self->stringify($v, ref $v); + my $shortmore = ''; + if ($self->{veryCompact} && ref $v + && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) { + my $depth = $#$v; + ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1) + if $self->{arrayDepth} and $depth >= $self->{arrayDepth}; + my @a = map $self->stringify($_), @$v[0..$depth]; + print "0..$#{$v} @a$shortmore\n"; + } elsif ($self->{veryCompact} && ref $v + && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) { + my @a = sort keys %$v; + my $depth = $#a; + ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1) + if $self->{hashDepth} and $depth >= $self->{hashDepth}; + my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})} + @a[0..$depth]; + local $" = ', '; + print "@b$shortmore\n"; + } else { + print "$short\n"; + $self->unwrap($v,shift); + } +} + +sub unwrap { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($v) = shift ; + my ($s) = shift ; # extra no of spaces + my $sp; + my (%v,@v,$address,$short,$fileno); + + $sp = " " x $s ; + $s += 3 ; + + # Check for reused addresses + if (ref $v) { + my $val = $v; + { no strict 'refs'; + $val = &{'overload::StrVal'}($v) + if %overload:: and defined &{'overload::StrVal'}; + } + ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ; + if (!$self->{dumpReused} && defined $address) { + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}-> REUSED_ADDRESS\n" ; + return ; + } + } + } elsif (ref \$v eq 'GLOB') { + $address = "$v" . ""; # To avoid a bug with globs + $address{$address}++ ; + if ( $address{$address} > 1 ) { + print "${sp}*DUMPED_GLOB*\n" ; + return ; + } + } + + if (ref $v eq 'Regexp') { + my $re = "$v"; + $re =~ s,/,\\/,g; + print "$sp-> qr/$re/\n"; + return; + } + + if ( UNIVERSAL::isa($v, 'HASH') ) { + my @sortKeys = sort keys(%$v) ; + my $more; + my $tHashDepth = $#sortKeys ; + $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1 + unless $self->{hashDepth} eq '' ; + $more = "....\n" if $tHashDepth < $#sortKeys ; + my $shortmore = ""; + $shortmore = ", ..." if $tHashDepth < $#sortKeys ; + $#sortKeys = $tHashDepth ; + if ($self->{compactDump} && !grep(ref $_, values %{$v})) { + $short = $sp; + my @keys; + for (@sortKeys) { + push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_}); + } + $short .= join ', ', @keys; + $short .= $shortmore; + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $key (@sortKeys) { + return if $DB::signal and $self->{stopDbSignal}; + my $value = $ {$v}{$key} ; + print $sp, $self->stringify($key), " => "; + $self->DumpElem($value, $s); + } + print "$sp empty hash\n" unless @sortKeys; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) { + my $tArrayDepth = $#{$v} ; + my $more ; + $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1 + unless $self->{arrayDepth} eq '' ; + $more = "....\n" if $tArrayDepth < $#{$v} ; + my $shortmore = ""; + $shortmore = " ..." if $tArrayDepth < $#{$v} ; + if ($self->{compactDump} && !grep(ref $_, @{$v})) { + if ($#$v >= 0) { + $short = $sp . "0..$#{$v} " . + join(" ", + map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} (0..$tArrayDepth) + ) . "$shortmore"; + } else { + $short = $sp . "empty array"; + } + (print "$short\n"), return if length $short <= $self->{compactDump}; + } + for my $num (0 .. $tArrayDepth) { + return if $DB::signal and $self->{stopDbSignal}; + print "$sp$num "; + if (exists $v->[$num]) { + $self->DumpElem($v->[$num], $s); + } else { + print "empty slot\n"; + } + } + print "$sp empty array\n" unless @$v; + print "$sp$more" if defined $more ; + } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) { + print "$sp-> "; + $self->DumpElem($$v, $s); + } elsif ( UNIVERSAL::isa($v, 'CODE') ) { + print "$sp-> "; + $self->dumpsub(0, $v); + } elsif ( UNIVERSAL::isa($v, 'GLOB') ) { + print "$sp-> ",$self->stringify($$v,1),"\n"; + if ($self->{globPrint}) { + $s += 3; + $self->dumpglob('', $s, "{$$v}", $$v, 1); + } elsif (defined ($fileno = fileno($v))) { + print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" ); + } + } elsif (ref \$v eq 'GLOB') { + if ($self->{globPrint}) { + $self->dumpglob('', $s, "{$v}", $v, 1); + } elsif (defined ($fileno = fileno(\$v))) { + print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" ); + } + } +} + +sub matchvar { + $_[0] eq $_[1] or + ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and + ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/}); +} + +sub compactDump { + my $self = shift; + $self->{compactDump} = shift if @_; + $self->{compactDump} = 6*80-1 + if $self->{compactDump} and $self->{compactDump} < 2; + $self->{compactDump}; +} + +sub veryCompact { + my $self = shift; + $self->{veryCompact} = shift if @_; + $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact}; + $self->{veryCompact}; +} + +sub set_unctrl { + my $self = shift; + if (@_) { + my $in = shift; + if ($in eq 'unctrl' or $in eq 'quote') { + $self->{unctrl} = $in; + } else { + print "Unknown value for 'unctrl'.\n"; + } + } + $self->{unctrl}; +} + +sub set_quote { + my $self = shift; + if (@_ and $_[0] eq '"') { + $self->{tick} = '"'; + $self->{unctrl} = 'quote'; + } elsif (@_ and $_[0] eq 'auto') { + $self->{tick} = 'auto'; + $self->{unctrl} = 'quote'; + } elsif (@_) { # Need to set + $self->{tick} = "'"; + $self->{unctrl} = 'unctrl'; + } + $self->{tick}; +} + +sub dumpglob { + my $self = shift; + return if $DB::signal and $self->{stopDbSignal}; + my ($package, $off, $key, $val, $all) = @_; + local(*stab) = $val; + my $fileno; + if (($key !~ /^_{dumpDBFiles}) and defined $stab) { + print( (' ' x $off) . "\$", &unctrl($key), " = " ); + $self->DumpElem($stab, 3+$off); + } + if (($key !~ /^_{dumpDBFiles}) and @stab) { + print( (' ' x $off) . "\@$key = (\n" ); + $self->unwrap(\@stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if ($key ne "main::" && $key ne "DB::" && %stab + && ($self->{dumpPackages} or $key !~ /::$/) + && ($key !~ /^_{dumpDBFiles}) + && !($package eq "Dumpvalue" and $key eq "stab")) { + print( (' ' x $off) . "\%$key = (\n" ); + $self->unwrap(\%stab,3+$off) ; + print( (' ' x $off) . ")\n" ); + } + if (defined ($fileno = fileno(*stab))) { + print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" ); + } + if ($all) { + if (defined &stab) { + $self->dumpsub($off, $key); + } + } +} + +sub CvGV_name { + my $self = shift; + my $in = shift; + return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken... + $in = \&$in; # Hard reference... + eval {require Devel::Peek; 1} or return; + my $gv = Devel::Peek::CvGV($in) or return; + *$gv{PACKAGE} . '::' . *$gv{NAME}; +} + +sub dumpsub { + my $self = shift; + my ($off,$sub) = @_; + my $ini = $sub; + my $s; + $sub = $1 if $sub =~ /^\{\*(.*)\}$/; + my $subref = defined $1 ? \&$sub : \&$ini; + my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s}) + || (($s = $self->CvGV_name($subref)) && $DB::sub{$s}) + || ($self->{subdump} && ($s = $self->findsubs("$subref")) + && $DB::sub{$s}); + $s = $sub unless defined $s; + $place = '???' unless defined $place; + print( (' ' x $off) . "&$s in $place\n" ); +} + +sub findsubs { + my $self = shift; + return undef unless %DB::sub; + my ($addr, $name, $loc); + while (($name, $loc) = each %DB::sub) { + $addr = \&$name; + $subs{"$addr"} = $name; + } + $self->{subdump} = 0; + $subs{ shift() }; +} + +sub dumpvars { + my $self = shift; + my ($package,@vars) = @_; + local(%address,$^W); + my ($key,$val); + $package .= "::" unless $package =~ /::$/; + *stab = *main::; + + while ($package =~ /(\w+?::)/g) { + *stab = $ {stab}{$1}; + } + $self->{TotalStrings} = 0; + $self->{Strings} = 0; + $self->{CompleteTotal} = 0; + while (($key,$val) = each(%stab)) { + return if $DB::signal and $self->{stopDbSignal}; + next if @vars && !grep( matchvar($key, $_), @vars ); + if ($self->{usageOnly}) { + $self->globUsage(\$val, $key) + if ($package ne 'Dumpvalue' or $key ne 'stab') + and ref(\$val) eq 'GLOB'; + } else { + $self->dumpglob($package, 0,$key, $val); + } + } + if ($self->{usageOnly}) { + print <{TotalStrings} bytes in $self->{Strings} strings. +EOP + $self->{CompleteTotal} += $self->{TotalStrings}; + print <{CompleteTotal} bytes (1 level deep) + overhead. +EOP + } +} + +sub scalarUsage { + my $self = shift; + my $size; + if (UNIVERSAL::isa($_[0], 'ARRAY')) { + $size = $self->arrayUsage($_[0]); + } elsif (UNIVERSAL::isa($_[0], 'HASH')) { + $size = $self->hashUsage($_[0]); + } elsif (!ref($_[0])) { + $size = length($_[0]); + } + $self->{TotalStrings} += $size; + $self->{Strings}++; + $size; +} + +sub arrayUsage { # array ref, name + my $self = shift; + my $size = 0; + map {$size += $self->scalarUsage($_)} @{$_[0]}; + my $len = @{$_[0]}; + print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n" + if defined $_[1]; + $self->{CompleteTotal} += $size; + $size; +} + +sub hashUsage { # hash ref, name + my $self = shift; + my @keys = keys %{$_[0]}; + my @values = values %{$_[0]}; + my $keys = $self->arrayUsage(\@keys); + my $values = $self->arrayUsage(\@values); + my $len = @keys; + my $total = $keys + $values; + print "\%$_[1] = $len item", ($len > 1 ? "s" : ""), + " (keys: $keys; values: $values; total: $total bytes)\n" + if defined $_[1]; + $total; +} + +sub globUsage { # glob ref, name + my $self = shift; + local *stab = *{$_[0]}; + my $total = 0; + $total += $self->scalarUsage($stab) if defined $stab; + $total += $self->arrayUsage(\@stab, $_[1]) if @stab; + $total += $self->hashUsage(\%stab, $_[1]) + if %stab and $_[1] ne "main::" and $_[1] ne "DB::"; + #and !($package eq "Dumpvalue" and $key eq "stab")); + $total; +} + +1; + + +package sort; + +our $VERSION = '2.04'; + +# The hints for pp_sort are now stored in $^H{sort}; older versions +# of perl used the global variable $sort::hints. -- rjh 2005-12-19 + +$sort::stable_bit = 0x00000100; +$sort::unstable_bit = 0x00000200; + +use strict; + +sub import { + shift; + if (@_ == 0) { + require Carp; + Carp::croak("sort pragma requires arguments"); + } + local $_; + $^H{sort} //= 0; + while ($_ = shift(@_)) { + if ($_ eq 'stable') { + $^H{sort} |= $sort::stable_bit; + $^H{sort} &= ~$sort::unstable_bit; + } elsif ($_ eq 'defaults') { + $^H{sort} = 0; + } else { + require Carp; + Carp::croak("sort: unknown subpragma '$_'"); + } + } +} + +sub unimport { + shift; + if (@_ == 0) { + require Carp; + Carp::croak("sort pragma requires arguments"); + } + local $_; + no warnings 'uninitialized'; # bitops would warn + while ($_ = shift(@_)) { + if ($_ eq 'stable') { + $^H{sort} &= ~$sort::stable_bit; + $^H{sort} |= $sort::unstable_bit; + } else { + require Carp; + Carp::croak("sort: unknown subpragma '$_'"); + } + } +} + +sub current { + my @sort; + if ($^H{sort}) { + push @sort, 'stable' if $^H{sort} & $sort::stable_bit; + } + join(' ', @sort); +} + +1; +__END__ + + +package AnyDBM_File; +use warnings; +use strict; + +use 5.006_001; +our $VERSION = '1.01'; +our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +my $mod; +for $mod (@ISA) { + if (eval "require $mod") { + @ISA = ($mod); # if we leave @ISA alone, warnings abound + return 1; + } +} + +die "No DBM package was successfully found or installed"; + +__END__ + +# -*- buffer-read-only: t -*- +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by regen/feature.pl. +# Any changes made here will be lost! + +package feature; + +our $VERSION = '1.52'; + +our %feature = ( + fc => 'feature_fc', + say => 'feature_say', + state => 'feature_state', + switch => 'feature_switch', + bitwise => 'feature_bitwise', + evalbytes => 'feature_evalbytes', + array_base => 'feature_arybase', + signatures => 'feature_signatures', + current_sub => 'feature___SUB__', + refaliasing => 'feature_refaliasing', + postderef_qq => 'feature_postderef_qq', + unicode_eval => 'feature_unieval', + declared_refs => 'feature_myref', + unicode_strings => 'feature_unicode', +); + +our %feature_bundle = ( + "5.10" => [qw(array_base say state switch)], + "5.11" => [qw(array_base say state switch unicode_strings)], + "5.15" => [qw(current_sub evalbytes fc say state switch unicode_eval unicode_strings)], + "5.23" => [qw(current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], + "5.27" => [qw(bitwise current_sub evalbytes fc postderef_qq say state switch unicode_eval unicode_strings)], + "all" => [qw(array_base bitwise current_sub declared_refs evalbytes fc postderef_qq refaliasing say signatures state switch unicode_eval unicode_strings)], + "default" => [qw(array_base)], +); + +$feature_bundle{"5.12"} = $feature_bundle{"5.11"}; +$feature_bundle{"5.13"} = $feature_bundle{"5.11"}; +$feature_bundle{"5.14"} = $feature_bundle{"5.11"}; +$feature_bundle{"5.16"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.17"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.18"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.19"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.20"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.21"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.22"} = $feature_bundle{"5.15"}; +$feature_bundle{"5.24"} = $feature_bundle{"5.23"}; +$feature_bundle{"5.25"} = $feature_bundle{"5.23"}; +$feature_bundle{"5.26"} = $feature_bundle{"5.23"}; +$feature_bundle{"5.28"} = $feature_bundle{"5.27"}; +$feature_bundle{"5.9.5"} = $feature_bundle{"5.10"}; +my %noops = ( + postderef => 1, + lexical_subs => 1, +); + +our $hint_shift = 26; +our $hint_mask = 0x1c000000; +our @hint_bundles = qw( default 5.10 5.11 5.15 5.23 5.27 ); + +# This gets set (for now) in $^H as well as in %^H, +# for runtime speed of the uc/lc/ucfirst/lcfirst functions. +# See HINT_UNI_8_BIT in perl.h. +our $hint_uni8bit = 0x00000800; + +# TODO: +# - think about versioned features (use feature switch => 2) + + +sub import { + shift; + + if (!@_) { + croak("No features specified"); + } + + __common(1, @_); +} + +sub unimport { + shift; + + # A bare C should reset to the default bundle + if (!@_) { + $^H &= ~($hint_uni8bit|$hint_mask); + return; + } + + __common(0, @_); +} + + +sub __common { + my $import = shift; + my $bundle_number = $^H & $hint_mask; + my $features = $bundle_number != $hint_mask + && $feature_bundle{$hint_bundles[$bundle_number >> $hint_shift]}; + if ($features) { + # Features are enabled implicitly via bundle hints. + # Delete any keys that may be left over from last time. + delete @^H{ values(%feature) }; + $^H |= $hint_mask; + for (@$features) { + $^H{$feature{$_}} = 1; + $^H |= $hint_uni8bit if $_ eq 'unicode_strings'; + } + } + while (@_) { + my $name = shift; + if (substr($name, 0, 1) eq ":") { + my $v = substr($name, 1); + if (!exists $feature_bundle{$v}) { + $v =~ s/^([0-9]+)\.([0-9]+).[0-9]+$/$1.$2/; + if (!exists $feature_bundle{$v}) { + unknown_feature_bundle(substr($name, 1)); + } + } + unshift @_, @{$feature_bundle{$v}}; + next; + } + if (!exists $feature{$name}) { + if (exists $noops{$name}) { + next; + } + unknown_feature($name); + } + if ($import) { + $^H{$feature{$name}} = 1; + $^H |= $hint_uni8bit if $name eq 'unicode_strings'; + } else { + delete $^H{$feature{$name}}; + $^H &= ~ $hint_uni8bit if $name eq 'unicode_strings'; + } + } +} + +sub unknown_feature { + my $feature = shift; + croak(sprintf('Feature "%s" is not supported by Perl %vd', + $feature, $^V)); +} + +sub unknown_feature_bundle { + my $feature = shift; + croak(sprintf('Feature bundle "%s" is not supported by Perl %vd', + $feature, $^V)); +} + +sub croak { + require Carp; + Carp::croak(@_); +} + +1; + +# ex: set ro: +package subs; + +our $VERSION = '1.03'; + + +require 5.000; + +sub import { + my $callpack = caller; + my $pack = shift; + my @imports = @_; + foreach my $sym (@imports) { + *{"${callpack}::$sym"} = \&{"${callpack}::$sym"}; + } +}; + +1; +package SelfLoader; +use 5.008; +use strict; +use IO::Handle; +our $VERSION = "1.25"; + +# The following bit of eval-magic is necessary to make this work on +# perls < 5.009005. +our $AttrList; +BEGIN { + if ($] > 5.009004) { + eval <<'NEWERPERL'; +use 5.009005; # due to new regexp features +# allow checking for valid ': attrlist' attachments +# see also AutoSplit +$AttrList = qr{ + \s* : \s* + (?: + # one attribute + (?> # no backtrack + (?! \d) \w+ + (? \( (?: [^()]++ | (?&nested)++ )*+ \) ) ? + ) + (?: \s* : \s* | \s+ (?! :) ) + )* +}x; + +NEWERPERL + } + else { + eval <<'OLDERPERL'; +# allow checking for valid ': attrlist' attachments +# (we use 'our' rather than 'my' here, due to the rather complex and buggy +# behaviour of lexicals with qr// and (??{$lex}) ) +our $nested; +$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x; +our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x; +$AttrList = qr{ \s* : \s* (?: $one_attr )* }x; +OLDERPERL + } +} +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(AUTOLOAD); +sub Version {$VERSION} +sub DEBUG () { 0 } + +my %Cache; # private cache for all SelfLoader's client packages + +# in croak and carp, protect $@ from "require Carp;" RT #40216 + +sub croak { { local $@; require Carp; } goto &Carp::croak } +sub carp { { local $@; require Carp; } goto &Carp::carp } + +AUTOLOAD { + our $AUTOLOAD; + print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if DEBUG; + my $SL_code = $Cache{$AUTOLOAD}; + my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@ + unless ($SL_code) { + # Maybe this pack had stubs before __DATA__, and never initialized. + # Or, this maybe an automatic DESTROY method call when none exists. + $AUTOLOAD =~ m/^(.*)::/; + SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::_load_stubs((caller)[0]) } + +sub _load_stubs { + # $endlines is used by Devel::SelfStubber to capture lines after __END__ + my($self, $callpack, $endlines) = @_; + no strict "refs"; + my $fh = \*{"${callpack}::DATA"}; + use strict; + my $currpack = $callpack; + my($line,$name,@lines, @stubs, $protoype); + + print STDERR "SelfLoader::load_stubs($callpack)\n" if DEBUG; + croak("$callpack doesn't contain an __DATA__ token") + unless defined fileno($fh); + # Protect: fork() shares the file pointer between the parent and the kid + if(sysseek($fh, tell($fh), 0)) { + open my $nfh, '<&', $fh or croak "reopen: $!";# dup() the fd + close $fh or die "close: $!"; # autocloses, but be + # paranoid + open $fh, '<&', $nfh or croak "reopen2: $!"; # dup() the fd "back" + close $nfh or die "close after reopen: $!"; # autocloses, but be + # paranoid + $fh->untaint; + } + $Cache{"${currpack}::) and $line !~ m/^__END__/) { + if ($line =~ m/ ^\s* # indentation + sub\s+([\w:]+)\s* # 'sub' and sub name + ( + (?:\([\\\$\@\%\&\*\;]*\))? # optional prototype sigils + (?:$AttrList)? # optional attribute list + )/x) { + push(@stubs, $self->_add_to_cache($name, $currpack, + \@lines, $protoype)); + $protoype = $2; + @lines = ($line); + if (index($1,'::') == -1) { # simple sub name + $name = "${currpack}::$1"; + } else { # sub name with package + $name = $1; + $name =~ m/^(.*)::/; + if (defined(&{"${1}::AUTOLOAD"})) { + \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD || + die 'SelfLoader Error: attempt to specify Selfloading', + " sub $name in non-selfloading module $1"; + } else { + $self->export($1,'AUTOLOAD'); + } + } + } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared + push(@stubs, $self->_add_to_cache($name, $currpack, + \@lines, $protoype)); + $self->_package_defined($line); + $name = ''; + @lines = (); + $currpack = $1; + $Cache{"${currpack}::export($currpack,'AUTOLOAD'); + } + } else { + push(@lines,$line); + } + } + if (defined($line) && $line =~ /^__END__/) { # __END__ + unless ($line =~ /^__END__\s*DATA/) { + if ($endlines) { + # Devel::SelfStubber would like us to capture the lines after + # __END__ so it can write out the entire file + @$endlines = <$fh>; + } + close($fh); + } + } + push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype)); + no strict; + eval join('', @stubs) if @stubs; +} + + +sub _add_to_cache { + my($self,$fullname,$pack,$lines, $protoype) = @_; + return () unless $fullname; + carp("Redefining sub $fullname") + if exists $Cache{$fullname}; + $Cache{$fullname} = join('', + "\n\#line 1 \"sub $fullname\"\npackage $pack; ", + @$lines); + #$Cache{$fullname} = join('', "package $pack; ",@$lines); + print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if DEBUG; + # return stub to be eval'd + defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;" +} + +sub _package_defined {} + +1; +__END__ + +package overload; + +our $VERSION = '1.30'; + +%ops = ( + with_assign => "+ - * / % ** << >> x .", + assign => "+= -= *= /= %= **= <<= >>= x= .=", + num_comparison => "< <= > >= == !=", + '3way_comparison' => "<=> cmp", + str_comparison => "lt le gt ge eq ne", + binary => '& &= | |= ^ ^= &. &.= |. |.= ^. ^.=', + unary => "neg ! ~ ~.", + mutators => '++ --', + func => "atan2 cos sin exp abs log sqrt int", + conversion => 'bool "" 0+ qr', + iterators => '<>', + filetest => "-X", + dereferencing => '${} @{} %{} &{} *{}', + matching => '~~', + special => 'nomethod fallback =', +); + +my %ops_seen; +@ops_seen{ map split(/ /), values %ops } = (); + +sub nil {} + +sub OVERLOAD { + $package = shift; + my %arg = @_; + my $sub; + *{$package . "::(("} = \&nil; # Make it findable via fetchmethod. + for (keys %arg) { + if ($_ eq 'fallback') { + for my $sym (*{$package . "::()"}) { + *$sym = \&nil; # Make it findable via fetchmethod. + $$sym = $arg{$_}; + } + } else { + warnings::warnif("overload arg '$_' is invalid") + unless exists $ops_seen{$_}; + $sub = $arg{$_}; + if (not ref $sub) { + $ {$package . "::(" . $_} = $sub; + $sub = \&nil; + } + #print STDERR "Setting '$ {'package'}::\cO$_' to \\&'$sub'.\n"; + *{$package . "::(" . $_} = \&{ $sub }; + } + } +} + +sub import { + $package = (caller())[0]; + # *{$package . "::OVERLOAD"} = \&OVERLOAD; + shift; + $package->overload::OVERLOAD(@_); +} + +sub unimport { + $package = (caller())[0]; + shift; + *{$package . "::(("} = \&nil; + for (@_) { + warnings::warnif("overload arg '$_' is invalid") + unless exists $ops_seen{$_}; + delete $ {$package . "::"}{$_ eq 'fallback' ? '()' : "(" .$_}; + } +} + +sub Overloaded { + my $package = shift; + $package = ref $package if ref $package; + mycan ($package, '()') || mycan ($package, '(('); +} + +sub ov_method { + my $globref = shift; + return undef unless $globref; + my $sub = \&{*$globref}; + no overloading; + return $sub if $sub != \&nil; + return shift->can($ {*$globref}); +} + +sub OverloadedStringify { + my $package = shift; + $package = ref $package if ref $package; + #$package->can('(""') + ov_method mycan($package, '(""'), $package + or ov_method mycan($package, '(0+'), $package + or ov_method mycan($package, '(bool'), $package + or ov_method mycan($package, '(nomethod'), $package; +} + +sub Method { + my $package = shift; + if(ref $package) { + local $@; + local $!; + require Scalar::Util; + $package = Scalar::Util::blessed($package); + return undef if !defined $package; + } + #my $meth = $package->can('(' . shift); + ov_method mycan($package, '(' . shift), $package; + #return $meth if $meth ne \&nil; + #return $ {*{$meth}}; +} + +sub AddrRef { + no overloading; + "$_[0]"; +} + +*StrVal = *AddrRef; + +sub mycan { # Real can would leave stubs. + my ($package, $meth) = @_; + + local $@; + local $!; + require mro; + + my $mro = mro::get_linear_isa($package); + foreach my $p (@$mro) { + my $fqmeth = $p . q{::} . $meth; + return \*{$fqmeth} if defined &{$fqmeth}; + } + + return undef; +} + +%constants = ( + 'integer' => 0x1000, # HINT_NEW_INTEGER + 'float' => 0x2000, # HINT_NEW_FLOAT + 'binary' => 0x4000, # HINT_NEW_BINARY + 'q' => 0x8000, # HINT_NEW_STRING + 'qr' => 0x10000, # HINT_NEW_RE + ); + +use warnings::register; +sub constant { + # Arguments: what, sub + while (@_) { + if (@_ == 1) { + warnings::warnif ("Odd number of arguments for overload::constant"); + last; + } + elsif (!exists $constants {$_ [0]}) { + warnings::warnif ("'$_[0]' is not an overloadable type"); + } + elsif (!ref $_ [1] || "$_[1]" !~ /(^|=)CODE\(0x[0-9a-f]+\)$/) { + # Can't use C above as code references can be + # blessed, and C would return the package the ref is blessed into. + if (warnings::enabled) { + $_ [1] = "undef" unless defined $_ [1]; + warnings::warn ("'$_[1]' is not a code reference"); + } + } + else { + $^H{$_[0]} = $_[1]; + $^H |= $constants{$_[0]}; + } + shift, shift; + } +} + +sub remove_constant { + # Arguments: what, sub + while (@_) { + delete $^H{$_[0]}; + $^H &= ~ $constants{$_[0]}; + shift, shift; + } +} + +1; + +__END__ + + +package strict; + +$strict::VERSION = "1.11"; + +my ( %bitmask, %explicit_bitmask ); + +BEGIN { + # Verify that we're called correctly so that strictures will work. + # Can't use Carp, since Carp uses us! + # see also warnings.pm. + die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(caller)[1,2] + if __FILE__ !~ ( '(?x) \b '.__PACKAGE__.' \.pmc? \z' ) + && __FILE__ =~ ( '(?x) \b (?i:'.__PACKAGE__.') \.pmc? \z' ); + + %bitmask = ( + refs => 0x00000002, + subs => 0x00000200, + vars => 0x00000400, + ); + + %explicit_bitmask = ( + refs => 0x00000020, + subs => 0x00000040, + vars => 0x00000080, + ); + + my $bits = 0; + $bits |= $_ for values %bitmask; + + my $inline_all_bits = $bits; + *all_bits = sub () { $inline_all_bits }; + + $bits = 0; + $bits |= $_ for values %explicit_bitmask; + + my $inline_all_explicit_bits = $bits; + *all_explicit_bits = sub () { $inline_all_explicit_bits }; +} + +sub bits { + my $bits = 0; + my @wrong; + foreach my $s (@_) { + if (exists $bitmask{$s}) { + $^H |= $explicit_bitmask{$s}; + + $bits |= $bitmask{$s}; + } + else { + push @wrong, $s; + } + } + if (@wrong) { + require Carp; + Carp::croak("Unknown 'strict' tag(s) '@wrong'"); + } + $bits; +} + +sub import { + shift; + $^H |= @_ ? &bits : all_bits | all_explicit_bits; +} + +sub unimport { + shift; + + if (@_) { + $^H &= ~&bits; + } + else { + $^H &= ~all_bits; + $^H |= all_explicit_bits; + } +} + +1; +__END__ + +package English; + +our $VERSION = '1.10'; + +require Exporter; +@ISA = qw(Exporter); + + +no warnings; + +my $globbed_match ; + +# Grandfather $NAME import +sub import { + my $this = shift; + my @list = grep { ! /^-no_match_vars$/ } @_ ; + local $Exporter::ExportLevel = 1; + if ( @_ == @list ) { + *EXPORT = \@COMPLETE_EXPORT ; + $globbed_match ||= ( + eval q{ + *MATCH = *& ; + *PREMATCH = *` ; + *POSTMATCH = *' ; + 1 ; + } + || do { + require Carp ; + Carp::croak("Can't create English for match leftovers: $@") ; + } + ) ; + } + else { + *EXPORT = \@MINIMAL_EXPORT ; + } + Exporter::import($this,grep {s/^\$/*/} @list); +} + +@MINIMAL_EXPORT = qw( + *ARG + *LAST_PAREN_MATCH + *INPUT_LINE_NUMBER + *NR + *INPUT_RECORD_SEPARATOR + *RS + *OUTPUT_AUTOFLUSH + *OUTPUT_FIELD_SEPARATOR + *OFS + *OUTPUT_RECORD_SEPARATOR + *ORS + *LIST_SEPARATOR + *SUBSCRIPT_SEPARATOR + *SUBSEP + *FORMAT_PAGE_NUMBER + *FORMAT_LINES_PER_PAGE + *FORMAT_LINES_LEFT + *FORMAT_NAME + *FORMAT_TOP_NAME + *FORMAT_LINE_BREAK_CHARACTERS + *FORMAT_FORMFEED + *CHILD_ERROR + *OS_ERROR + *ERRNO + *EXTENDED_OS_ERROR + *EVAL_ERROR + *PROCESS_ID + *PID + *REAL_USER_ID + *UID + *EFFECTIVE_USER_ID + *EUID + *REAL_GROUP_ID + *GID + *EFFECTIVE_GROUP_ID + *EGID + *PROGRAM_NAME + *PERL_VERSION + *OLD_PERL_VERSION + *ACCUMULATOR + *COMPILING + *DEBUGGING + *SYSTEM_FD_MAX + *INPLACE_EDIT + *PERLDB + *BASETIME + *WARNING + *EXECUTABLE_NAME + *OSNAME + *LAST_REGEXP_CODE_RESULT + *EXCEPTIONS_BEING_CAUGHT + *LAST_SUBMATCH_RESULT + @LAST_MATCH_START + @LAST_MATCH_END +); + + +@MATCH_EXPORT = qw( + *MATCH + *PREMATCH + *POSTMATCH +); + +@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ; + +# The ground of all being. + + *ARG = *_ ; + +# Matching. + + *LAST_PAREN_MATCH = *+ ; + *LAST_SUBMATCH_RESULT = *^N ; + *LAST_MATCH_START = *-{ARRAY} ; + *LAST_MATCH_END = *+{ARRAY} ; + +# Input. + + *INPUT_LINE_NUMBER = *. ; + *NR = *. ; + *INPUT_RECORD_SEPARATOR = */ ; + *RS = */ ; + +# Output. + + *OUTPUT_AUTOFLUSH = *| ; + *OUTPUT_FIELD_SEPARATOR = *, ; + *OFS = *, ; + *OUTPUT_RECORD_SEPARATOR = *\ ; + *ORS = *\ ; + +# Interpolation "constants". + + *LIST_SEPARATOR = *" ; + *SUBSCRIPT_SEPARATOR = *; ; + *SUBSEP = *; ; + +# Formats + + *FORMAT_PAGE_NUMBER = *% ; + *FORMAT_LINES_PER_PAGE = *= ; + *FORMAT_LINES_LEFT = *-{SCALAR} ; + *FORMAT_NAME = *~ ; + *FORMAT_TOP_NAME = *^ ; + *FORMAT_LINE_BREAK_CHARACTERS = *: ; + *FORMAT_FORMFEED = *^L ; + +# Error status. + + *CHILD_ERROR = *? ; + *OS_ERROR = *! ; + *ERRNO = *! ; + *OS_ERROR = *! ; + *ERRNO = *! ; + *EXTENDED_OS_ERROR = *^E ; + *EVAL_ERROR = *@ ; + +# Process info. + + *PROCESS_ID = *$ ; + *PID = *$ ; + *REAL_USER_ID = *< ; + *UID = *< ; + *EFFECTIVE_USER_ID = *> ; + *EUID = *> ; + *REAL_GROUP_ID = *( ; + *GID = *( ; + *EFFECTIVE_GROUP_ID = *) ; + *EGID = *) ; + *PROGRAM_NAME = *0 ; + +# Internals. + + *PERL_VERSION = *^V ; + *OLD_PERL_VERSION = *] ; + *ACCUMULATOR = *^A ; + *COMPILING = *^C ; + *DEBUGGING = *^D ; + *SYSTEM_FD_MAX = *^F ; + *INPLACE_EDIT = *^I ; + *PERLDB = *^P ; + *LAST_REGEXP_CODE_RESULT = *^R ; + *EXCEPTIONS_BEING_CAUGHT = *^S ; + *BASETIME = *^T ; + *WARNING = *^W ; + *EXECUTABLE_NAME = *^X ; + *OSNAME = *^O ; + +# Deprecated. + +# *ARRAY_BASE = *[ ; +# *OFMT = *# ; + +1; +package integer; + +our $VERSION = '1.01'; + + +$integer::hint_bits = 0x1; + +sub import { + $^H |= $integer::hint_bits; +} + +sub unimport { + $^H &= ~$integer::hint_bits; +} + +1; +#!perl -w +package version; + +use 5.006002; +use strict; +use warnings::register; +if ($] >= 5.015) { + warnings::register_categories(qw/version/); +} + +our $VERSION = 0.9923; +our $CLASS = 'version'; +our (@ISA, $STRICT, $LAX); + +# avoid using Exporter +require version::regex; +*version::is_lax = \&version::regex::is_lax; +*version::is_strict = \&version::regex::is_strict; +*LAX = \$version::regex::LAX; +*LAX_DECIMAL_VERSION = \$version::regex::LAX_DECIMAL_VERSION; +*LAX_DOTTED_DECIMAL_VERSION = \$version::regex::LAX_DOTTED_DECIMAL_VERSION; +*STRICT = \$version::regex::STRICT; +*STRICT_DECIMAL_VERSION = \$version::regex::STRICT_DECIMAL_VERSION; +*STRICT_DOTTED_DECIMAL_VERSION = \$version::regex::STRICT_DOTTED_DECIMAL_VERSION; + +sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq $CLASS) { + local $^W; + *{$class.'::declare'} = \&{$CLASS.'::declare'}; + *{$class.'::qv'} = \&{$CLASS.'::qv'}; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } + + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg.'::declare'} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg.'::qv'} = + sub {return $class->qv(shift) } + unless defined(&{$callpkg.'::qv'}); + } + + if (exists($args{'UNIVERSAL::VERSION'})) { + local $^W; + *UNIVERSAL::VERSION + = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} + unless defined(&{$callpkg.'::is_lax'}); + } +} + + +1; +package bigint; + +use 5.010; +use strict; +use warnings; + +our $VERSION = '0.49'; + +use Exporter; +our @ISA = qw( Exporter ); +our @EXPORT_OK = qw( PI e bpi bexp hex oct ); +our @EXPORT = qw( inf NaN ); + +use overload; + +############################################################################## + +# These are all alike, and thus faked by AUTOLOAD + +my @faked = qw/round_mode accuracy precision div_scale/; +our ($AUTOLOAD, $_lite); # _lite for testsuite + +sub AUTOLOAD { + my $name = $AUTOLOAD; + + $name =~ s/.*:://; # split package + no strict 'refs'; + foreach my $n (@faked) { + if ($n eq $name) { + *{"bigint::$name"} = + sub { + my $self = shift; + no strict 'refs'; + if (defined $_[0]) { + return Math::BigInt->$name($_[0]); + } + return Math::BigInt->$name(); + }; + return &$name; + } + } + + # delayed load of Carp and avoid recursion + require Carp; + Carp::croak ("Can't call bigint\-\>$name, not a valid method"); +} + +sub upgrade { + $Math::BigInt::upgrade; +} + +sub _binary_constant { + # this takes a binary/hexadecimal/octal constant string and returns it + # as string suitable for new. Basically it converts octal to decimal, and + # passes every thing else unmodified back. + my $string = shift; + + return Math::BigInt->new($string) if $string =~ /^0[bx]/; + + # so it must be an octal constant + Math::BigInt->from_oct($string); +} + +sub _float_constant { + # this takes a floating point constant string and returns it truncated to + # integer. For instance, '4.5' => '4', '1.234e2' => '123' etc + my $float = shift; + + # some simple cases first + return $float if ($float =~ /^[+-]?[0-9]+$/); # '+123','-1','0' etc + return $float + if ($float =~ /^[+-]?[0-9]+\.?[eE]\+?[0-9]+$/); # 123e2, 123.e+2 + return '0' if ($float =~ /^[+-]?[0]*\.[0-9]+$/); # .2, 0.2, -.1 + if ($float =~ /^[+-]?[0-9]+\.[0-9]*$/) { # 1., 1.23, -1.2 etc + $float =~ s/\..*//; + return $float; + } + my ($mis, $miv, $mfv, $es, $ev) = Math::BigInt::_split($float); + return $float if !defined $mis; # doesn't look like a number to me + my $ec = int($$ev); + my $sign = $$mis; + $sign = '' if $sign eq '+'; + if ($$es eq '-') { + # ignore fraction part entirely + if ($ec >= length($$miv)) { # 123.23E-4 + return '0'; + } + return $sign . substr($$miv, 0, length($$miv) - $ec); # 1234.45E-2 = 12 + } + # xE+y + if ($ec >= length($$mfv)) { + $ec -= length($$mfv); + return $sign.$$miv.$$mfv if $ec == 0; # 123.45E+2 => 12345 + return $sign.$$miv.$$mfv.'E'.$ec; # 123.45e+3 => 12345e1 + } + $mfv = substr($$mfv, 0, $ec); + $sign.$$miv.$mfv; # 123.45e+1 => 1234 +} + +sub unimport { + $^H{bigint} = undef; # no longer in effect + overload::remove_constant('binary', '', 'float', '', 'integer'); +} + +sub in_effect { + my $level = shift || 0; + my $hinthash = (caller($level))[10]; + $hinthash->{bigint}; +} + +############################################################################# +# the following two routines are for "use bigint qw/hex oct/;": + +use constant LEXICAL => $] > 5.009004; + +# Internal function with the same semantics as CORE::hex(). This function is +# not used directly, but rather by other front-end functions. + +sub _hex_core { + my $str = shift; + + # Strip off, clean, and parse as much as we can from the beginning. + + my $x; + if ($str =~ s/ ^ (0?[xX])? ( [0-9a-fA-F]* ( _ [0-9a-fA-F]+ )* ) //x) { + my $chrs = $2; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_hex($chrs); + } else { + $x = Math::BigInt -> bzero(); + } + + # Warn about trailing garbage. + + if (CORE::length($str)) { + require Carp; + Carp::carp(sprintf("Illegal hexadecimal digit '%s' ignored", + substr($str, 0, 1))); + } + + return $x; +} + +# Internal function with the same semantics as CORE::oct(). This function is +# not used directly, but rather by other front-end functions. + +sub _oct_core { + my $str = shift; + + $str =~ s/^\s*//; + + # Hexadecimal input. + + return _hex_core($str) if $str =~ /^0?[xX]/; + + my $x; + + # Binary input. + + if ($str =~ /^0?[bB]/) { + + # Strip off, clean, and parse as much as we can from the beginning. + + if ($str =~ s/ ^ (0?[bB])? ( [01]* ( _ [01]+ )* ) //x) { + my $chrs = $2; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_bin($chrs); + } + + # Warn about trailing garbage. + + if (CORE::length($str)) { + require Carp; + Carp::carp(sprintf("Illegal binary digit '%s' ignored", + substr($str, 0, 1))); + } + + return $x; + } + + # Octal input. Strip off, clean, and parse as much as we can from the + # beginning. + + if ($str =~ s/ ^ ( [0-7]* ( _ [0-7]+ )* ) //x) { + my $chrs = $1; + $chrs =~ tr/_//d; + $chrs = '0' unless CORE::length $chrs; + $x = Math::BigInt -> from_oct($chrs); + } + + # Warn about trailing garbage. CORE::oct() only warns about 8 and 9. + + if (CORE::length($str)) { + my $chr = substr($str, 0, 1); + if ($chr eq '8' || $chr eq '9') { + require Carp; + Carp::carp(sprintf("Illegal octal digit '%s' ignored", $chr)); + } + } + + return $x; +} + +{ + my $proto = LEXICAL ? '_' : ';$'; + eval ' +sub hex(' . $proto . ') {' . <<'.'; + my $str = @_ ? $_[0] : $_; + _hex_core($str); +} +. + + eval ' +sub oct(' . $proto . ') {' . <<'.'; + my $str = @_ ? $_[0] : $_; + _oct_core($str); +} +. +} + +############################################################################# +# the following two routines are for Perl 5.9.4 or later and are lexical + +my ($prev_oct, $prev_hex, $overridden); + +if (LEXICAL) { eval <<'.' } +sub _hex(_) { + my $hh = (caller 0)[10]; + return $prev_hex ? &$prev_hex($_[0]) : CORE::hex($_[0]) + unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat}; + _hex_core($_[0]); +} + +sub _oct(_) { + my $hh = (caller 0)[10]; + return $prev_oct ? &$prev_oct($_[0]) : CORE::oct($_[0]) + unless $$hh{bigint}||$$hh{bignum}||$$hh{bigrat}; + _oct_core($_[0]); +} +. + +sub _override { + return if $overridden; + $prev_oct = *CORE::GLOBAL::oct{CODE}; + $prev_hex = *CORE::GLOBAL::hex{CODE}; + no warnings 'redefine'; + *CORE::GLOBAL::oct = \&_oct; + *CORE::GLOBAL::hex = \&_hex; + $overridden++; +} + +sub import { + my $self = shift; + + $^H{bigint} = 1; # we are in effect + + # for newer Perls always override hex() and oct() with a lexical version: + if (LEXICAL) { + _override(); + } + # some defaults + my $lib = ''; + my $lib_kind = 'try'; + + my @import = (':constant'); # drive it w/ constant + my @a = @_; + my $l = scalar @_; + my $j = 0; + my ($ver, $trace); # version? trace? + my ($a, $p); # accuracy, precision + for (my $i = 0; $i < $l; $i++, $j++) { + if ($_[$i] =~ /^(l|lib|try|only)$/) { + # this causes a different low lib to take care... + $lib_kind = $1; + $lib_kind = 'lib' if $lib_kind eq 'l'; + $lib = $_[$i + 1] || ''; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } elsif ($_[$i] =~ /^(a|accuracy)$/) { + $a = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } elsif ($_[$i] =~ /^(p|precision)$/) { + $p = $_[$i + 1]; + my $s = 2; + $s = 1 if @a - $j < 2; # avoid "can not modify non-existent..." + splice @a, $j, $s; + $j -= $s; + $i++; + } elsif ($_[$i] =~ /^(v|version)$/) { + $ver = 1; + splice @a, $j, 1; + $j--; + } elsif ($_[$i] =~ /^(t|trace)$/) { + $trace = 1; + splice @a, $j, 1; + $j--; + } elsif ($_[$i] !~ /^(PI|e|bpi|bexp|hex|oct)\z/) { + die ("unknown option $_[$i]"); + } + } + my $class; + $_lite = 0; # using M::BI::L ? + if ($trace) { + require Math::BigInt::Trace; + $class = 'Math::BigInt::Trace'; + } else { + # see if we can find Math::BigInt::Lite + if (!defined $a && !defined $p) { # rounding won't work to well + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + if (eval { require Math::BigInt::Lite; 1 }) { + @import = (); # :constant in Lite, not MBI + Math::BigInt::Lite->import(':constant'); + $_lite = 1; # signal okay + } + } + require Math::BigInt if $_lite == 0; # not already loaded? + $class = 'Math::BigInt'; # regardless of MBIL or not + } + push @import, $lib_kind => $lib if $lib ne ''; + # Math::BigInt::Trace or plain Math::BigInt + $class->import(@import); + + bigint->accuracy($a) if defined $a; + bigint->precision($p) if defined $p; + if ($ver) { + print "bigint\t\t\t v$VERSION\n"; + print "Math::BigInt::Lite\t v$Math::BigInt::Lite::VERSION\n" if $_lite; + print "Math::BigInt\t\t v$Math::BigInt::VERSION"; + my $config = Math::BigInt->config(); + print " lib => $config->{lib} v$config->{lib_version}\n"; + exit; + } + # we take care of floating point constants, since BigFloat isn't available + # and BigInt doesn't like them: + overload::constant float => + sub { + Math::BigInt->new(_float_constant(shift)); + }; + # Take care of octal/hexadecimal constants + overload::constant binary => + sub { + _binary_constant(shift); + }; + + # if another big* was already loaded: + my ($package) = caller(); + + no strict 'refs'; + if (!defined *{"${package}::inf"}) { + $self->export_to_level(1, $self, @a); # export inf and NaN, e and PI + } +} + +sub inf () { Math::BigInt->binf(); } +sub NaN () { Math::BigInt->bnan(); } + +sub PI () { Math::BigInt->new(3); } +sub e () { Math::BigInt->new(2); } +sub bpi ($) { Math::BigInt->new(3); } +sub bexp ($$) { + my $x = Math::BigInt->new($_[0]); + $x->bexp($_[1]); +} + +1; + +__END__ + +package autodie; +use 5.008; +use strict; +use warnings; + +use parent qw(Fatal); +our $VERSION; + +# ABSTRACT: Replace functions with ones that succeed or die with lexical scope + +BEGIN { + our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version +} + +use constant ERROR_WRONG_FATAL => q{ +Incorrect version of Fatal.pm loaded by autodie. + +The autodie pragma uses an updated version of Fatal to do its +heavy lifting. We seem to have loaded Fatal version %s, which is +probably the version that came with your version of Perl. However +autodie needs version %s, which would have come bundled with +autodie. + +You may be able to solve this problem by adding the following +line of code to your main program, before any use of Fatal or +autodie. + + use lib "%s"; + +}; + +# We have to check we've got the right version of Fatal before we +# try to compile the rest of our code, lest we use a constant +# that doesn't exist. + +BEGIN { + + # If we have the wrong Fatal, then we've probably loaded the system + # one, not our own. Complain, and give a useful hint. ;) + + if (defined($Fatal::VERSION) and defined($VERSION) and $Fatal::VERSION ne $VERSION) { + my $autodie_path = $INC{'autodie.pm'}; + + $autodie_path =~ s/autodie\.pm//; + + require Carp; + + Carp::croak sprintf( + ERROR_WRONG_FATAL, $Fatal::VERSION, $VERSION, $autodie_path + ); + } +} + +# When passing args to Fatal we want to keep the first arg +# (our package) in place. Hence the splice. + +sub import { + splice(@_,1,0,Fatal::LEXICAL_TAG); + goto &Fatal::import; +} + +sub unimport { + splice(@_,1,0,Fatal::LEXICAL_TAG); + goto &Fatal::unimport; +} + +1; + +__END__ + +package PerlIO; + +our $VERSION = '1.10'; + +# Map layer name to package that defines it +our %alias; + +sub import +{ + my $class = shift; + while (@_) + { + my $layer = shift; + if (exists $alias{$layer}) + { + $layer = $alias{$layer} + } + else + { + $layer = "${class}::$layer"; + } + eval { require $layer =~ s{::}{/}gr . '.pm' }; + warn $@ if $@; + } +} + +sub F_UTF8 () { 0x8000 } + +1; +__END__ + +use strict; +use warnings; +package perlfaq; +$perlfaq::VERSION = '5.021011'; +1; +package vars; + +use 5.006; + +our $VERSION = '1.04'; + +use warnings::register; +use strict qw(vars subs); + +sub import { + my $callpack = caller; + my (undef, @imports) = @_; + my ($sym, $ch); + foreach (@imports) { + if (($ch, $sym) = /^([\$\@\%\*\&])(.+)/) { + if ($sym =~ /\W/) { + # time for a more-detailed check-up + if ($sym =~ /^\w+[[{].*[]}]$/) { + require Carp; + Carp::croak("Can't declare individual elements of hash or array"); + } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) { + warnings::warn("No need to declare built-in vars"); + } elsif (($^H &= strict::bits('vars'))) { + require Carp; + Carp::croak("'$_' is not a valid variable name under strict vars"); + } + } + $sym = "${callpack}::$sym" unless $sym =~ /::/; + *$sym = + ( $ch eq "\$" ? \$$sym + : $ch eq "\@" ? \@$sym + : $ch eq "\%" ? \%$sym + : $ch eq "\*" ? \*$sym + : $ch eq "\&" ? \&$sym + : do { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + }); + } else { + require Carp; + Carp::croak("'$_' is not a valid variable name"); + } + } +}; + +1; +__END__ + +package Exporter; + +require 5.006; + +# Be lean. +#use strict; +#no strict 'refs'; + +our $Debug = 0; +our $ExportLevel = 0; +our $Verbose ||= 0; +our $VERSION = '5.73'; +our (%Cache); + +sub as_heavy { + require Exporter::Heavy; + # Unfortunately, this does not work if the caller is aliased as *name = \&foo + # Thus the need to create a lot of identical subroutines + my $c = (caller(1))[3]; + $c =~ s/.*:://; + \&{"Exporter::Heavy::heavy_$c"}; +} + +sub export { + goto &{as_heavy()}; +} + +sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { + *{$callpkg."::import"} = \&import; + return; + } + + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my $exports = \@{"$pkg\::EXPORT"}; + # But, avoid creating things if they don't exist, which saves a couple of + # hundred bytes per package processed. + my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"}; + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or $fail && @$fail > 1; + my $export_cache = ($Cache{$pkg} ||= {}); + my $args = @_ or @_ = @$exports; + + if ($args and not %$export_cache) { + s/^&//, $export_cache->{$_} = 1 + foreach (@$exports, @{"$pkg\::EXPORT_OK"}); + } + my $heavy; + # Try very hard not to use {} and hence have to enter scope on the foreach + # We bomb out of the loop with last as soon as heavy is set. + if ($args or $fail) { + ($heavy = (/\W/ or $args and not exists $export_cache->{$_} + or $fail and @$fail and $_ eq $fail->[0])) and last + foreach (@_); + } else { + ($heavy = /\W/) and last + foreach (@_); + } + return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; + local $SIG{__WARN__} = + sub {require Carp; &Carp::carp} if not $SIG{__WARN__}; + # shortcut for the common case of no type character + *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; +} + +# Default methods + +sub export_fail { + my $self = shift; + @_; +} + +# Unfortunately, caller(1)[3] "does not work" if the caller is aliased as +# *name = \&foo. Thus the need to create a lot of identical subroutines +# Otherwise we could have aliased them to export(). + +sub export_to_level { + goto &{as_heavy()}; +} + +sub export_tags { + goto &{as_heavy()}; +} + +sub export_ok_tags { + goto &{as_heavy()}; +} + +sub require_version { + goto &{as_heavy()}; +} + +1; +__END__ + + + + +package locale; + +our $VERSION = '1.09'; +use Config; + +$Carp::Internal{ (__PACKAGE__) } = 1; + + +# A separate bit is used for each of the two forms of the pragma, to save +# having to look at %^H for the normal case of a plain 'use locale' without an +# argument. + +$locale::hint_bits = 0x4; +$locale::partial_hint_bits = 0x10; # If pragma has an argument + +# The pseudo-category :characters consists of 2 real ones; but it also is +# given its own number, -1, because in the complement form it also has the +# side effect of "use feature 'unicode_strings'" + +sub import { + shift; # should be 'locale'; not checked + + $^H{locale} = 0 unless defined $^H{locale}; + if (! @_) { # If no parameter, use the plain form that changes all categories + $^H |= $locale::hint_bits; + + } + else { + my @categories = ( qw(:ctype :collate :messages + :numeric :monetary :time) ); + for (my $i = 0; $i < @_; $i++) { + my $arg = $_[$i]; + $complement = $arg =~ s/ : ( ! | not_ ) /:/x; + if (! grep { $arg eq $_ } @categories, ":characters") { + require Carp; + Carp::croak("Unknown parameter '$_[$i]' to 'use locale'"); + } + + if ($complement) { + if ($i != 0 || $i < @_ - 1) { + require Carp; + Carp::croak("Only one argument to 'use locale' allowed" + . "if is $complement"); + } + + if ($arg eq ':characters') { + push @_, grep { $_ ne ':ctype' && $_ ne ':collate' } + @categories; + # We add 1 to the category number; This category number + # is -1 + $^H{locale} |= (1 << 0); + } + else { + push @_, grep { $_ ne $arg } @categories; + } + next; + } + elsif ($arg eq ':characters') { + push @_, ':ctype', ':collate'; + next; + } + + $^H |= $locale::partial_hint_bits; + + # This form of the pragma overrides the other + $^H &= ~$locale::hint_bits; + + $arg =~ s/^://; + + eval { require POSIX; import POSIX 'locale_h'; }; + + # Map our names to the ones defined by POSIX + my $LC = "LC_" . uc($arg); + + my $bit = eval "&POSIX::$LC"; + if (defined $bit) { # XXX Should we warn that this category isn't + # supported on this platform, or make it + # always be the C locale? + + # Verify our assumption. + if (! ($bit >= 0 && $bit < 31)) { + require Carp; + Carp::croak("Cannot have ':$arg' parameter to 'use locale'" + . " on this platform. Use the 'perlbug' utility" + . " to report this problem, or send email to" + . " 'perlbug\@perl.org'. $LC=$bit"); + } + + # 1 is added so that the pseudo-category :characters, which is + # -1, comes out 0. + $^H{locale} |= 1 << ($bit + 1); + } + } + } + +} + +sub unimport { + $^H &= ~($locale::hint_bits|$locale::partial_hint_bits); + $^H{locale} = 0; +} + +1; +package sigtrap; + + +use Carp; + +$VERSION = 1.08; +$Verbose ||= 0; + +sub import { + my $pkg = shift; + my $handler = \&handler_traceback; + my $saw_sig = 0; + my $untrapped = 0; + local $_; + + Arg_loop: + while (@_) { + $_ = shift; + if (/^[A-Z][A-Z0-9]*$/) { + $saw_sig++; + unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') { + print "Installing handler $handler for $_\n" if $Verbose; + $SIG{$_} = $handler; + } + } + elsif ($_ eq 'normal-signals') { + unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); + } + elsif ($_ eq 'error-signals') { + unshift @_, grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); + } + elsif ($_ eq 'old-interface-signals') { + unshift @_, + grep(exists $SIG{$_}, + qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); + } + elsif ($_ eq 'stack-trace') { + $handler = \&handler_traceback; + } + elsif ($_ eq 'die') { + $handler = \&handler_die; + } + elsif ($_ eq 'handler') { + @_ or croak "No argument specified after 'handler'"; + $handler = shift; + unless (ref $handler or $handler eq 'IGNORE' + or $handler eq 'DEFAULT') { + require Symbol; + $handler = Symbol::qualify($handler, (caller)[0]); + } + } + elsif ($_ eq 'untrapped') { + $untrapped = 1; + } + elsif ($_ eq 'any') { + $untrapped = 0; + } + elsif ($_ =~ /^\d/) { + $VERSION >= $_ or croak "sigtrap.pm version $_ required," + . " but this is only version $VERSION"; + } + else { + croak "Unrecognized argument $_"; + } + } + unless ($saw_sig) { + @_ = qw(old-interface-signals); + goto Arg_loop; + } +} + +sub handler_die { + croak "Caught a SIG$_[0]"; +} + +sub handler_traceback { + package DB; # To get subroutine args. + $SIG{'ABRT'} = DEFAULT; + kill 'ABRT', $$ if $panic++; + syswrite(STDERR, 'Caught a SIG', 12); + syswrite(STDERR, $_[0], length($_[0])); + syswrite(STDERR, ' at ', 4); + ($pack,$file,$line) = caller; + syswrite(STDERR, $file, length($file)); + syswrite(STDERR, ' line ', 6); + syswrite(STDERR, $line, length($line)); + syswrite(STDERR, "\n", 1); + + # Now go for broke. + for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { + @a = (); + for (@{[@args]}) { + s/([\'\\])/\\$1/g; + s/([^\0]*)/'$1'/ + unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; + require 'meta_notation.pm'; + $_ = _meta_notation($_) if /[[:^print:]]/a; + push(@a, $_); + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + $e =~ s/\n\s*\;\s*\Z// if $e; + $e =~ s/[\\\']/\\$1/g if $e; + if ($r) { + $s = "require '$e'"; + } elsif (defined $r) { + $s = "eval '$e'"; + } elsif ($s eq '(eval)') { + $s = "eval {...}"; + } + $f = "file '$f'" unless $f eq '-e'; + $mess = "$w$s$a called from $f line $l\n"; + syswrite(STDERR, $mess, length($mess)); + } + kill 'ABRT', $$; +} + +1; + +__END__ + +package DirHandle; + +our $VERSION = '1.05'; + + +require 5.000; +use Carp; +use Symbol; + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: DirHandle->new( [DIRNAME] )'; + my $class = shift; + my $dh = gensym; + if (@_) { + DirHandle::open($dh, $_[0]) + or return undef; + } + bless $dh, $class; +} + +sub DESTROY { + my ($dh) = @_; + # Don't warn about already being closed as it may have been closed + # correctly, or maybe never opened at all. + local($., $@, $!, $^E, $?); + no warnings 'io'; + closedir($dh); +} + +sub open { + @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; + my ($dh, $dirname) = @_; + opendir($dh, $dirname); +} + +sub close { + @_ == 1 or croak 'usage: $dh->close()'; + my ($dh) = @_; + closedir($dh); +} + +sub read { + @_ == 1 or croak 'usage: $dh->read()'; + my ($dh) = @_; + readdir($dh); +} + +sub rewind { + @_ == 1 or croak 'usage: $dh->rewind()'; + my ($dh) = @_; + rewinddir($dh); +} + +1; +use strict; +use warnings; + +# A tiny private library routine which is a helper to several Perl core +# modules, to allow a paradigm to be implemented in a single place. The name, +# contents, or even the existence of this file may be changed at any time and +# are NOT to be used by anything outside the Perl core. + +sub _meta_notation ($) { + + # Returns a copy of the input string with the nonprintable characters + # below 0x100 changed into printables. Any ASCII printables or above 0xFF + # are unchanged. (XXX Probably above-Latin1 characters should be + # converted to \X{...}) + # + # \0 .. \x1F (which are "\c@" .. "\c_") are changed into ^@, ^A, ^B, ... + # ^Z, ^[, ^\, ^], ^^, ^_ + # \c? is changed into ^?. + # + # The above accounts for all the ASCII-range nonprintables. + # + # On ASCII platforms, the upper-Latin1-range characters are converted to + # Meta notation, so that \xC1 becomes 'M-A', \xE2 becomes 'M-b', etc. + # This is how it always has worked, so is continued that way for backwards + # compatibility. The range \x80 .. \x9F becomes M-^@ .. M-^A, M-^B, ... + # M-^Z, M-^[, M-^\, M-^], M-^, M-^_ + # + # On EBCDIC platforms, the upper-Latin1-range characters are converted + # into '\x{...}' Meta notation doesn't make sense on EBCDIC platforms + # because the ASCII-range printables are a mixture of upper bit set or + # not. [A-Za-Z0-9] all have the upper bit set. The underscore likely + # doesn't; and other punctuation may or may not. There's no simple + # pattern. + + my $string = shift; + + $string =~ s/([\0-\037])/ + sprintf("^%c",utf8::unicode_to_native(ord($1)^64))/xeg; + $string =~ s/\c?/^?/g; + if (ord("A") == 65) { + $string =~ s/([\200-\237])/sprintf("M-^%c",(ord($1)&0177)^64)/eg; + $string =~ s/([\240-\377])/sprintf("M-%c" ,ord($1)&0177)/eg; + } + else { + no warnings 'experimental::regex_sets'; + # Leave alone things above \xff + $string =~ s/( (?[ [\x00-\xFF] & [:^print:]])) / + sprintf("\\x{%X}", ord($1))/xaeg; + } + + return $string; +} +1 +package autodie::Util; + +use strict; +use warnings; + +use Exporter 5.57 qw(import); + +use autodie::Scope::GuardStack; + +our @EXPORT_OK = qw( + fill_protos + install_subs + make_core_trampoline + on_end_of_compile_scope +); + +our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version + +# ABSTRACT: Internal Utility subroutines for autodie and Fatal + +# docs says we should pick __PACKAGE__ / +my $H_STACK_KEY = __PACKAGE__ . '/stack'; + +sub on_end_of_compile_scope { + my ($hook) = @_; + + # Dark magic to have autodie work under 5.8 + # Copied from namespace::clean, that copied it from + # autobox, that found it on an ancient scroll written + # in blood. + + # This magic bit causes %^H to be lexically scoped. + $^H |= 0x020000; + + my $stack = $^H{$H_STACK_KEY}; + if (not defined($stack)) { + $stack = autodie::Scope::GuardStack->new; + $^H{$H_STACK_KEY} = $stack; + } + + $stack->push_hook($hook); + return; +} + +# This code is based on code from the original Fatal. The "XXXX" +# remark is from the original code and its meaning is (sadly) unknown. +sub fill_protos { + my ($proto) = @_; + my ($n, $isref, @out, @out1, $seen_semi) = -1; + if ($proto =~ m{^\s* (?: [;] \s*)? \@}x) { + # prototype is entirely slurply - special case that does not + # require any handling. + return ([0, '@_']); + } + + while ($proto =~ /\S/) { + $n++; + push(@out1,[$n,@out]) if $seen_semi; + push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//; + push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//; + push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//; + $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ???? + die "Internal error: Unknown prototype letters: \"$proto\""; + } + push(@out1,[$n+1,@out]); + return @out1; +} + + +sub make_core_trampoline { + my ($call, $pkg, $proto_str) = @_; + my $trampoline_code = 'sub {'; + my $trampoline_sub; + my @protos = fill_protos($proto_str); + + foreach my $proto (@protos) { + local $" = ", "; # So @args is formatted correctly. + my ($count, @args) = @$proto; + if (@args && $args[-1] =~ m/[@#]_/) { + $trampoline_code .= qq/ + if (\@_ >= $count) { + return $call(@args); + } + /; + } else { + $trampoline_code .= qq< + if (\@_ == $count) { + return $call(@args); + } + >; + } + } + + $trampoline_code .= qq< require Carp; Carp::croak("Internal error in Fatal/autodie. Leak-guard failure"); } >; + my $E; + + { + local $@; + $trampoline_sub = eval "package $pkg;\n $trampoline_code"; ## no critic + $E = $@; + } + die "Internal error in Fatal/autodie: Leak-guard installation failure: $E" + if $E; + + return $trampoline_sub; +} + +# The code here is originally lifted from namespace::clean, +# by Robert "phaylon" Sedlacek. +# +# It's been redesigned after feedback from ikegami on perlmonks. +# See http://perlmonks.org/?node_id=693338 . Ikegami rocks. +# +# Given a package, and hash of (subname => subref) pairs, +# we install the given subroutines into the package. If +# a subref is undef, the subroutine is removed. Otherwise +# it replaces any existing subs which were already there. + +sub install_subs { + my ($target_pkg, $subs_to_reinstate) = @_; + + my $pkg_sym = "${target_pkg}::"; + + # It does not hurt to do this in a predictable order, and might help debugging. + foreach my $sub_name (sort keys(%{$subs_to_reinstate})) { + + # We will repeatedly mess with stuff that strict "refs" does + # not like. So lets just disable it once for this entire + # scope. + no strict qw(refs); ## no critic + + my $sub_ref = $subs_to_reinstate->{$sub_name}; + + my $full_path = ${pkg_sym}.${sub_name}; + my $oldglob = *$full_path; + + # Nuke the old glob. + delete($pkg_sym->{$sub_name}); + + # For some reason this local *alias = *$full_path triggers an + # "only used once" warning. Not entirely sure why, but at + # least it is easy to silence. + no warnings qw(once); + local *alias = *$full_path; + use warnings qw(once); + + # Copy innocent bystanders back. Note that we lose + # formats; it seems that Perl versions up to 5.10.0 + # have a bug which causes copying formats to end up in + # the scalar slot. Thanks to Ben Morrow for spotting this. + + foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) { + next unless defined(*$oldglob{$slot}); + *alias = *$oldglob{$slot}; + } + + if ($sub_ref) { + *$full_path = $sub_ref; + } + } + + return; +} + +1; + +__END__ + +package autodie::skip; +use strict; +use warnings; + +our $VERSION = '2.29'; # VERSION + +# This package exists purely so people can inherit from it, +# which isn't at all how roles are supposed to work, but it's +# how people will use them anyway. + +if ($] < 5.010) { + # Older Perls don't have a native ->DOES. Let's provide a cheap + # imitation here. + + *DOES = sub { return shift->isa(@_); }; +} + +1; + +__END__ + +package autodie::hints; + +use strict; +use warnings; + +use constant PERL58 => ( $] < 5.009 ); + +our $VERSION = '2.29001'; + +# ABSTRACT: Provide hints about user subroutines to autodie + + +# TODO: implement regular expression hints + +use constant UNDEF_ONLY => sub { not defined $_[0] }; +use constant EMPTY_OR_UNDEF => sub { + ! @_ or + @_==1 && !defined $_[0] +}; + +use constant EMPTY_ONLY => sub { @_ == 0 }; +use constant EMPTY_OR_FALSE => sub { + ! @_ or + @_==1 && !$_[0] +}; + +use constant SINGLE_TRUE => sub { @_ == 1 and not $_[0] }; + +use constant DEFAULT_HINTS => { + scalar => UNDEF_ONLY, + list => EMPTY_OR_UNDEF, +}; + + +use constant HINTS_PROVIDER => 'autodie::hints::provider'; + +our $DEBUG = 0; + +# Only ( undef ) is a strange but possible situation for very +# badly written code. It's not supported yet. + +my %Hints = ( + 'File::Copy::copy' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::move' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::cp' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, + 'File::Copy::mv' => { scalar => SINGLE_TRUE, list => SINGLE_TRUE }, +); + +# Start by using Sub::Identify if it exists on this system. + +eval { require Sub::Identify; Sub::Identify->import('get_code_info'); }; + +# If it doesn't exist, we'll define our own. This code is directly +# taken from Rafael Garcia's Sub::Identify 0.04, used under the same +# license as Perl itself. + +if ($@) { + require B; + + no warnings 'once'; + + *get_code_info = sub ($) { + + my ($coderef) = @_; + ref $coderef or return; + my $cv = B::svref_2object($coderef); + $cv->isa('B::CV') or return; + # bail out if GV is undefined + $cv->GV->isa('B::SPECIAL') and return; + + return ($cv->GV->STASH->NAME, $cv->GV->NAME); + }; + +} + +sub sub_fullname { + return join( '::', get_code_info( $_[1] ) ); +} + +my %Hints_loaded = (); + +sub load_hints { + my ($class, $sub) = @_; + + my ($package) = ( $sub =~ /(.*)::/ ); + + if (not defined $package) { + require Carp; + Carp::croak( + "Internal error in autodie::hints::load_hints - no package found. + "); + } + + # Do nothing if we've already tried to load hints for + # this package. + return if $Hints_loaded{$package}++; + + my $hints_available = 0; + + { + no strict 'refs'; ## no critic + + if ($package->can('DOES') and $package->DOES(HINTS_PROVIDER) ) { + $hints_available = 1; + } + elsif ( PERL58 and $package->isa(HINTS_PROVIDER) ) { + $hints_available = 1; + } + elsif ( ${"${package}::DOES"}{HINTS_PROVIDER.""} ) { + $hints_available = 1; + } + } + + return if not $hints_available; + + my %package_hints = %{ $package->AUTODIE_HINTS }; + + foreach my $sub (keys %package_hints) { + + my $hint = $package_hints{$sub}; + + # Ensure we have a package name. + $sub = "${package}::$sub" if $sub !~ /::/; + + # TODO - Currently we don't check for conflicts, should we? + $Hints{$sub} = $hint; + + $class->normalise_hints(\%Hints, $sub); + } + + return; + +} + +sub normalise_hints { + my ($class, $hints, $sub) = @_; + + if ( exists $hints->{$sub}->{fail} ) { + + if ( exists $hints->{$sub}->{scalar} or + exists $hints->{$sub}->{list} + ) { + # TODO: Turn into a proper diagnostic. + require Carp; + local $Carp::CarpLevel = 1; + Carp::croak("fail hints cannot be provided with either scalar or list hints for $sub"); + } + + # Set our scalar and list hints. + + $hints->{$sub}->{scalar} = + $hints->{$sub}->{list} = delete $hints->{$sub}->{fail}; + + return; + + } + + # Check to make sure all our hints exist. + + foreach my $hint (qw(scalar list)) { + if ( not exists $hints->{$sub}->{$hint} ) { + # TODO: Turn into a proper diagnostic. + require Carp; + local $Carp::CarpLevel = 1; + Carp::croak("$hint hint missing for $sub"); + } + } + + return; +} + +sub get_hints_for { + my ($class, $sub) = @_; + + my $subname = $class->sub_fullname( $sub ); + + # If we have hints loaded for a sub, then return them. + + if ( exists $Hints{ $subname } ) { + return $Hints{ $subname }; + } + + # If not, we try to load them... + + $class->load_hints( $subname ); + + # ...and try again! + + if ( exists $Hints{ $subname } ) { + return $Hints{ $subname }; + } + + # It's the caller's responsibility to use defaults if desired. + # This allows on autodie to insist on hints if needed. + + return; + +} + +sub set_hints_for { + my ($class, $sub, $hints) = @_; + + if (ref $sub) { + $sub = $class->sub_fullname( $sub ); + + require Carp; + + $sub or Carp::croak("Attempts to set_hints_for unidentifiable subroutine"); + } + + if ($DEBUG) { + warn "autodie::hints: Setting $sub to hints: $hints\n"; + } + + $Hints{ $sub } = $hints; + + $class->normalise_hints(\%Hints, $sub); + + return; +} + +1; + +__END__ + + +package autodie::exception; +use 5.008; +use strict; +use warnings; +use Carp qw(croak); + +our $VERSION = '2.29002'; +# ABSTRACT: Exceptions from autodying functions. + +our $DEBUG = 0; + +use overload + q{""} => "stringify", + # Overload smart-match only if we're using 5.10 or up + ($] >= 5.010 ? ('~~' => "matches") : ()), + fallback => 1 +; + +my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. + + + +sub args { return $_[0]->{$PACKAGE}{args}; } + + +sub function { return $_[0]->{$PACKAGE}{function}; } + + +sub file { return $_[0]->{$PACKAGE}{file}; } + + +sub package { return $_[0]->{$PACKAGE}{package}; } + + +sub caller { return $_[0]->{$PACKAGE}{caller}; } + + +sub line { return $_[0]->{$PACKAGE}{line}; } + + +# TODO: The comments above say this can be undefined. Is that actually +# the case? (With 'system', perhaps?) + +sub context { return $_[0]->{$PACKAGE}{context} } + + +sub return { return $_[0]->{$PACKAGE}{return} } + + +# TODO: Make errno part of a role. It doesn't make sense for +# everything. + +sub errno { return $_[0]->{$PACKAGE}{errno}; } + + +sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } + + +{ + my (%cache); + + sub matches { + my ($this, $that) = @_; + + # TODO - Handle references + croak "UNIMPLEMENTED" if ref $that; + + my $sub = $this->function; + + if ($DEBUG) { + my $sub2 = $this->function; + warn "Smart-matching $that against $sub / $sub2\n"; + } + + # Direct subname match. + return 1 if $that eq $sub; + return 1 if $that !~ /:/ and "CORE::$that" eq $sub; + return 0 if $that !~ /^:/; + + # Cached match / check tags. + require Fatal; + + if (exists $cache{$sub}{$that}) { + return $cache{$sub}{$that}; + } + + # This rather awful looking line checks to see if our sub is in the + # list of expanded tags, caches it, and returns the result. + + return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; + } +} + +# This exists primarily so that child classes can override or +# augment it if they wish. + +sub _expand_tag { + my ($this, @args) = @_; + + return Fatal->_expand_tag(@args); +} + + +# The table below records customer formatters. +# TODO - Should this be a package var instead? +# TODO - Should these be in a completely different file, or +# perhaps loaded on demand? Most formatters will never +# get used in most programs. + +my %formatter_of = ( + 'CORE::close' => \&_format_close, + 'CORE::open' => \&_format_open, + 'CORE::dbmopen' => \&_format_dbmopen, + 'CORE::flock' => \&_format_flock, + 'CORE::read' => \&_format_readwrite, + 'CORE::sysread' => \&_format_readwrite, + 'CORE::syswrite' => \&_format_readwrite, + 'CORE::chmod' => \&_format_chmod, + 'CORE::mkdir' => \&_format_mkdir, +); + +sub _beautify_arguments { + shift @_; + + # Walk through all our arguments, and... + # + # * Replace undef with the word 'undef' + # * Replace globs with the string '$fh' + # * Quote all other args. + foreach my $arg (@_) { + if (not defined($arg)) { $arg = 'undef' } + elsif (ref($arg) eq "GLOB") { $arg = '$fh' } + else { $arg = qq{'$arg'} } + } + + return @_; +} + +sub _trim_package_name { + # Info: The following is done since 05/2008 (which is before v1.10) + + # TODO: This is probably a good idea for CORE, is it + # a good idea for other subs? + + # Trim package name off dying sub for error messages + (my $name = $_[1]) =~ s/.*:://; + return $name; +} + +# Returns the parameter formatted as octal number +sub _octalize_number { + my $number = $_[1]; + + # Only reformat if it looks like a whole number + if ($number =~ /^\d+$/) { + $number = sprintf("%#04lo", $number); + } + + return $number; +} + +# TODO: Our tests only check LOCK_EX | LOCK_NB is properly +# formatted. Try other combinations and ensure they work +# correctly. + +sub _format_flock { + my ($this) = @_; + + require Fcntl; + + my $filehandle = $this->args->[0]; + my $raw_mode = $this->args->[1]; + + my $mode_type; + my $lock_unlock; + + if ($raw_mode & Fcntl::LOCK_EX() ) { + $lock_unlock = "lock"; + $mode_type = "for exclusive access"; + } + elsif ($raw_mode & Fcntl::LOCK_SH() ) { + $lock_unlock = "lock"; + $mode_type = "for shared access"; + } + elsif ($raw_mode & Fcntl::LOCK_UN() ) { + $lock_unlock = "unlock"; + $mode_type = ""; + } + else { + # I've got no idea what they're trying to do. + $lock_unlock = "lock"; + $mode_type = "with mode $raw_mode"; + } + + my $cooked_filehandle; + + if ($filehandle and not ref $filehandle) { + + # A package filehandle with a name! + + $cooked_filehandle = " $filehandle"; + } + else { + # Otherwise we have a scalar filehandle. + + $cooked_filehandle = ''; + + } + + local $! = $this->errno; + + return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; + +} + +# Default formatter for CORE::chmod +sub _format_chmod { + my ($this) = @_; + my @args = @{$this->args}; + + my $mode = shift @args; + local $! = $this->errno; + + $mode = $this->_octalize_number($mode); + + @args = $this->_beautify_arguments(@args); + + return "Can't chmod($mode, ". join(q{, }, @args) ."): $!"; +} + +# Default formatter for CORE::mkdir +sub _format_mkdir { + my ($this) = @_; + my @args = @{$this->args}; + + # If no mask is specified use default formatter + if (@args < 2) { + return $this->format_default; + } + + my $file = $args[0]; + my $mask = $args[1]; + local $! = $this->errno; + + $mask = $this->_octalize_number($mask); + + return "Can't mkdir('$file', $mask): '$!'"; +} + +# Default formatter for CORE::dbmopen +sub _format_dbmopen { + my ($this) = @_; + my @args = @{$this->args}; + + # TODO: Presently, $args flattens out the (usually empty) hash + # which is passed as the first argument to dbmopen. This is + # a bug in our args handling code (taking a reference to it would + # be better), but for the moment we'll just examine the end of + # our arguments list for message formatting. + + my $mode = $args[-1]; + my $file = $args[-2]; + + $mode = $this->_octalize_number($mode); + + local $! = $this->errno; + + return "Can't dbmopen(%hash, '$file', $mode): '$!'"; +} + +# Default formatter for CORE::close + +sub _format_close { + my ($this) = @_; + my $close_arg = $this->args->[0]; + + local $! = $this->errno; + + # If we've got an old-style filehandle, mention it. + if ($close_arg and not ref $close_arg) { + return "Can't close filehandle '$close_arg': '$!'"; + } + + # TODO - This will probably produce an ugly error. Test and fix. + return "Can't close($close_arg) filehandle: '$!'"; + +} + +# Default formatter for CORE::read, CORE::sysread and CORE::syswrite +# +# Similar to default formatter with the buffer filtered out as it +# may contain binary data. +sub _format_readwrite { + my ($this) = @_; + my $call = $this->_trim_package_name($this->function); + local $! = $this->errno; + + # These subs receive the following arguments (in order): + # + # * FILEHANDLE + # * SCALAR (buffer, we do not want to write this) + # * LENGTH (optional for syswrite) + # * OFFSET (optional for all) + my (@args) = @{$this->args}; + my $arg_name = $args[1]; + if (defined($arg_name)) { + if (ref($arg_name)) { + my $name = blessed($arg_name) || ref($arg_name); + $arg_name = "<${name}>"; + } else { + $arg_name = ''; + } + } else { + $arg_name = ''; + } + $args[1] = $arg_name; + + return "Can't $call(" . join(q{, }, @args) . "): $!"; +} + +# Default formatter for CORE::open + +use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; + +sub _format_open_with_mode { + my ($this, $mode, $file, $error) = @_; + + my $wordy_mode; + + if ($mode eq '<') { $wordy_mode = 'reading'; } + elsif ($mode eq '>') { $wordy_mode = 'writing'; } + elsif ($mode eq '>>') { $wordy_mode = 'appending'; } + + $file = '' if not defined $file; + + return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; + + Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); + +} + +sub _format_open { + my ($this) = @_; + + my @open_args = @{$this->args}; + + # Use the default formatter for single-arg and many-arg open + if (@open_args <= 1 or @open_args >= 4) { + return $this->format_default; + } + + # For two arg open, we have to extract the mode + if (@open_args == 2) { + my ($fh, $file) = @open_args; + + if (ref($fh) eq "GLOB") { + $fh = '$fh'; + } + + my ($mode) = $file =~ m{ + ^\s* # Spaces before mode + ( + (?> # Non-backtracking subexp. + < # Reading + |>>? # Writing/appending + ) + ) + [^&] # Not an ampersand (which means a dup) + }x; + + if (not $mode) { + # Maybe it's a 2-arg open without any mode at all? + # Detect the most simple case for this, where our + # file consists only of word characters. + + if ( $file =~ m{^\s*\w+\s*$} ) { + $mode = '<' + } + else { + # Otherwise, we've got no idea what's going on. + # Use the default. + return $this->format_default; + } + } + + # Localising $! means perl makes it a pretty error for us. + local $! = $this->errno; + + return $this->_format_open_with_mode($mode, $file, $!); + } + + # Here we must be using three arg open. + + my $file = $open_args[2]; + + local $! = $this->errno; + + my $mode = $open_args[1]; + + local $@; + + my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; + + return $msg if $msg; + + # Default message (for pipes and odd things) + + return "Can't open '$file' with mode '$open_args[1]': '$!'"; +} + + +sub register { + my ($class, $symbol, $handler) = @_; + + croak "Incorrect call to autodie::register" if @_ != 3; + + $formatter_of{$symbol} = $handler; + +} + + +# Simply produces the file and line number; intended to be added +# to the end of error messages. + +sub add_file_and_line { + my ($this) = @_; + + return sprintf(" at %s line %d\n", $this->file, $this->line); +} + + +sub stringify { + my ($this) = @_; + + my $call = $this->function; + my $msg; + + if ($DEBUG) { + my $dying_pkg = $this->package; + my $sub = $this->function; + my $caller = $this->caller; + warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; + } + + # TODO - This isn't using inheritance. Should it? + if ( my $sub = $formatter_of{$call} ) { + $msg = $sub->($this) . $this->add_file_and_line; + } else { + $msg = $this->format_default . $this->add_file_and_line; + } + $msg .= $this->{$PACKAGE}{_stack_trace} + if $Carp::Verbose; + + return $msg; +} + + +# TODO: This produces ugly errors. Is there any way we can +# dig around to find the actual variable names? I know perl 5.10 +# does some dark and terrible magicks to find them for undef warnings. + +sub format_default { + my ($this) = @_; + + my $call = $this->_trim_package_name($this->function); + + local $! = $this->errno; + + my @args = @{ $this->args() }; + @args = $this->_beautify_arguments(@args); + + # Format our beautiful error. + + return "Can't $call(". join(q{, }, @args) . "): $!" ; + + # TODO - Handle user-defined errors from hash. + + # TODO - Handle default error messages. + +} + + +sub new { + my ($class, @args) = @_; + + my $this = {}; + + bless($this,$class); + + # I'd love to use EVERY here, but it causes our code to die + # because it wants to stringify our objects before they're + # initialised, causing everything to explode. + + $this->_init(@args); + + return $this; +} + +sub _init { + + my ($this, %args) = @_; + + # Capturing errno here is not necessarily reliable. + my $original_errno = $!; + + our $init_called = 1; + + my $class = ref $this; + + # We're going to walk up our call stack, looking for the + # first thing that doesn't look like our exception + # code, autodie/Fatal, or some whacky eval. + + my ($package, $file, $line, $sub); + + my $depth = 0; + + while (1) { + $depth++; + + ($package, $file, $line, $sub) = CORE::caller($depth); + + # Skip up the call stack until we find something outside + # of the Fatal/autodie/eval space. + + next if $package->isa('Fatal'); + next if $package->isa($class); + next if $package->isa(__PACKAGE__); + + # Anything with the 'autodie::skip' role wants us to skip it. + # https://github.com/pjf/autodie/issues/15 + + next if ($package->can('DOES') and $package->DOES('autodie::skip')); + + next if $file =~ /^\(eval\s\d+\)$/; + + last; + + } + + # We now have everything correct, *except* for our subroutine + # name. If it's __ANON__ or (eval), then we need to keep on + # digging deeper into our stack to find the real name. However we + # don't update our other information, since that will be correct + # for our current exception. + + my $first_guess_subroutine = $sub; + + while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { + $depth++; + + $sub = (CORE::caller($depth))[3]; + } + + # If we end up falling out the bottom of our stack, then our + # __ANON__ guess is the best we can get. This includes situations + # where we were called from the top level of a program. + + if (not defined $sub) { + $sub = $first_guess_subroutine; + } + + $this->{$PACKAGE}{package} = $package; + $this->{$PACKAGE}{file} = $file; + $this->{$PACKAGE}{line} = $line; + $this->{$PACKAGE}{caller} = $sub; + + # Tranks to %Carp::CarpInternal all Fatal, autodie and + # autodie::exception stack frames are filtered already, but our + # nameless wrapper is still present, so strip that. + + my $trace = Carp::longmess(); + $trace =~ s/^\s*at \(eval[^\n]+\n//; + + # And if we see an __ANON__, then we'll replace that with the actual + # name of our autodying function. + + my $short_func = $args{function}; + $short_func =~ s/^CORE:://; + $trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/; + + # And now we just fill in all our attributes. + + $this->{$PACKAGE}{_stack_trace} = $trace; + + $this->{$PACKAGE}{errno} = $args{errno} || 0; + + $this->{$PACKAGE}{context} = $args{context}; + $this->{$PACKAGE}{return} = $args{return}; + $this->{$PACKAGE}{eval_error} = $args{eval_error}; + + $this->{$PACKAGE}{args} = $args{args} || []; + $this->{$PACKAGE}{function}= $args{function} or + croak("$class->new() called without function arg"); + + return $this; + +} + +1; + +__END__ + +package autodie::exception::system; +use 5.008; +use strict; +use warnings; +use parent 'autodie::exception'; +use Carp qw(croak); + +our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version + +# ABSTRACT: Exceptions from autodying system(). + +my $PACKAGE = __PACKAGE__; + + +sub _init { + my ($this, %args) = @_; + + $this->{$PACKAGE}{message} = $args{message} + || croak "'message' arg not supplied to autodie::exception::system->new"; + + return $this->SUPER::_init(%args); + +} + + +sub stringify { + + my ($this) = @_; + + return $this->{$PACKAGE}{message} . $this->add_file_and_line; + +} + +1; + +__END__ + +package autodie::Scope::Guard; + +use strict; +use warnings; + +# ABSTRACT: Wrapper class for calling subs at end of scope +our $VERSION = '2.29'; # VERSION + +# This code schedules the cleanup of subroutines at the end of +# scope. It's directly inspired by chocolateboy's excellent +# Scope::Guard module. + +sub new { + my ($class, $handler) = @_; + return bless($handler, $class); +} + +sub DESTROY { + my ($self) = @_; + + $self->(); +} + +1; + +__END__ + +package autodie::Scope::GuardStack; + +use strict; +use warnings; + +use autodie::Scope::Guard; + +# ABSTRACT: Hook stack for managing scopes via %^H +our $VERSION = '2.29'; # VERSION + +my $H_KEY_STEM = __PACKAGE__ . '/guard'; +my $COUNTER = 0; + +# This code schedules the cleanup of subroutines at the end of +# scope. It's directly inspired by chocolateboy's excellent +# Scope::Guard module. + +sub new { + my ($class) = @_; + + return bless([], $class); +} + +sub push_hook { + my ($self, $hook) = @_; + my $h_key = $H_KEY_STEM . ($COUNTER++); + my $size = @{$self}; + $^H{$h_key} = autodie::Scope::Guard->new(sub { + # Pop the stack until we reach the right size + # - this may seem weird, but it is to avoid relying + # on "destruction order" of keys in %^H. + # + # Example: + # { + # use autodie; # hook 1 + # no autodie; # hook 2 + # use autodie; # hook 3 + # } + # + # Here we want call hook 3, then hook 2 and finally hook 1. + # Any other order could have undesired consequences. + # + # Suppose hook 2 is destroyed first, it will pop hook 3 and + # then hook 2. hook 3 will then be destroyed, but do nothing + # since its "frame" was already popped and finally hook 1 + # will be popped and take its own frame with it. + # + # We need to check that $self still exists since things can get weird + # during global destruction. + $self->_pop_hook while $self && @{$self} > $size; + }); + push(@{$self}, [$hook, $h_key]); + return; +} + +sub _pop_hook { + my ($self) = @_; + my ($hook, $key) = @{ pop(@{$self}) }; + my $ref = delete($^H{$key}); + $hook->(); + return; +} + +sub DESTROY { + my ($self) = @_; + + # To be honest, I suspect @{$self} will always be empty here due + # to the subs in %^H having references to the stack (which would + # keep the stack alive until those have been destroyed). Anyhow, + # it never hurt to be careful. + $self->_pop_hook while @{$self}; + return; +} + +1; + +__END__ + +package Tie::Array; + +use 5.006_001; +use strict; +use Carp; +our $VERSION = '1.07'; + +# Pod documentation after __END__ below. + +sub DESTROY { } +sub EXTEND { } +sub UNSHIFT { scalar shift->SPLICE(0,0,@_) } +sub SHIFT { shift->SPLICE(0,1) } +sub CLEAR { shift->STORESIZE(0) } + +sub PUSH +{ + my $obj = shift; + my $i = $obj->FETCHSIZE; + $obj->STORE($i++, shift) while (@_); +} + +sub POP +{ + my $obj = shift; + my $newsize = $obj->FETCHSIZE - 1; + my $val; + if ($newsize >= 0) + { + $val = $obj->FETCH($newsize); + $obj->STORESIZE($newsize); + } + $val; +} + +sub SPLICE { + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + $len += $sz - $off if $len < 0; + my @result; + for (my $i = 0; $i < $len; $i++) { + push(@result,$obj->FETCH($off+$i)); + } + $off = $sz if $off > $sz; + $len -= $off + $len - $sz if $off + $len > $sz; + if (@_ > $len) { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } + } + elsif (@_ < $len) { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) { + $obj->STORE($off+$i,$_[$i]); + } + return wantarray ? @result : pop @result; +} + +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a DELETE method"; +} + +package Tie::StdArray; +our @ISA = 'Tie::Array'; + +sub TIEARRAY { bless [], $_[0] } +sub FETCHSIZE { scalar @{$_[0]} } +sub STORESIZE { $#{$_[0]} = $_[1]-1 } +sub STORE { $_[0]->[$_[1]] = $_[2] } +sub FETCH { $_[0]->[$_[1]] } +sub CLEAR { @{$_[0]} = () } +sub POP { pop(@{$_[0]}) } +sub PUSH { my $o = shift; push(@$o,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub EXISTS { exists $_[0]->[$_[1]] } +sub DELETE { delete $_[0]->[$_[1]] } + +sub SPLICE +{ + my $ob = shift; + my $sz = $ob->FETCHSIZE; + my $off = @_ ? shift : 0; + $off += $sz if $off < 0; + my $len = @_ ? shift : $sz-$off; + return splice(@$ob,$off,$len,@_); +} + +1; + +__END__ + +package Tie::SubstrHash; + +our $VERSION = '1.00'; + + +use Carp; + +sub TIEHASH { + my $pack = shift; + my ($klen, $vlen, $tsize) = @_; + my $rlen = 1 + $klen + $vlen; + $tsize = [$tsize, + findgteprime($tsize * 1.1)]; # Allow 10% empty. + local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; + $$self[0] x= $rlen * $tsize->[1]; + $self; +} + +sub CLEAR { + local($self) = @_; + $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]); + $$self[5] = 0; + $$self[6] = -1; +} + +sub FETCH { + local($self,$key) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + return undef; + } + elsif (ord($record) == 1) { + } + elsif (substr($record, 1, $klen) eq $key) { + return substr($record, 1+$klen, $vlen); + } + &rehash; + } +} + +sub STORE { + local($self,$key,$val) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0]; + croak(qq/Value "$val" is not $vlen characters long/) + if length($val) != $vlen; + my $writeoffset; + + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + $writeoffset = $offset unless defined $writeoffset; + substr($$self[0], $writeoffset, $rlen) = $record; + ++$$self[5]; + return; + } + elsif (ord($record) == 1) { + $writeoffset = $offset unless defined $writeoffset; + } + elsif (substr($record, 1, $klen) eq $key) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + substr($$self[0], $offset, $rlen) = $record; + return; + } + &rehash; + } +} + +sub DELETE { + local($self,$key) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + return undef; + } + elsif (ord($record) == 1) { + } + elsif (substr($record, 1, $klen) eq $key) { + substr($$self[0], $offset, 1) = "\1"; + return substr($record, 1+$klen, $vlen); + --$$self[5]; + } + &rehash; + } +} + +sub FIRSTKEY { + local($self) = @_; + $$self[6] = -1; + &NEXTKEY; +} + +sub NEXTKEY { + local($self) = @_; + local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; + for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { + next unless substr($$self[0], $iterix * $rlen, 1) eq "\2"; + $$self[6] = $iterix; + return substr($$self[0], $iterix * $rlen + 1, $klen); + } + $$self[6] = -1; + undef; +} + +sub EXISTS { + croak "Tie::SubstrHash does not support exists()"; +} + +sub hashkey { + croak(qq/Key "$key" is not $klen characters long/) + if length($key) != $klen; + $hash = 2; + for (unpack('C*', $key)) { + $hash = $hash * 33 + $_; + &_hashwrap if $hash >= 1e13; + } + &_hashwrap if $hash >= $tsize->[1]; + $hash = 1 unless $hash; + $hashbase = $hash; +} + +sub _hashwrap { + $hash -= int($hash / $tsize->[1]) * $tsize->[1]; +} + +sub rehash { + $hash += $hashbase; + $hash -= $tsize->[1] if $hash >= $tsize->[1]; +} + +# using POSIX::ceil() would be too heavy, and not all platforms have it. +sub ceil { + my $num = shift; + $num = int($num + 1) unless $num == int $num; + return $num; +} + +# See: +# +# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html +# + +sub findgteprime { # find the smallest prime integer greater than or equal to + use integer; + + my $num = ceil(shift); + return 2 if $num <= 2; + + $num++ unless $num % 2; + my $i; + my $sqrtnum = int sqrt $num; + my $sqrtnumsquared = $sqrtnum * $sqrtnum; + + NUM: + for (;; $num += 2) { + if ($sqrtnumsquared < $num) { + $sqrtnum++; + $sqrtnumsquared = $sqrtnum * $sqrtnum; + } + for ($i = 3; $i <= $sqrtnum; $i += 2) { + next NUM unless $num % $i; + } + return $num; + } +} + +1; +package Tie::StdHandle; + +use strict; + +use Tie::Handle; +our @ISA = 'Tie::Handle'; +our $VERSION = '4.5'; + + +sub TIEHANDLE +{ + my $class = shift; + my $fh = \do { local *HANDLE}; + bless $fh,$class; + $fh->OPEN(@_) if (@_); + return $fh; +} + +sub EOF { eof($_[0]) } +sub TELL { tell($_[0]) } +sub FILENO { fileno($_[0]) } +sub SEEK { seek($_[0],$_[1],$_[2]) } +sub CLOSE { close($_[0]) } +sub BINMODE { binmode($_[0]) } + +sub OPEN +{ + $_[0]->CLOSE if defined($_[0]->FILENO); + @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); +} + +sub READ { &CORE::read(shift, \shift, @_) } +sub READLINE { my $fh = $_[0]; <$fh> } +sub GETC { getc($_[0]) } + +sub WRITE +{ + my $fh = $_[0]; + local $\; # don't print any line terminator + print $fh substr($_[1], $_[3], $_[2]); +} + + +1; +use strict; +package Tie::Memoize; +use Tie::Hash; +our @ISA = 'Tie::ExtraHash'; +our $VERSION = '1.1'; + +our $exists_token = \undef; + +sub croak {require Carp; goto &Carp::croak} + +# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function; +# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ] + +sub FETCH { + my ($h,$key) = ($_[0][0], $_[1]); + my $res = $h->{$key}; + return $res if defined $res; # Shortcut if accessible + return $res if exists $h->{$key}; # Accessible, but undef + my $cache = $_[0][1]{$key}; + return if defined $cache and not $cache; # Known to not exist + my @res = $_[0][2]->($key, $_[0][4]); # Autoload + $_[0][1]{$key} = 0, return unless @res; # Cache non-existence + delete $_[0][1]{$key}; # Clear existence cache, not needed any more + $_[0][0]{$key} = $res[0]; # Store data and return +} + +sub EXISTS { + my ($a,$key) = (shift, shift); + return 1 if exists $a->[0]{$key}; # Have data + my $cache = $a->[1]{$key}; + return $cache if defined $cache; # Existence cache + my @res = $a->[3]($key,$a->[4]); + $a->[1]{$key} = 0, return unless @res; # Cache non-existence + # Now we know it exists + return ($a->[1]{$key} = 1) if $a->[5]; # Only existence reported + # Now know the value + $a->[0]{$key} = $res[0]; # Store data + return 1 +} + +sub TIEHASH { + croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2; + croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6; + push @_, undef if @_ < 3; # Data + push @_, $_[1] if @_ < 4; # exists + push @_, {} while @_ < 6; # initial value and caches + bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0] +} + +1; + + + +package Tie::File; +require 5.005; +use Carp ':DEFAULT', 'confess'; +use POSIX 'SEEK_SET'; +use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY'; +sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY } + + +$VERSION = "1.02"; +my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes +my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records +my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful + +my %good_opt = map {$_ => 1, "-$_" => 1} + qw(memory dw_size mode recsep discipline + autodefer autochomp autodefer_threshhold concurrent); + +sub TIEARRAY { + if (@_ % 2 != 0) { + croak "usage: tie \@array, $_[0], filename, [option => value]..."; + } + my ($pack, $file, %opts) = @_; + + # transform '-foo' keys into 'foo' keys + for my $key (keys %opts) { + unless ($good_opt{$key}) { + croak("$pack: Unrecognized option '$key'\n"); + } + my $okey = $key; + if ($key =~ s/^-+//) { + $opts{$key} = delete $opts{$okey}; + } + } + + if ($opts{concurrent}) { + croak("$pack: concurrent access not supported yet\n"); + } + + unless (defined $opts{memory}) { + # default is the larger of the default cache size and the + # deferred-write buffer size (if specified) + $opts{memory} = $DEFAULT_MEMORY_SIZE; + $opts{memory} = $opts{dw_size} + if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE; + # Dora Winifred Read + } + $opts{dw_size} = $opts{memory} unless defined $opts{dw_size}; + if ($opts{dw_size} > $opts{memory}) { + croak("$pack: dw_size may not be larger than total memory allocation\n"); + } + # are we in deferred-write mode? + $opts{defer} = 0 unless defined $opts{defer}; + $opts{deferred} = {}; # no records are presently deferred + $opts{deferred_s} = 0; # count of total bytes in ->{deferred} + $opts{deferred_max} = -1; # empty + + # What's a good way to arrange that this class can be overridden? + $opts{cache} = Tie::File::Cache->new($opts{memory}); + + # autodeferment is enabled by default + $opts{autodefer} = 1 unless defined $opts{autodefer}; + $opts{autodeferring} = 0; # but is not initially active + $opts{ad_history} = []; + $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD + unless defined $opts{autodefer_threshhold}; + $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD + unless defined $opts{autodefer_filelen_threshhold}; + + $opts{offsets} = [0]; + $opts{filename} = $file; + unless (defined $opts{recsep}) { + $opts{recsep} = _default_recsep(); + } + $opts{recseplen} = length($opts{recsep}); + if ($opts{recseplen} == 0) { + croak "Empty record separator not supported by $pack"; + } + + $opts{autochomp} = 1 unless defined $opts{autochomp}; + + $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode}; + $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY); + $opts{sawlastrec} = undef; + + my $fh; + + if (UNIVERSAL::isa($file, 'GLOB')) { + # We use 1 here on the theory that some systems + # may not indicate failure if we use 0. + # MSWin32 does not indicate failure with 0, but I don't know if + # it will indicate failure with 1 or not. + unless (seek $file, 1, SEEK_SET) { + croak "$pack: your filehandle does not appear to be seekable"; + } + seek $file, 0, SEEK_SET; # put it back + $fh = $file; # setting binmode is the user's problem + } elsif (ref $file) { + croak "usage: tie \@array, $pack, filename, [option => value]..."; + } else { + # $fh = \do { local *FH }; # XXX this is buggy + if ($] < 5.006) { + # perl 5.005 and earlier don't autovivify filehandles + require Symbol; + $fh = Symbol::gensym(); + } + sysopen $fh, $file, $opts{mode}, 0666 or return; + binmode $fh; + ++$opts{ourfh}; + } + { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write + if (defined $opts{discipline} && $] >= 5.006) { + # This avoids a compile-time warning under 5.005 + eval 'binmode($fh, $opts{discipline})'; + croak $@ if $@ =~ /unknown discipline/i; + die if $@; + } + $opts{fh} = $fh; + + bless \%opts => $pack; +} + +sub FETCH { + my ($self, $n) = @_; + my $rec; + + # check the defer buffer + $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n}; + $rec = $self->_fetch($n) unless defined $rec; + + # inlined _chomp1 + substr($rec, - $self->{recseplen}) = "" + if defined $rec && $self->{autochomp}; + $rec; +} + +# Chomp many records in-place; return nothing useful +sub _chomp { + my $self = shift; + return unless $self->{autochomp}; + if ($self->{autochomp}) { + for (@_) { + next unless defined; + substr($_, - $self->{recseplen}) = ""; + } + } +} + +# Chomp one record in-place; return modified record +sub _chomp1 { + my ($self, $rec) = @_; + return $rec unless $self->{autochomp}; + return unless defined $rec; + substr($rec, - $self->{recseplen}) = ""; + $rec; +} + +sub _fetch { + my ($self, $n) = @_; + + # check the record cache + { my $cached = $self->{cache}->lookup($n); + return $cached if defined $cached; + } + + if ($#{$self->{offsets}} < $n) { + return if $self->{eof}; # request for record beyond end of file + my $o = $self->_fill_offsets_to($n); + # If it's still undefined, there is no such record, so return 'undef' + return unless defined $o; + } + + my $fh = $self->{FH}; + $self->_seek($n); # we can do this now that offsets is populated + my $rec = $self->_read_record; + +# If we happen to have just read the first record, check to see if +# the length of the record matches what 'tell' says. If not, Tie::File +# won't work, and should drop dead. +# +# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) { +# if (defined $self->{discipline}) { +# croak "I/O discipline $self->{discipline} not supported"; +# } else { +# croak "File encoding not supported"; +# } +# } + + $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing}; + $rec; +} + +sub STORE { + my ($self, $n, $rec) = @_; + die "STORE called from _check_integrity!" if $DIAGNOSTIC; + + $self->_fixrecs($rec); + + if ($self->{autodefer}) { + $self->_annotate_ad_history($n); + } + + return $self->_store_deferred($n, $rec) if $self->_is_deferring; + + + # We need this to decide whether the new record will fit + # It incidentally populates the offsets table + # Note we have to do this before we alter the cache + # 20020324 Wait, but this DOES alter the cache. TODO BUG? + my $oldrec = $self->_fetch($n); + + if (not defined $oldrec) { + # We're storing a record beyond the end of the file + $self->_extend_file_to($n+1); + $oldrec = $self->{recsep}; + } +# return if $oldrec eq $rec; # don't bother + my $len_diff = length($rec) - length($oldrec); + + # length($oldrec) here is not consistent with text mode TODO XXX BUG + $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec)); + $self->_oadjust([$n, 1, $rec]); + $self->{cache}->update($n, $rec); +} + +sub _store_deferred { + my ($self, $n, $rec) = @_; + $self->{cache}->remove($n); + my $old_deferred = $self->{deferred}{$n}; + + if (defined $self->{deferred_max} && $n > $self->{deferred_max}) { + $self->{deferred_max} = $n; + } + $self->{deferred}{$n} = $rec; + + my $len_diff = length($rec); + $len_diff -= length($old_deferred) if defined $old_deferred; + $self->{deferred_s} += $len_diff; + $self->{cache}->adj_limit(-$len_diff); + if ($self->{deferred_s} > $self->{dw_size}) { + $self->_flush; + } elsif ($self->_cache_too_full) { + $self->_cache_flush; + } +} + +# Remove a single record from the deferred-write buffer without writing it +# The record need not be present +sub _delete_deferred { + my ($self, $n) = @_; + my $rec = delete $self->{deferred}{$n}; + return unless defined $rec; + + if (defined $self->{deferred_max} + && $n == $self->{deferred_max}) { + undef $self->{deferred_max}; + } + + $self->{deferred_s} -= length $rec; + $self->{cache}->adj_limit(length $rec); +} + +sub FETCHSIZE { + my $self = shift; + my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets; + + my $top_deferred = $self->_defer_max; + $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1; + $n; +} + +sub STORESIZE { + my ($self, $len) = @_; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('STORESIZE'); + } + + my $olen = $self->FETCHSIZE; + return if $len == $olen; # Woo-hoo! + + # file gets longer + if ($len > $olen) { + if ($self->_is_deferring) { + for ($olen .. $len-1) { + $self->_store_deferred($_, $self->{recsep}); + } + } else { + $self->_extend_file_to($len); + } + return; + } + + # file gets shorter + if ($self->_is_deferring) { + # TODO maybe replace this with map-plus-assignment? + for (grep $_ >= $len, keys %{$self->{deferred}}) { + $self->_delete_deferred($_); + } + $self->{deferred_max} = $len-1; + } + + $self->_seek($len); + $self->_chop_file; + $#{$self->{offsets}} = $len; +# $self->{offsets}[0] = 0; # in case we just chopped this + + $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys); +} + +### OPTIMIZE ME +### It should not be necessary to do FETCHSIZE +### Just seek to the end of the file. +sub PUSH { + my $self = shift; + $self->SPLICE($self->FETCHSIZE, scalar(@_), @_); + + # No need to return: + # $self->FETCHSIZE; # because av.c takes care of this for me +} + +sub POP { + my $self = shift; + my $size = $self->FETCHSIZE; + return if $size == 0; +# print STDERR "# POPPITY POP POP POP\n"; + scalar $self->SPLICE($size-1, 1); +} + +sub SHIFT { + my $self = shift; + scalar $self->SPLICE(0, 1); +} + +sub UNSHIFT { + my $self = shift; + $self->SPLICE(0, 0, @_); + # $self->FETCHSIZE; # av.c takes care of this for me +} + +sub CLEAR { + my $self = shift; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('CLEAR'); + } + + $self->_seekb(0); + $self->_chop_file; + $self->{cache}->set_limit($self->{memory}); + $self->{cache}->empty; + @{$self->{offsets}} = (0); + %{$self->{deferred}}= (); + $self->{deferred_s} = 0; + $self->{deferred_max} = -1; +} + +sub EXTEND { + my ($self, $n) = @_; + + # No need to pre-extend anything in this case + return if $self->_is_deferring; + + $self->_fill_offsets_to($n); + $self->_extend_file_to($n); +} + +sub DELETE { + my ($self, $n) = @_; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('DELETE'); + } + + my $lastrec = $self->FETCHSIZE-1; + my $rec = $self->FETCH($n); + $self->_delete_deferred($n) if $self->_is_deferring; + if ($n == $lastrec) { + $self->_seek($n); + $self->_chop_file; + $#{$self->{offsets}}--; + $self->{cache}->remove($n); + # perhaps in this case I should also remove trailing null records? + # 20020316 + # Note that delete @a[-3..-1] deletes the records in the wrong order, + # so we only chop the very last one out of the file. We could repair this + # by tracking deleted records inside the object. + } elsif ($n < $lastrec) { + $self->STORE($n, ""); + } + $rec; +} + +sub EXISTS { + my ($self, $n) = @_; + return 1 if exists $self->{deferred}{$n}; + $n < $self->FETCHSIZE; +} + +sub SPLICE { + my $self = shift; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('SPLICE'); + } + + $self->_flush if $self->_is_deferring; # move this up? + if (wantarray) { + $self->_chomp(my @a = $self->_splice(@_)); + @a; + } else { + $self->_chomp1(scalar $self->_splice(@_)); + } +} + +sub DESTROY { + my $self = shift; + $self->flush if $self->_is_deferring; + $self->{cache}->delink if defined $self->{cache}; # break circular link + if ($self->{fh} and $self->{ourfh}) { + delete $self->{ourfh}; + close delete $self->{fh}; + } +} + +sub _splice { + my ($self, $pos, $nrecs, @data) = @_; + my @result; + + $pos = 0 unless defined $pos; + + # Deal with negative and other out-of-range positions + # Also set default for $nrecs + { + my $oldsize = $self->FETCHSIZE; + $nrecs = $oldsize unless defined $nrecs; + my $oldpos = $pos; + + if ($pos < 0) { + $pos += $oldsize; + if ($pos < 0) { + croak "Modification of non-creatable array value attempted, " . + "subscript $oldpos"; + } + } + + if ($pos > $oldsize) { + return unless @data; + $pos = $oldsize; # This is what perl does for normal arrays + } + + # The manual is very unclear here + if ($nrecs < 0) { + $nrecs = $oldsize - $pos + $nrecs; + $nrecs = 0 if $nrecs < 0; + } + + # nrecs is too big---it really means "until the end" + # 20030507 + if ($nrecs + $pos > $oldsize) { + $nrecs = $oldsize - $pos; + } + } + + $self->_fixrecs(@data); + my $data = join '', @data; + my $datalen = length $data; + my $oldlen = 0; + + # compute length of data being removed + for ($pos .. $pos+$nrecs-1) { + last unless defined $self->_fill_offsets_to($_); + my $rec = $self->_fetch($_); + last unless defined $rec; + push @result, $rec; + + # Why don't we just use length($rec) here? + # Because that record might have come from the cache. _splice + # might have been called to flush out the deferred-write records, + # and in this case length($rec) is the length of the record to be + # *written*, not the length of the actual record in the file. But + # the offsets are still true. 20020322 + $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_] + if defined $self->{offsets}[$_+1]; + } + $self->_fill_offsets_to($pos+$nrecs); + + # Modify the file + $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen); + # Adjust the offsets table + $self->_oadjust([$pos, $nrecs, @data]); + + { # Take this read cache stuff out into a separate function + # You made a half-attempt to put it into _oadjust. + # Finish something like that up eventually. + # STORE also needs to do something similarish + + # update the read cache, part 1 + # modified records + for ($pos .. $pos+$nrecs-1) { + my $new = $data[$_-$pos]; + if (defined $new) { + $self->{cache}->update($_, $new); + } else { + $self->{cache}->remove($_); + } + } + + # update the read cache, part 2 + # moved records - records past the site of the change + # need to be renumbered + # Maybe merge this with the previous block? + { + my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys; + my @newkeys = map $_-$nrecs+@data, @oldkeys; + $self->{cache}->rekey(\@oldkeys, \@newkeys); + } + + # Now there might be too much data in the cache, if we spliced out + # some short records and spliced in some long ones. If so, flush + # the cache. + $self->_cache_flush; + } + + # Yes, the return value of 'splice' *is* actually this complicated + wantarray ? @result : @result ? $result[-1] : undef; +} + + +# write data into the file +# $data is the data to be written. +# it should be written at position $pos, and should overwrite +# exactly $len of the following bytes. +# Note that if length($data) > $len, the subsequent bytes will have to +# be moved up, and if length($data) < $len, they will have to +# be moved down +sub _twrite { + my ($self, $data, $pos, $len) = @_; + + unless (defined $pos) { + die "\$pos was undefined in _twrite"; + } + + my $len_diff = length($data) - $len; + + if ($len_diff == 0) { # Woo-hoo! + my $fh = $self->{fh}; + $self->_seekb($pos); + $self->_write_record($data); + return; # well, that was easy. + } + + # the two records are of different lengths + # our strategy here: rewrite the tail of the file, + # reading ahead one buffer at a time + # $bufsize is required to be at least as large as the data we're overwriting + my $bufsize = _bufsize($len_diff); + my ($writepos, $readpos) = ($pos, $pos+$len); + my $next_block; + my $more_data; + + # Seems like there ought to be a way to avoid the repeated code + # and the special case here. The read(1) is also a little weird. + # Think about this. + do { + $self->_seekb($readpos); + my $br = read $self->{fh}, $next_block, $bufsize; + $more_data = read $self->{fh}, my($dummy), 1; + $self->_seekb($writepos); + $self->_write_record($data); + $readpos += $br; + $writepos += length $data; + $data = $next_block; + } while $more_data; + $self->_seekb($writepos); + $self->_write_record($next_block); + + # There might be leftover data at the end of the file + $self->_chop_file if $len_diff < 0; +} + +# _iwrite(D, S, E) +# Insert text D at position S. +# Let C = E-S-|D|. If C < 0; die. +# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E). +# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched. +# +# In a later version, don't read the entire intervening area into +# memory at once; do the copying block by block. +sub _iwrite { + my $self = shift; + my ($D, $s, $e) = @_; + my $d = length $D; + my $c = $e-$s-$d; + local *FH = $self->{fh}; + confess "Not enough space to insert $d bytes between $s and $e" + if $c < 0; + confess "[$s,$e) is an invalid insertion range" if $e < $s; + + $self->_seekb($s); + read FH, my $buf, $e-$s; + + $D .= substr($buf, 0, $c, ""); + + $self->_seekb($s); + $self->_write_record($D); + + return $buf; +} + +# Like _twrite, but the data-pos-len triple may be repeated; you may +# write several chunks. All the writing will be done in +# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap. +sub _mtwrite { + my $self = shift; + my $unwritten = ""; + my $delta = 0; + + @_ % 3 == 0 + or die "Arguments to _mtwrite did not come in groups of three"; + + while (@_) { + my ($data, $pos, $len) = splice @_, 0, 3; + my $end = $pos + $len; # The OLD end of the segment to be replaced + $data = $unwritten . $data; + $delta -= length($unwritten); + $unwritten = ""; + $pos += $delta; # This is where the data goes now + my $dlen = length $data; + $self->_seekb($pos); + if ($len >= $dlen) { # the data will fit + $self->_write_record($data); + $delta += ($dlen - $len); # everything following moves down by this much + $data = ""; # All the data in the buffer has been written + } else { # won't fit + my $writable = substr($data, 0, $len - $delta, ""); + $self->_write_record($writable); + $delta += ($dlen - $len); # everything following moves down by this much + } + + # At this point we've written some but maybe not all of the data. + # There might be a gap to close up, or $data might still contain a + # bunch of unwritten data that didn't fit. + my $ndlen = length $data; + if ($delta == 0) { + $self->_write_record($data); + } elsif ($delta < 0) { + # upcopy (close up gap) + if (@_) { + $self->_upcopy($end, $end + $delta, $_[1] - $end); + } else { + $self->_upcopy($end, $end + $delta); + } + } else { + # downcopy (insert data that didn't fit; replace this data in memory + # with _later_ data that doesn't fit) + if (@_) { + $unwritten = $self->_downcopy($data, $end, $_[1] - $end); + } else { + # Make the file longer to accommodate the last segment that doesn't + $unwritten = $self->_downcopy($data, $end); + } + } + } +} + +# Copy block of data of length $len from position $spos to position $dpos +# $dpos must be <= $spos +# +# If $len is undefined, go all the way to the end of the file +# and then truncate it ($spos - $dpos bytes will be removed) +sub _upcopy { + my $blocksize = 8192; + my ($self, $spos, $dpos, $len) = @_; + if ($dpos > $spos) { + die "source ($spos) was upstream of destination ($dpos) in _upcopy"; + } elsif ($dpos == $spos) { + return; + } + + while (! defined ($len) || $len > 0) { + my $readsize = ! defined($len) ? $blocksize + : $len > $blocksize ? $blocksize + : $len; + + my $fh = $self->{fh}; + $self->_seekb($spos); + my $bytes_read = read $fh, my($data), $readsize; + $self->_seekb($dpos); + if ($data eq "") { + $self->_chop_file; + last; + } + $self->_write_record($data); + $spos += $bytes_read; + $dpos += $bytes_read; + $len -= $bytes_read if defined $len; + } +} + +# Write $data into a block of length $len at position $pos, +# moving everything in the block forwards to make room. +# Instead of writing the last length($data) bytes from the block +# (because there isn't room for them any longer) return them. +# +# Undefined $len means 'until the end of the file' +sub _downcopy { + my $blocksize = 8192; + my ($self, $data, $pos, $len) = @_; + my $fh = $self->{fh}; + + while (! defined $len || $len > 0) { + my $readsize = ! defined($len) ? $blocksize + : $len > $blocksize? $blocksize : $len; + $self->_seekb($pos); + read $fh, my($old), $readsize; + my $last_read_was_short = length($old) < $readsize; + $data .= $old; + my $writable; + if ($last_read_was_short) { + # If last read was short, then $data now contains the entire rest + # of the file, so there's no need to write only one block of it + $writable = $data; + $data = ""; + } else { + $writable = substr($data, 0, $readsize, ""); + } + last if $writable eq ""; + $self->_seekb($pos); + $self->_write_record($writable); + last if $last_read_was_short && $data eq ""; + $len -= $readsize if defined $len; + $pos += $readsize; + } + return $data; +} + +# Adjust the object data structures following an '_mtwrite' +# Arguments are +# [$pos, $nrecs, @length] items +# indicating that $nrecs records were removed at $recpos (a record offset) +# and replaced with records of length @length... +# Arguments guarantee that $recpos is strictly increasing. +# No return value +sub _oadjust { + my $self = shift; + my $delta = 0; + my $delta_recs = 0; + my $prev_end = -1; + my %newkeys; + + for (@_) { + my ($pos, $nrecs, @data) = @$_; + $pos += $delta_recs; + + # Adjust the offsets of the records after the previous batch up + # to the first new one of this batch + for my $i ($prev_end+2 .. $pos - 1) { + $self->{offsets}[$i] += $delta; + $newkey{$i} = $i + $delta_recs; + } + + $prev_end = $pos + @data - 1; # last record moved on this pass + + # Remove the offsets for the removed records; + # replace with the offsets for the inserted records + my @newoff = ($self->{offsets}[$pos] + $delta); + for my $i (0 .. $#data) { + my $newlen = length $data[$i]; + push @newoff, $newoff[$i] + $newlen; + $delta += $newlen; + } + + for my $i ($pos .. $pos+$nrecs-1) { + last if $i+1 > $#{$self->{offsets}}; + my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i]; + $delta -= $oldlen; + } + +# # also this data has changed, so update it in the cache +# for (0 .. $#data) { +# $self->{cache}->update($pos + $_, $data[$_]); +# } +# if ($delta_recs) { +# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys; +# my @newkeys = map $_ + $delta_recs, @oldkeys; +# $self->{cache}->rekey(\@oldkeys, \@newkeys); +# } + + # replace old offsets with new + splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff; + # What if we just spliced out the end of the offsets table? + # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO + + $delta_recs += @data - $nrecs; # net change in total number of records + } + + # The trailing records at the very end of the file + if ($delta) { + for my $i ($prev_end+2 .. $#{$self->{offsets}}) { + $self->{offsets}[$i] += $delta; + } + } + + # If we scrubbed out all known offsets, regenerate the trivial table + # that knows that the file does indeed start at 0. + $self->{offsets}[0] = 0 unless @{$self->{offsets}}; + # If the file got longer, the offsets table is no longer complete + # $self->{eof} = 0 if $delta_recs > 0; + + # Now there might be too much data in the cache, if we spliced out + # some short records and spliced in some long ones. If so, flush + # the cache. + $self->_cache_flush; +} + +# If a record does not already end with the appropriate terminator +# string, append one. +sub _fixrecs { + my $self = shift; + for (@_) { + $_ = "" unless defined $_; + $_ .= $self->{recsep} + unless substr($_, - $self->{recseplen}) eq $self->{recsep}; + } +} + + +################################################################ +# +# Basic read, write, and seek +# + +# seek to the beginning of record #$n +# Assumes that the offsets table is already correctly populated +# +# Note that $n=-1 has a special meaning here: It means the start of +# the last known record; this may or may not be the very last record +# in the file, depending on whether the offsets table is fully populated. +# +sub _seek { + my ($self, $n) = @_; + my $o = $self->{offsets}[$n]; + defined($o) + or confess("logic error: undefined offset for record $n"); + seek $self->{fh}, $o, SEEK_SET + or confess "Couldn't seek filehandle: $!"; # "Should never happen." +} + +# seek to byte $b in the file +sub _seekb { + my ($self, $b) = @_; + seek $self->{fh}, $b, SEEK_SET + or die "Couldn't seek filehandle: $!"; # "Should never happen." +} + +# populate the offsets table up to the beginning of record $n +# return the offset of record $n +sub _fill_offsets_to { + my ($self, $n) = @_; + + return $self->{offsets}[$n] if $self->{eof}; + + my $fh = $self->{fh}; + local *OFF = $self->{offsets}; + my $rec; + + until ($#OFF >= $n) { + $self->_seek(-1); # tricky -- see comment at _seek + $rec = $self->_read_record; + if (defined $rec) { + push @OFF, int(tell $fh); # Tels says that int() saves memory here + } else { + $self->{eof} = 1; + return; # It turns out there is no such record + } + } + + # we have now read all the records up to record n-1, + # so we can return the offset of record n + $OFF[$n]; +} + +sub _fill_offsets { + my ($self) = @_; + + my $fh = $self->{fh}; + local *OFF = $self->{offsets}; + + $self->_seek(-1); # tricky -- see comment at _seek + + # Tels says that inlining read_record() would make this loop + # five times faster. 20030508 + while ( defined $self->_read_record()) { + # int() saves us memory here + push @OFF, int(tell $fh); + } + + $self->{eof} = 1; + $#OFF; +} + +# assumes that $rec is already suitably terminated +sub _write_record { + my ($self, $rec) = @_; + my $fh = $self->{fh}; + local $\ = ""; + print $fh $rec + or die "Couldn't write record: $!"; # "Should never happen." +# $self->{_written} += length($rec); +} + +sub _read_record { + my $self = shift; + my $rec; + { local $/ = $self->{recsep}; + my $fh = $self->{fh}; + $rec = <$fh>; + } + return unless defined $rec; + if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) { + # improperly terminated final record --- quietly fix it. +# my $ac = substr($rec, -$self->{recseplen}); +# $ac =~ s/\n/\\n/g; + $self->{sawlastrec} = 1; + unless ($self->{rdonly}) { + local $\ = ""; + my $fh = $self->{fh}; + print $fh $self->{recsep}; + } + $rec .= $self->{recsep}; + } +# $self->{_read} += length($rec) if defined $rec; + $rec; +} + +sub _rw_stats { + my $self = shift; + @{$self}{'_read', '_written'}; +} + +################################################################ +# +# Read cache management + +sub _cache_flush { + my ($self) = @_; + $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s}); +} + +sub _cache_too_full { + my $self = shift; + $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory}; +} + +################################################################ +# +# File custodial services +# + + +# We have read to the end of the file and have the offsets table +# entirely populated. Now we need to write a new record beyond +# the end of the file. We prepare for this by writing +# empty records into the file up to the position we want +# +# assumes that the offsets table already contains the offset of record $n, +# if it exists, and extends to the end of the file if not. +sub _extend_file_to { + my ($self, $n) = @_; + $self->_seek(-1); # position after the end of the last record + my $pos = $self->{offsets}[-1]; + + # the offsets table has one entry more than the total number of records + my $extras = $n - $#{$self->{offsets}}; + + # Todo : just use $self->{recsep} x $extras here? + while ($extras-- > 0) { + $self->_write_record($self->{recsep}); + push @{$self->{offsets}}, int(tell $self->{fh}); + } +} + +# Truncate the file at the current position +sub _chop_file { + my $self = shift; + truncate $self->{fh}, tell($self->{fh}); +} + + +# compute the size of a buffer suitable for moving +# all the data in a file forward $n bytes +# ($n may be negative) +# The result should be at least $n. +sub _bufsize { + my $n = shift; + return 8192 if $n <= 0; + my $b = $n & ~8191; + $b += 8192 if $n & 8191; + $b; +} + +################################################################ +# +# Miscellaneous public methods +# + +# Lock the file +sub flock { + my ($self, $op) = @_; + unless (@_ <= 3) { + my $pack = ref $self; + croak "Usage: $pack\->flock([OPERATION])"; + } + my $fh = $self->{fh}; + $op = LOCK_EX unless defined $op; + my $locked = flock $fh, $op; + + if ($locked && ($op & (LOCK_EX | LOCK_SH))) { + # If you're locking the file, then presumably it's because + # there might have been a write access by another process. + # In that case, the read cache contents and the offsets table + # might be invalid, so discard them. 20030508 + $self->{offsets} = [0]; + $self->{cache}->empty; + } + + $locked; +} + +# Get/set autochomp option +sub autochomp { + my $self = shift; + if (@_) { + my $old = $self->{autochomp}; + $self->{autochomp} = shift; + $old; + } else { + $self->{autochomp}; + } +} + +# Get offset table entries; returns offset of nth record +sub offset { + my ($self, $n) = @_; + + if ($#{$self->{offsets}} < $n) { + return if $self->{eof}; # request for record beyond the end of file + my $o = $self->_fill_offsets_to($n); + # If it's still undefined, there is no such record, so return 'undef' + return unless defined $o; + } + + $self->{offsets}[$n]; +} + +sub discard_offsets { + my $self = shift; + $self->{offsets} = [0]; +} + +################################################################ +# +# Matters related to deferred writing +# + +# Defer writes +sub defer { + my $self = shift; + $self->_stop_autodeferring; + @{$self->{ad_history}} = (); + $self->{defer} = 1; +} + +# Flush deferred writes +# +# This could be better optimized to write the file in one pass, instead +# of one pass per block of records. But that will require modifications +# to _twrite, so I should have a good _twrite test suite first. +sub flush { + my $self = shift; + + $self->_flush; + $self->{defer} = 0; +} + +sub _old_flush { + my $self = shift; + my @writable = sort {$a<=>$b} (keys %{$self->{deferred}}); + + while (@writable) { + # gather all consecutive records from the front of @writable + my $first_rec = shift @writable; + my $last_rec = $first_rec+1; + ++$last_rec, shift @writable while @writable && $last_rec == $writable[0]; + --$last_rec; + $self->_fill_offsets_to($last_rec); + $self->_extend_file_to($last_rec); + $self->_splice($first_rec, $last_rec-$first_rec+1, + @{$self->{deferred}}{$first_rec .. $last_rec}); + } + + $self->_discard; # clear out defered-write-cache +} + +sub _flush { + my $self = shift; + my @writable = sort {$a<=>$b} (keys %{$self->{deferred}}); + my @args; + my @adjust; + + while (@writable) { + # gather all consecutive records from the front of @writable + my $first_rec = shift @writable; + my $last_rec = $first_rec+1; + ++$last_rec, shift @writable while @writable && $last_rec == $writable[0]; + --$last_rec; + my $end = $self->_fill_offsets_to($last_rec+1); + if (not defined $end) { + $self->_extend_file_to($last_rec); + $end = $self->{offsets}[$last_rec]; + } + my ($start) = $self->{offsets}[$first_rec]; + push @args, + join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data + $start, # position + $end-$start; # length + push @adjust, [$first_rec, # starting at this position... + $last_rec-$first_rec+1, # this many records... + # are replaced with these... + @{$self->{deferred}}{$first_rec .. $last_rec}, + ]; + } + + $self->_mtwrite(@args); # write multiple record groups + $self->_discard; # clear out defered-write-cache + $self->_oadjust(@adjust); +} + +# Discard deferred writes and disable future deferred writes +sub discard { + my $self = shift; + $self->_discard; + $self->{defer} = 0; +} + +# Discard deferred writes, but retain old deferred writing mode +sub _discard { + my $self = shift; + %{$self->{deferred}} = (); + $self->{deferred_s} = 0; + $self->{deferred_max} = -1; + $self->{cache}->set_limit($self->{memory}); +} + +# Deferred writing is enabled, either explicitly ($self->{defer}) +# or automatically ($self->{autodeferring}) +sub _is_deferring { + my $self = shift; + $self->{defer} || $self->{autodeferring}; +} + +# The largest record number of any deferred record +sub _defer_max { + my $self = shift; + return $self->{deferred_max} if defined $self->{deferred_max}; + my $max = -1; + for my $key (keys %{$self->{deferred}}) { + $max = $key if $key > $max; + } + $self->{deferred_max} = $max; + $max; +} + +################################################################ +# +# Matters related to autodeferment +# + +# Get/set autodefer option +sub autodefer { + my $self = shift; + if (@_) { + my $old = $self->{autodefer}; + $self->{autodefer} = shift; + if ($old) { + $self->_stop_autodeferring; + @{$self->{ad_history}} = (); + } + $old; + } else { + $self->{autodefer}; + } +} + +# The user is trying to store record #$n Record that in the history, +# and then enable (or disable) autodeferment if that seems useful. +# Note that it's OK for $n to be a non-number, as long as the function +# is prepared to deal with that. Nobody else looks at the ad_history. +# +# Now, what does the ad_history mean, and what is this function doing? +# Essentially, the idea is to enable autodeferring when we see that the +# user has made three consecutive STORE calls to three consecutive records. +# ("Three" is actually ->{autodefer_threshhold}.) +# A STORE call for record #$n inserts $n into the autodefer history, +# and if the history contains three consecutive records, we enable +# autodeferment. An ad_history of [X, Y] means that the most recent +# STOREs were for records X, X+1, ..., Y, in that order. +# +# Inserting a nonconsecutive number erases the history and starts over. +# +# Performing a special operation like SPLICE erases the history. +# +# There's one special case: CLEAR means that CLEAR was just called. +# In this case, we prime the history with [-2, -1] so that if the next +# write is for record 0, autodeferring goes on immediately. This is for +# the common special case of "@a = (...)". +# +sub _annotate_ad_history { + my ($self, $n) = @_; + return unless $self->{autodefer}; # feature is disabled + return if $self->{defer}; # already in explicit defer mode + return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold}; + + local *H = $self->{ad_history}; + if ($n eq 'CLEAR') { + @H = (-2, -1); # prime the history with fake records + $self->_stop_autodeferring; + } elsif ($n =~ /^\d+$/) { + if (@H == 0) { + @H = ($n, $n); + } else { # @H == 2 + if ($H[1] == $n-1) { # another consecutive record + $H[1]++; + if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) { + $self->{autodeferring} = 1; + } + } else { # nonconsecutive- erase and start over + @H = ($n, $n); + $self->_stop_autodeferring; + } + } + } else { # SPLICE or STORESIZE or some such + @H = (); + $self->_stop_autodeferring; + } +} + +# If autodeferring was enabled, cut it out and discard the history +sub _stop_autodeferring { + my $self = shift; + if ($self->{autodeferring}) { + $self->_flush; + } + $self->{autodeferring} = 0; +} + +################################################################ + + +# This is NOT a method. It is here for two reasons: +# 1. To factor a fairly complicated block out of the constructor +# 2. To provide access for the test suite, which need to be sure +# files are being written properly. +sub _default_recsep { + my $recsep = $/; + if ($^O eq 'MSWin32') { # Dos too? + # Windows users expect files to be terminated with \r\n + # But $/ is set to \n instead + # Note that this also transforms \n\n into \r\n\r\n. + # That is a feature. + $recsep =~ s/\n/\r\n/g; + } + $recsep; +} + +# Utility function for _check_integrity +sub _ci_warn { + my $msg = shift; + $msg =~ s/\n/\\n/g; + $msg =~ s/\r/\\r/g; + print "# $msg\n"; +} + +# Given a file, make sure the cache is consistent with the +# file contents and the internal data structures are consistent with +# each other. Returns true if everything checks out, false if not +# +# The $file argument is no longer used. It is retained for compatibility +# with the existing test suite. +sub _check_integrity { + my ($self, $file, $warn) = @_; + my $rsl = $self->{recseplen}; + my $rs = $self->{recsep}; + my $good = 1; + local *_; # local $_ does not work here + local $DIAGNOSTIC = 1; + + if (not defined $rs) { + _ci_warn("recsep is undef!"); + $good = 0; + } elsif ($rs eq "") { + _ci_warn("recsep is empty!"); + $good = 0; + } elsif ($rsl != length $rs) { + my $ln = length $rs; + _ci_warn("recsep <$rs> has length $ln, should be $rsl"); + $good = 0; + } + + if (not defined $self->{offsets}[0]) { + _ci_warn("offset 0 is missing!"); + $good = 0; + + } elsif ($self->{offsets}[0] != 0) { + _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!"); + $good = 0; + } + + my $cached = 0; + { + local *F = $self->{fh}; + seek F, 0, SEEK_SET; + local $. = 0; + local $/ = $rs; + + while () { + my $n = $. - 1; + my $cached = $self->{cache}->_produce($n); + my $offset = $self->{offsets}[$.]; + my $ao = tell F; + if (defined $offset && $offset != $ao) { + _ci_warn("rec $n: offset <$offset> actual <$ao>"); + $good = 0; + } + if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) { + $good = 0; + _ci_warn("rec $n: cached <$cached> actual <$_>"); + } + if (defined $cached && substr($cached, -$rsl) ne $rs) { + $good = 0; + _ci_warn("rec $n in the cache is missing the record separator"); + } + if (! defined $offset && $self->{eof}) { + $good = 0; + _ci_warn("The offset table was marked complete, but it is missing " . + "element $."); + } + } + if (@{$self->{offsets}} > $.+1) { + $good = 0; + my $n = @{$self->{offsets}}; + _ci_warn("The offset table has $n items, but the file has only $."); + } + + my $deferring = $self->_is_deferring; + for my $n ($self->{cache}->ckeys) { + my $r = $self->{cache}->_produce($n); + $cached += length($r); + next if $n+1 <= $.; # checked this already + _ci_warn("spurious caching of record $n"); + $good = 0; + } + my $b = $self->{cache}->bytes; + if ($cached != $b) { + _ci_warn("cache size is $b, should be $cached"); + $good = 0; + } + } + + # That cache has its own set of tests + $good = 0 unless $self->{cache}->_check_integrity; + + # Now let's check the deferbuffer + # Unless deferred writing is enabled, it should be empty + if (! $self->_is_deferring && %{$self->{deferred}}) { + _ci_warn("deferred writing disabled, but deferbuffer nonempty"); + $good = 0; + } + + # Any record in the deferbuffer should *not* be present in the readcache + my $deferred_s = 0; + while (my ($n, $r) = each %{$self->{deferred}}) { + $deferred_s += length($r); + if (defined $self->{cache}->_produce($n)) { + _ci_warn("record $n is in the deferbuffer *and* the readcache"); + $good = 0; + } + if (substr($r, -$rsl) ne $rs) { + _ci_warn("rec $n in the deferbuffer is missing the record separator"); + $good = 0; + } + } + + # Total size of deferbuffer should match internal total + if ($deferred_s != $self->{deferred_s}) { + _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s"); + $good = 0; + } + + # Total size of deferbuffer should not exceed the specified limit + if ($deferred_s > $self->{dw_size}) { + _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit " . + "of $self->{dw_size}"); + $good = 0; + } + + # Total size of cached data should not exceed the specified limit + if ($deferred_s + $cached > $self->{memory}) { + my $total = $deferred_s + $cached; + _ci_warn("total stored data size is $total which exceeds the limit " . + "of $self->{memory}"); + $good = 0; + } + + # Stuff related to autodeferment + if (!$self->{autodefer} && @{$self->{ad_history}}) { + _ci_warn("autodefer is disabled, but ad_history is nonempty"); + $good = 0; + } + if ($self->{autodeferring} && $self->{defer}) { + _ci_warn("both autodeferring and explicit deferring are active"); + $good = 0; + } + if (@{$self->{ad_history}} == 0) { + # That's OK, no additional tests required + } elsif (@{$self->{ad_history}} == 2) { + my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}}; + if (@non_number) { + my $msg; + { local $" = ')('; + $msg = "ad_history contains non-numbers (@{$self->{ad_history}})"; + } + _ci_warn($msg); + $good = 0; + } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) { + _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}"); + $good = 0; + } + } else { + _ci_warn("ad_history has bad length <@{$self->{ad_history}}>"); + $good = 0; + } + + $good; +} + +################################################################ +# +# Tie::File::Cache +# +# Read cache + +package Tie::File::Cache; +$Tie::File::Cache::VERSION = $Tie::File::VERSION; +use Carp ':DEFAULT', 'confess'; + +sub HEAP () { 0 } +sub HASH () { 1 } +sub MAX () { 2 } +sub BYTES() { 3 } +#sub STAT () { 4 } # Array with request statistics for each record +#sub MISS () { 5 } # Total number of cache misses +#sub REQ () { 6 } # Total number of cache requests +use strict 'vars'; + +sub new { + my ($pack, $max) = @_; + local *_; + croak "missing argument to ->new" unless defined $max; + my $self = []; + bless $self => $pack; + @$self = (Tie::File::Heap->new($self), {}, $max, 0); + $self; +} + +sub adj_limit { + my ($self, $n) = @_; + $self->[MAX] += $n; +} + +sub set_limit { + my ($self, $n) = @_; + $self->[MAX] = $n; +} + +# For internal use only +# Will be called by the heap structure to notify us that a certain +# piece of data has moved from one heap element to another. +# $k is the hash key of the item +# $n is the new index into the heap at which it is stored +# If $n is undefined, the item has been removed from the heap. +sub _heap_move { + my ($self, $k, $n) = @_; + if (defined $n) { + $self->[HASH]{$k} = $n; + } else { + delete $self->[HASH]{$k}; + } +} + +sub insert { + my ($self, $key, $val) = @_; + local *_; + croak "missing argument to ->insert" unless defined $key; + unless (defined $self->[MAX]) { + confess "undefined max" ; + } + confess "undefined val" unless defined $val; + return if length($val) > $self->[MAX]; + +# if ($self->[STAT]) { +# $self->[STAT][$key] = 1; +# return; +# } + + my $oldnode = $self->[HASH]{$key}; + if (defined $oldnode) { + my $oldval = $self->[HEAP]->set_val($oldnode, $val); + $self->[BYTES] -= length($oldval); + } else { + $self->[HEAP]->insert($key, $val); + } + $self->[BYTES] += length($val); + $self->flush if $self->[BYTES] > $self->[MAX]; +} + +sub expire { + my $self = shift; + my $old_data = $self->[HEAP]->popheap; + return unless defined $old_data; + $self->[BYTES] -= length $old_data; + $old_data; +} + +sub remove { + my ($self, @keys) = @_; + my @result; + +# if ($self->[STAT]) { +# for my $key (@keys) { +# $self->[STAT][$key] = 0; +# } +# return; +# } + + for my $key (@keys) { + next unless exists $self->[HASH]{$key}; + my $old_data = $self->[HEAP]->remove($self->[HASH]{$key}); + $self->[BYTES] -= length $old_data; + push @result, $old_data; + } + @result; +} + +sub lookup { + my ($self, $key) = @_; + local *_; + croak "missing argument to ->lookup" unless defined $key; + +# if ($self->[STAT]) { +# $self->[MISS]++ if $self->[STAT][$key]++ == 0; +# $self->[REQ]++; +# my $hit_rate = 1 - $self->[MISS] / $self->[REQ]; +# # Do some testing to determine this threshhold +# $#$self = STAT - 1 if $hit_rate > 0.20; +# } + + if (exists $self->[HASH]{$key}) { + $self->[HEAP]->lookup($self->[HASH]{$key}); + } else { + return; + } +} + +# For internal use only +sub _produce { + my ($self, $key) = @_; + my $loc = $self->[HASH]{$key}; + return unless defined $loc; + $self->[HEAP][$loc][2]; +} + +# For internal use only +sub _promote { + my ($self, $key) = @_; + $self->[HEAP]->promote($self->[HASH]{$key}); +} + +sub empty { + my ($self) = @_; + %{$self->[HASH]} = (); + $self->[BYTES] = 0; + $self->[HEAP]->empty; +# @{$self->[STAT]} = (); +# $self->[MISS] = 0; +# $self->[REQ] = 0; +} + +sub is_empty { + my ($self) = @_; + keys %{$self->[HASH]} == 0; +} + +sub update { + my ($self, $key, $val) = @_; + local *_; + croak "missing argument to ->update" unless defined $key; + if (length($val) > $self->[MAX]) { + my ($oldval) = $self->remove($key); + $self->[BYTES] -= length($oldval) if defined $oldval; + } elsif (exists $self->[HASH]{$key}) { + my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val); + $self->[BYTES] += length($val); + $self->[BYTES] -= length($oldval) if defined $oldval; + } else { + $self->[HEAP]->insert($key, $val); + $self->[BYTES] += length($val); + } + $self->flush; +} + +sub rekey { + my ($self, $okeys, $nkeys) = @_; + local *_; + my %map; + @map{@$okeys} = @$nkeys; + croak "missing argument to ->rekey" unless defined $nkeys; + croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys; + my %adjusted; # map new keys to heap indices + # You should be able to cut this to one loop TODO XXX + for (0 .. $#$okeys) { + $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]}; + } + while (my ($nk, $ix) = each %adjusted) { + # @{$self->[HASH]}{keys %adjusted} = values %adjusted; + $self->[HEAP]->rekey($ix, $nk); + $self->[HASH]{$nk} = $ix; + } +} + +sub ckeys { + my $self = shift; + my @a = keys %{$self->[HASH]}; + @a; +} + +# Return total amount of cached data +sub bytes { + my $self = shift; + $self->[BYTES]; +} + +# Expire oldest item from cache until cache size is smaller than $max +sub reduce_size_to { + my ($self, $max) = @_; + until ($self->[BYTES] <= $max) { + # Note that Tie::File::Cache::expire has been inlined here + my $old_data = $self->[HEAP]->popheap; + return unless defined $old_data; + $self->[BYTES] -= length $old_data; + } +} + +# Why not just $self->reduce_size_to($self->[MAX])? +# Try this when things stabilize TODO XXX +# If the cache is too full, expire the oldest records +sub flush { + my $self = shift; + $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX]; +} + +# For internal use only +sub _produce_lru { + my $self = shift; + $self->[HEAP]->expire_order; +} + +BEGIN { *_ci_warn = \&Tie::File::_ci_warn } + +sub _check_integrity { # For CACHE + my $self = shift; + my $good = 1; + + # Test HEAP + $self->[HEAP]->_check_integrity or $good = 0; + + # Test HASH + my $bytes = 0; + for my $k (keys %{$self->[HASH]}) { + if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) { + $good = 0; + _ci_warn "Cache hash key <$k> is non-numeric"; + } + + my $h = $self->[HASH]{$k}; + if (! defined $h) { + $good = 0; + _ci_warn "Heap index number for key $k is undefined"; + } elsif ($h == 0) { + $good = 0; + _ci_warn "Heap index number for key $k is zero"; + } else { + my $j = $self->[HEAP][$h]; + if (! defined $j) { + $good = 0; + _ci_warn "Heap contents key $k (=> $h) are undefined"; + } else { + $bytes += length($j->[2]); + if ($k ne $j->[1]) { + $good = 0; + _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k"; + } + } + } + } + + # Test BYTES + if ($bytes != $self->[BYTES]) { + $good = 0; + _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]"; + } + + # Test MAX + if ($bytes > $self->[MAX]) { + $good = 0; + _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]"; + } + + return $good; +} + +sub delink { + my $self = shift; + $self->[HEAP] = undef; # Bye bye heap +} + +################################################################ +# +# Tie::File::Heap +# +# Heap data structure for use by cache LRU routines + +package Tie::File::Heap; +use Carp ':DEFAULT', 'confess'; +$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION; +sub SEQ () { 0 }; +sub KEY () { 1 }; +sub DAT () { 2 }; + +sub new { + my ($pack, $cache) = @_; + die "$pack: Parent cache object $cache does not support _heap_move method" + unless eval { $cache->can('_heap_move') }; + my $self = [[0,$cache,0]]; + bless $self => $pack; +} + +# Allocate a new sequence number, larger than all previously allocated numbers +sub _nseq { + my $self = shift; + $self->[0][0]++; +} + +sub _cache { + my $self = shift; + $self->[0][1]; +} + +sub _nelts { + my $self = shift; + $self->[0][2]; +} + +sub _nelts_inc { + my $self = shift; + ++$self->[0][2]; +} + +sub _nelts_dec { + my $self = shift; + --$self->[0][2]; +} + +sub is_empty { + my $self = shift; + $self->_nelts == 0; +} + +sub empty { + my $self = shift; + $#$self = 0; + $self->[0][2] = 0; + $self->[0][0] = 0; # might as well reset the sequence numbers +} + +# notify the parent cache object that we moved something +sub _heap_move { + my $self = shift; + $self->_cache->_heap_move(@_); +} + +# Insert a piece of data into the heap with the indicated sequence number. +# The item with the smallest sequence number is always at the top. +# If no sequence number is specified, allocate a new one and insert the +# item at the bottom. +sub insert { + my ($self, $key, $data, $seq) = @_; + $seq = $self->_nseq unless defined $seq; + $self->_insert_new([$seq, $key, $data]); +} + +# Insert a new, fresh item at the bottom of the heap +sub _insert_new { + my ($self, $item) = @_; + my $i = @$self; + $i = int($i/2) until defined $self->[$i/2]; + $self->[$i] = $item; + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $self->_nelts_inc; +} + +# Insert [$data, $seq] pair at or below item $i in the heap. +# If $i is omitted, default to 1 (the top element.) +sub _insert { + my ($self, $item, $i) = @_; +# $self->_check_loc($i) if defined $i; + $i = 1 unless defined $i; + until (! defined $self->[$i]) { + if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older + ($self->[$i], $item) = ($item, $self->[$i]); + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + } + # If either is undefined, go that way. Otherwise, choose at random + my $dir; + $dir = 0 if !defined $self->[2*$i]; + $dir = 1 if !defined $self->[2*$i+1]; + $dir = int(rand(2)) unless defined $dir; + $i = 2*$i + $dir; + } + $self->[$i] = $item; + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $self->_nelts_inc; +} + +# Remove the item at node $i from the heap, moving child items upwards. +# The item with the smallest sequence number is always at the top. +# Moving items upwards maintains this condition. +# Return the removed item. Return undef if there was no item at node $i. +sub remove { + my ($self, $i) = @_; + $i = 1 unless defined $i; + my $top = $self->[$i]; + return unless defined $top; + while (1) { + my $ii; + my ($L, $R) = (2*$i, 2*$i+1); + + # If either is undefined, go the other way. + # Otherwise, go towards the smallest. + last unless defined $self->[$L] || defined $self->[$R]; + $ii = $R if not defined $self->[$L]; + $ii = $L if not defined $self->[$R]; + unless (defined $ii) { + $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R; + } + + $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $i = $ii; # Fill new vacated spot + } + $self->[0][1]->_heap_move($top->[KEY], undef); + undef $self->[$i]; + $self->_nelts_dec; + return $top->[DAT]; +} + +sub popheap { + my $self = shift; + $self->remove(1); +} + +# set the sequence number of the indicated item to a higher number +# than any other item in the heap, and bubble the item down to the +# bottom. +sub promote { + my ($self, $n) = @_; +# $self->_check_loc($n); + $self->[$n][SEQ] = $self->_nseq; + my $i = $n; + while (1) { + my ($L, $R) = (2*$i, 2*$i+1); + my $dir; + last unless defined $self->[$L] || defined $self->[$R]; + $dir = $R unless defined $self->[$L]; + $dir = $L unless defined $self->[$R]; + unless (defined $dir) { + $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R; + } + @{$self}[$i, $dir] = @{$self}[$dir, $i]; + for ($i, $dir) { + $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_]; + } + $i = $dir; + } +} + +# Return item $n from the heap, promoting its LRU status +sub lookup { + my ($self, $n) = @_; +# $self->_check_loc($n); + my $val = $self->[$n]; + $self->promote($n); + $val->[DAT]; +} + + +# Assign a new value for node $n, promoting it to the bottom of the heap +sub set_val { + my ($self, $n, $val) = @_; +# $self->_check_loc($n); + my $oval = $self->[$n][DAT]; + $self->[$n][DAT] = $val; + $self->promote($n); + return $oval; +} + +# The hash key has changed for an item; +# alter the heap's record of the hash key +sub rekey { + my ($self, $n, $new_key) = @_; +# $self->_check_loc($n); + $self->[$n][KEY] = $new_key; +} + +sub _check_loc { + my ($self, $n) = @_; + unless (1 || defined $self->[$n]) { + confess "_check_loc($n) failed"; + } +} + +BEGIN { *_ci_warn = \&Tie::File::_ci_warn } + +sub _check_integrity { + my $self = shift; + my $good = 1; + my %seq; + + unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) { + _ci_warn "Element 0 of heap corrupt"; + $good = 0; + } + $good = 0 unless $self->_satisfies_heap_condition(1); + for my $i (2 .. $#{$self}) { + my $p = int($i/2); # index of parent node + if (defined $self->[$i] && ! defined $self->[$p]) { + _ci_warn "Element $i of heap defined, but parent $p isn't"; + $good = 0; + } + + if (defined $self->[$i]) { + if ($seq{$self->[$i][SEQ]}) { + my $seq = $self->[$i][SEQ]; + _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq"; + $good = 0; + } else { + $seq{$self->[$i][SEQ]} = $i; + } + } + } + + return $good; +} + +sub _satisfies_heap_condition { + my $self = shift; + my $n = shift || 1; + my $good = 1; + for (0, 1) { + my $c = $n*2 + $_; + next unless defined $self->[$c]; + if ($self->[$n][SEQ] >= $self->[$c]) { + _ci_warn "Node $n of heap does not predate node $c"; + $good = 0 ; + } + $good = 0 unless $self->_satisfies_heap_condition($c); + } + return $good; +} + +# Return a list of all the values, sorted by expiration order +sub expire_order { + my $self = shift; + my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes; + map { $_->[KEY] } @nodes; +} + +sub _nodes { + my $self = shift; + my $i = shift || 1; + return unless defined $self->[$i]; + ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1)); +} + +"Cogito, ergo sum."; # don't forget to return a true value from the file + +__END__ + + +package Tie::Hash; + +our $VERSION = '1.05'; + + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIEHASH(@_); +} + +# Grandfather "new" + +sub TIEHASH { + my $pkg = shift; + my $pkg_new = $pkg -> can ('new'); + + if ($pkg_new and $pkg ne __PACKAGE__) { + my $my_new = __PACKAGE__ -> can ('new'); + if ($pkg_new == $my_new) { + # + # Prevent recursion + # + croak "$pkg must define either a TIEHASH() or a new() method"; + } + + warnings::warnif ("WARNING: calling ${pkg}->new since " . + "${pkg}->TIEHASH is missing"); + $pkg -> new (@_); + } + else { + croak "$pkg doesn't define a TIEHASH method"; + } +} + +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; +} + +sub CLEAR { + my $self = shift; + my $key = $self->FIRSTKEY(@_); + my @keys; + + while (defined $key) { + push @keys, $key; + $key = $self->NEXTKEY(@_, $key); + } + foreach $key (@keys) { + $self->DELETE(@_, $key); + } +} + +# The Tie::StdHash package implements standard perl hash behaviour. +# It exists to act as a base class for classes which only wish to +# alter some parts of their behaviour. + +package Tie::StdHash; +# @ISA = qw(Tie::Hash); # would inherit new() only + +sub TIEHASH { bless {}, $_[0] } +sub STORE { $_[0]->{$_[1]} = $_[2] } +sub FETCH { $_[0]->{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } +sub NEXTKEY { each %{$_[0]} } +sub EXISTS { exists $_[0]->{$_[1]} } +sub DELETE { delete $_[0]->{$_[1]} } +sub CLEAR { %{$_[0]} = () } +sub SCALAR { scalar %{$_[0]} } + +package Tie::ExtraHash; + +sub TIEHASH { my $p = shift; bless [{}, @_], $p } +sub STORE { $_[0][0]{$_[1]} = $_[2] } +sub FETCH { $_[0][0]{$_[1]} } +sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } +sub NEXTKEY { each %{$_[0][0]} } +sub EXISTS { exists $_[0][0]->{$_[1]} } +sub DELETE { delete $_[0][0]->{$_[1]} } +sub CLEAR { %{$_[0][0]} = () } +sub SCALAR { scalar %{$_[0][0]} } + +1; +package Tie::Handle; + +use 5.006_001; +our $VERSION = '4.2'; + +# Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility +# loading Tie::Handle has to make Tie::StdHandle available. +use Tie::StdHandle; + + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIEHANDLE(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIEHANDLE { + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"); + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIEHANDLE method"; + } +} + +sub PRINT { + my $self = shift; + if($self->can('WRITE') != \&WRITE) { + my $buf = join(defined $, ? $, : "",@_); + $buf .= $\ if defined $\; + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINT method"; + } +} + +sub PRINTF { + my $self = shift; + + if($self->can('WRITE') != \&WRITE) { + my $buf = sprintf(shift,@_); + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINTF method"; + } +} + +sub READLINE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READLINE method"; +} + +sub GETC { + my $self = shift; + + if($self->can('READ') != \&READ) { + my $buf; + $self->READ($buf,1); + return $buf; + } + else { + croak ref($self)," doesn't define a GETC method"; + } +} + +sub READ { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READ method"; +} + +sub WRITE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a WRITE method"; +} + +sub CLOSE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a CLOSE method"; +} + +1; +package Tie::RefHash; + +use vars qw/$VERSION/; + +$VERSION = "1.39"; + +use 5.005; + + +use Tie::Hash; +use vars '@ISA'; +@ISA = qw(Tie::Hash); +use strict; +use Carp qw/croak/; + +BEGIN { + local $@; + # determine whether we need to take care of threads + use Config (); + my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"} + *_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 }; + *_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 }; + *_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 }; +} + +BEGIN { + # create a refaddr function + + local $@; + + if ( _HAS_SCALAR_UTIL ) { + Scalar::Util->import("refaddr"); + } else { + require overload; + + *refaddr = sub { + if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) { + return $1; + } else { + die "couldn't parse StrVal: " . overload::StrVal($_[0]); + } + }; + } +} + +my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed + +sub TIEHASH { + my $c = shift; + my $s = []; + bless $s, $c; + while (@_) { + $s->STORE(shift, shift); + } + + if (_HAS_THREADS ) { + + if ( _HAS_WEAKEN ) { + # remember the object so that we can rekey it on CLONE + push @thread_object_registry, $s; + # but make this a weak reference, so that there are no leaks + Scalar::Util::weaken( $thread_object_registry[-1] ); + + if ( ++$count > 1000 ) { + # this ensures we don't fill up with a huge array dead weakrefs + @thread_object_registry = grep { defined } @thread_object_registry; + $count = 0; + } + } else { + $count++; # used in the warning + } + } + + return $s; +} + +my $storable_format_version = join("/", __PACKAGE__, "0.01"); + +sub STORABLE_freeze { + my ( $self, $is_cloning ) = @_; + my ( $refs, $reg ) = @$self; + return ( $storable_format_version, [ values %$refs ], $reg || {} ); +} + +sub STORABLE_thaw { + my ( $self, $is_cloning, $version, $refs, $reg ) = @_; + croak "incompatible versions of Tie::RefHash between freeze and thaw" + unless $version eq $storable_format_version; + + @$self = ( {}, $reg ); + $self->_reindex_keys( $refs ); +} + +sub CLONE { + my $pkg = shift; + + if ( $count and not _HAS_WEAKEN ) { + warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken"; + } + + # when the thread has been cloned all the objects need to be updated. + # dead weakrefs are undefined, so we filter them out + @thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry; + $count = 0; # we just cleaned up +} + +sub _reindex_keys { + my ( $self, $extra_keys ) = @_; + # rehash all the ref keys based on their new StrVal + %{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] }); +} + +sub FETCH { + my($s, $k) = @_; + if (ref $k) { + my $kstr = refaddr($k); + if (defined $s->[0]{$kstr}) { + $s->[0]{$kstr}[1]; + } + else { + undef; + } + } + else { + $s->[1]{$k}; + } +} + +sub STORE { + my($s, $k, $v) = @_; + if (ref $k) { + $s->[0]{refaddr($k)} = [$k, $v]; + } + else { + $s->[1]{$k} = $v; + } + $v; +} + +sub DELETE { + my($s, $k) = @_; + (ref $k) + ? (delete($s->[0]{refaddr($k)}) || [])->[1] + : delete($s->[1]{$k}); +} + +sub EXISTS { + my($s, $k) = @_; + (ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k}); +} + +sub FIRSTKEY { + my $s = shift; + keys %{$s->[0]}; # reset iterator + keys %{$s->[1]}; # reset iterator + $s->[2] = 0; # flag for iteration, see NEXTKEY + $s->NEXTKEY; +} + +sub NEXTKEY { + my $s = shift; + my ($k, $v); + if (!$s->[2]) { + if (($k, $v) = each %{$s->[0]}) { + return $v->[0]; + } + else { + $s->[2] = 1; + } + } + return each %{$s->[1]}; +} + +sub CLEAR { + my $s = shift; + $s->[2] = 0; + %{$s->[0]} = (); + %{$s->[1]} = (); +} + +package Tie::RefHash::Nestable; +use vars '@ISA'; +@ISA = 'Tie::RefHash'; + +sub STORE { + my($s, $k, $v) = @_; + if (ref($v) eq 'HASH' and not tied %$v) { + my @elems = %$v; + tie %$v, ref($s), @elems; + } + $s->SUPER::STORE($k, $v); +} + +1; +package Tie::Scalar; + +our $VERSION = '1.04'; + + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIESCALAR(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIESCALAR { + my $pkg = shift; + my $pkg_new = $pkg -> can ('new'); + + if ($pkg_new and $pkg ne __PACKAGE__) { + my $my_new = __PACKAGE__ -> can ('new'); + if ($pkg_new == $my_new) { + # + # Prevent recursion + # + croak "$pkg must define either a TIESCALAR() or a new() method"; + } + + warnings::warnif ("WARNING: calling ${pkg}->new since " . + "${pkg}->TIESCALAR is missing"); + $pkg -> new (@_); + } + else { + croak "$pkg doesn't define a TIESCALAR method"; + } +} + +sub FETCH { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a FETCH method"; +} + +sub STORE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a STORE method"; +} + +# +# The Tie::StdScalar package provides scalars that behave exactly like +# Perl's built-in scalars. Good base to inherit from, if you're only going to +# tweak a small bit. +# +package Tie::StdScalar; +@ISA = qw(Tie::Scalar); + +sub TIESCALAR { + my $class = shift; + my $instance = @_ ? shift : undef; + return bless \$instance => $class; +} + +sub FETCH { + return ${$_[0]}; +} + +sub STORE { + ${$_[0]} = $_[1]; +} + +sub DESTROY { + undef ${$_[0]}; +} + +1; +package DBM_Filter::null ; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +sub Store +{ + no warnings 'uninitialized'; + $_ .= "\x00" ; +} + +sub Fetch +{ + no warnings 'uninitialized'; + s/\x00$// ; +} + +1; + +__END__ + +package DBM_Filter::compress ; + +use strict; +use warnings; +use Carp; + +our $VERSION = '0.03'; + +BEGIN +{ + eval { require Compress::Zlib; Compress::Zlib->import() }; + + croak "Compress::Zlib module not found.\n" + if $@; +} + + + +sub Store { $_ = compress($_) } +sub Fetch { $_ = uncompress($_) } + +1; + +__END__ + +package DBM_Filter::int32 ; + +use strict; +use warnings; + +our $VERSION = '0.03'; + +# todo get Filter to figure endian. + +sub Store +{ + $_ = 0 if ! defined $_ || $_ eq "" ; + $_ = pack("i", $_); +} + +sub Fetch +{ + no warnings 'uninitialized'; + $_ = unpack("i", $_); +} + +1; + +__END__ + +package DBM_Filter::utf8 ; + +use strict; +use warnings; +use Carp; + +our $VERSION = '0.03'; + +BEGIN +{ + eval { require Encode; }; + + croak "Encode module not found.\n" + if $@; +} + +sub Store { $_ = Encode::encode_utf8($_) if defined $_ } + +sub Fetch { $_ = Encode::decode_utf8($_) if defined $_ } + +1; + +__END__ + +package DBM_Filter::encode ; + +use strict; +use warnings; +use Carp; + +our $VERSION = '0.03'; + +BEGIN +{ + eval { require Encode; }; + + croak "Encode module not found.\n" + if $@; +} + + +sub Filter +{ + my $encoding_name = shift || "utf8"; + + my $encoding = Encode::find_encoding($encoding_name) ; + + croak "Encoding '$encoding_name' is not available" + unless $encoding; + + return { + Store => sub { + $_ = $encoding->encode($_) + if defined $_ ; + }, + Fetch => sub { + $_ = $encoding->decode($_) + if defined $_ ; + } + } ; +} + +1; + +__END__ + +### the gnu tar specification: +### http://www.gnu.org/software/tar/manual/tar.html +### +### and the pax format spec, which tar derives from: +### http://www.opengroup.org/onlinepubs/007904975/utilities/pax.html + +package Archive::Tar; +require 5.005_03; + +use Cwd; +use IO::Zlib; +use IO::File; +use Carp qw(carp croak); +use File::Spec (); +use File::Spec::Unix (); +use File::Path (); + +use Archive::Tar::File; +use Archive::Tar::Constant; + +require Exporter; + +use strict; +use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD + $DO_NOT_USE_PREFIX $HAS_PERLIO $HAS_IO_STRING $SAME_PERMISSIONS + $INSECURE_EXTRACT_MODE $ZERO_PAD_NUMBERS @ISA @EXPORT $RESOLVE_SYMLINK + ]; + +@ISA = qw[Exporter]; +@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ]; +$DEBUG = 0; +$WARN = 1; +$FOLLOW_SYMLINK = 0; +$VERSION = "2.30"; +$CHOWN = 1; +$CHMOD = 1; +$SAME_PERMISSIONS = $> == 0 ? 1 : 0; +$DO_NOT_USE_PREFIX = 0; +$INSECURE_EXTRACT_MODE = 0; +$ZERO_PAD_NUMBERS = 0; +$RESOLVE_SYMLINK = $ENV{'PERL5_AT_RESOLVE_SYMLINK'} || 'speed'; + +BEGIN { + use Config; + $HAS_PERLIO = $Config::Config{useperlio}; + + ### try and load IO::String anyway, so you can dynamically + ### switch between perlio and IO::String + $HAS_IO_STRING = eval { + require IO::String; + import IO::String; + 1; + } || 0; +} + + +my $tmpl = { + _data => [ ], + _file => 'Unknown', +}; + +### install get/set accessors for this object. +for my $key ( keys %$tmpl ) { + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + return $self->{$key}; + } +} + +sub new { + my $class = shift; + $class = ref $class if ref $class; + + ### copying $tmpl here since a shallow copy makes it use the + ### same aref, causing for files to remain in memory always. + my $obj = bless { _data => [ ], _file => 'Unknown', _error => '' }, $class; + + if (@_) { + unless ( $obj->read( @_ ) ) { + $obj->_error(qq[No data could be read from file]); + return; + } + } + + return $obj; +} + + +sub read { + my $self = shift; + my $file = shift; + my $gzip = shift || 0; + my $opts = shift || {}; + + unless( defined $file ) { + $self->_error( qq[No file to read from!] ); + return; + } else { + $self->_file( $file ); + } + + my $handle = $self->_get_handle($file, $gzip, READ_ONLY->( ZLIB ) ) + or return; + + my $data = $self->_read_tar( $handle, $opts ) or return; + + $self->_data( $data ); + + return wantarray ? @$data : scalar @$data; +} + +sub _get_handle { + my $self = shift; + my $file = shift; return unless defined $file; + my $compress = shift || 0; + my $mode = shift || READ_ONLY->( ZLIB ); # default to read only + + ### Check if file is a file handle or IO glob + if ( ref $file ) { + return $file if eval{ *$file{IO} }; + return $file if eval{ $file->isa(q{IO::Handle}) }; + $file = q{}.$file; + } + + ### get a FH opened to the right class, so we can use it transparently + ### throughout the program + my $fh; + { ### reading magic only makes sense if we're opening a file for + ### reading. otherwise, just use what the user requested. + my $magic = ''; + if( MODE_READ->($mode) ) { + open my $tmp, $file or do { + $self->_error( qq[Could not open '$file' for reading: $!] ); + return; + }; + + ### read the first 4 bites of the file to figure out which class to + ### use to open the file. + sysread( $tmp, $magic, 4 ); + close $tmp; + } + + ### is it bzip? + ### if you asked specifically for bzip compression, or if we're in + ### read mode and the magic numbers add up, use bzip + if( BZIP and ( + ($compress eq COMPRESS_BZIP) or + ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM ) + ) + ) { + + ### different reader/writer modules, different error vars... sigh + if( MODE_READ->($mode) ) { + $fh = IO::Uncompress::Bunzip2->new( $file, MultiStream => 1 ) or do { + $self->_error( qq[Could not read '$file': ] . + $IO::Uncompress::Bunzip2::Bunzip2Error + ); + return; + }; + + } else { + $fh = IO::Compress::Bzip2->new( $file ) or do { + $self->_error( qq[Could not write to '$file': ] . + $IO::Compress::Bzip2::Bzip2Error + ); + return; + }; + } + + ### is it gzip? + ### if you asked for compression, if you wanted to read or the gzip + ### magic number is present (redundant with read) + } elsif( ZLIB and ( + $compress or MODE_READ->($mode) or $magic =~ GZIP_MAGIC_NUM + ) + ) { + $fh = IO::Zlib->new; + + unless( $fh->open( $file, $mode ) ) { + $self->_error(qq[Could not create filehandle for '$file': $!]); + return; + } + + ### is it plain tar? + } else { + $fh = IO::File->new; + + unless( $fh->open( $file, $mode ) ) { + $self->_error(qq[Could not create filehandle for '$file': $!]); + return; + } + + ### enable bin mode on tar archives + binmode $fh; + } + } + + return $fh; +} + + +sub _read_tar { + my $self = shift; + my $handle = shift or return; + my $opts = shift || {}; + + my $count = $opts->{limit} || 0; + my $filter = $opts->{filter}; + my $md5 = $opts->{md5} || 0; # cdrake + my $filter_cb = $opts->{filter_cb}; + my $extract = $opts->{extract} || 0; + + ### set a cap on the amount of files to extract ### + my $limit = 0; + $limit = 1 if $count > 0; + + my $tarfile = [ ]; + my $chunk; + my $read = 0; + my $real_name; # to set the name of a file when + # we're encountering @longlink + my $data; + + LOOP: + while( $handle->read( $chunk, HEAD ) ) { + ### IO::Zlib doesn't support this yet + my $offset; + if ( ref($handle) ne 'IO::Zlib' ) { + local $@; + $offset = eval { tell $handle } || 'unknown'; + $@ = ''; + } + else { + $offset = 'unknown'; + } + + unless( $read++ ) { + my $gzip = GZIP_MAGIC_NUM; + if( $chunk =~ /$gzip/ ) { + $self->_error( qq[Cannot read compressed format in tar-mode] ); + return; + } + + ### size is < HEAD, which means a corrupted file, as the minimum + ### length is _at least_ HEAD + if (length $chunk != HEAD) { + $self->_error( qq[Cannot read enough bytes from the tarfile] ); + return; + } + } + + ### if we can't read in all bytes... ### + last if length $chunk != HEAD; + + ### Apparently this should really be two blocks of 512 zeroes, + ### but GNU tar sometimes gets it wrong. See comment in the + ### source code (tar.c) to GNU cpio. + next if $chunk eq TAR_END; + + ### according to the posix spec, the last 12 bytes of the header are + ### null bytes, to pad it to a 512 byte block. That means if these + ### bytes are NOT null bytes, it's a corrupt header. See: + ### www.koders.com/c/fidCE473AD3D9F835D690259D60AD5654591D91D5BA.aspx + ### line 111 + { my $nulls = join '', "\0" x 12; + unless( $nulls eq substr( $chunk, 500, 12 ) ) { + $self->_error( qq[Invalid header block at offset $offset] ); + next LOOP; + } + } + + ### pass the realname, so we can set it 'proper' right away + ### some of the heuristics are done on the name, so important + ### to set it ASAP + my $entry; + { my %extra_args = (); + $extra_args{'name'} = $$real_name if defined $real_name; + + unless( $entry = Archive::Tar::File->new( chunk => $chunk, + %extra_args ) + ) { + $self->_error( qq[Couldn't read chunk at offset $offset] ); + next LOOP; + } + } + + ### ignore labels: + ### http://www.gnu.org/software/tar/manual/html_chapter/Media.html#SEC159 + next if $entry->is_label; + + if( length $entry->type and ($entry->is_file || $entry->is_longlink) ) { + + if ( $entry->is_file && !$entry->validate ) { + ### sometimes the chunk is rather fux0r3d and a whole 512 + ### bytes ends up in the ->name area. + ### clean it up, if need be + my $name = $entry->name; + $name = substr($name, 0, 100) if length $name > 100; + $name =~ s/\n/ /g; + + $self->_error( $name . qq[: checksum error] ); + next LOOP; + } + + my $block = BLOCK_SIZE->( $entry->size ); + + $data = $entry->get_content_by_ref; + + my $skip = 0; + my $ctx; # cdrake + ### skip this entry if we're filtering + + if($md5) { # cdrake + $ctx = Digest::MD5->new; # cdrake + $skip=5; # cdrake + + } elsif ($filter && $entry->name !~ $filter) { + $skip = 1; + + } elsif ($filter_cb && ! $filter_cb->($entry)) { + $skip = 2; + + ### skip this entry if it's a pax header. This is a special file added + ### by, among others, git-generated tarballs. It holds comments and is + ### not meant for extracting. See #38932: pax_global_header extracted + } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { + $skip = 3; + } + + if ($skip) { + # + # Since we're skipping, do not allocate memory for the + # whole file. Read it 64 BLOCKS at a time. Do not + # complete the skip yet because maybe what we read is a + # longlink and it won't get skipped after all + # + my $amt = $block; + my $fsz=$entry->size; # cdrake + while ($amt > 0) { + $$data = ''; + my $this = 64 * BLOCK; + $this = $amt if $this > $amt; + if( $handle->read( $$data, $this ) < $this ) { + $self->_error( qq[Read error on tarfile (missing data) ']. + $entry->full_path ."' at offset $offset" ); + next LOOP; + } + $amt -= $this; + $fsz -= $this; # cdrake + substr ($$data, $fsz) = "" if ($fsz<0); # remove external junk prior to md5 # cdrake + $ctx->add($$data) if($skip==5); # cdrake + } + $$data = $ctx->hexdigest if($skip==5 && !$entry->is_longlink && !$entry->is_unknown && !$entry->is_label ) ; # cdrake + } else { + + ### just read everything into memory + ### can't do lazy loading since IO::Zlib doesn't support 'seek' + ### this is because Compress::Zlib doesn't support it =/ + ### this reads in the whole data in one read() call. + if ( $handle->read( $$data, $block ) < $block ) { + $self->_error( qq[Read error on tarfile (missing data) ']. + $entry->full_path ."' at offset $offset" ); + next LOOP; + } + ### throw away trailing garbage ### + substr ($$data, $entry->size) = "" if defined $$data; + } + + ### part II of the @LongLink munging -- need to do /after/ + ### the checksum check. + if( $entry->is_longlink ) { + ### weird thing in tarfiles -- if the file is actually a + ### @LongLink, the data part seems to have a trailing ^@ + ### (unprintable) char. to display, pipe output through less. + ### but that doesn't *always* happen.. so check if the last + ### character is a control character, and if so remove it + ### at any rate, we better remove that character here, or tests + ### like 'eq' and hash lookups based on names will SO not work + ### remove it by calculating the proper size, and then + ### tossing out everything that's longer than that size. + + ### count number of nulls + my $nulls = $$data =~ tr/\0/\0/; + + ### cut data + size by that many bytes + $entry->size( $entry->size - $nulls ); + substr ($$data, $entry->size) = ""; + } + } + + ### clean up of the entries.. posix tar /apparently/ has some + ### weird 'feature' that allows for filenames > 255 characters + ### they'll put a header in with as name '././@LongLink' and the + ### contents will be the name of the /next/ file in the archive + ### pretty crappy and kludgy if you ask me + + ### set the name for the next entry if this is a @LongLink; + ### this is one ugly hack =/ but needed for direct extraction + if( $entry->is_longlink ) { + $real_name = $data; + next LOOP; + } elsif ( defined $real_name ) { + $entry->name( $$real_name ); + $entry->prefix(''); + undef $real_name; + } + + if ($filter && $entry->name !~ $filter) { + next LOOP; + + } elsif ($filter_cb && ! $filter_cb->($entry)) { + next LOOP; + + ### skip this entry if it's a pax header. This is a special file added + ### by, among others, git-generated tarballs. It holds comments and is + ### not meant for extracting. See #38932: pax_global_header extracted + } elsif ( $entry->name eq PAX_HEADER or $entry->type =~ /^(x|g)$/ ) { + next LOOP; + } + + if ( $extract && !$entry->is_longlink + && !$entry->is_unknown + && !$entry->is_label ) { + $self->_extract_file( $entry ) or return; + } + + ### Guard against tarfiles with garbage at the end + last LOOP if $entry->name eq ''; + + ### push only the name on the rv if we're extracting + ### -- for extract_archive + push @$tarfile, ($extract ? $entry->name : $entry); + + if( $limit ) { + $count-- unless $entry->is_longlink || $entry->is_dir; + last LOOP unless $count; + } + } continue { + undef $data; + } + + return $tarfile; +} + + +sub contains_file { + my $self = shift; + my $full = shift; + + return unless defined $full; + + ### don't warn if the entry isn't there.. that's what this function + ### is for after all. + local $WARN = 0; + return 1 if $self->_find_entry($full); + return; +} + + +sub extract { + my $self = shift; + my @args = @_; + my @files; + my $hashmap; + + # use the speed optimization for all extracted files + local($self->{cwd}) = cwd() unless $self->{cwd}; + + ### you requested the extraction of only certain files + if( @args ) { + for my $file ( @args ) { + + ### it's already an object? + if( UNIVERSAL::isa( $file, 'Archive::Tar::File' ) ) { + push @files, $file; + next; + + ### go find it then + } else { + + # create hash-map once to speed up lookup + $hashmap = $hashmap || { + map { $_->full_path, $_ } @{$self->_data} + }; + + if (exists $hashmap->{$file}) { + ### we found the file you're looking for + push @files, $hashmap->{$file}; + } else { + return $self->_error( + qq[Could not find '$file' in archive] ); + } + } + } + + ### just grab all the file items + } else { + @files = $self->get_files; + } + + ### nothing found? that's an error + unless( scalar @files ) { + $self->_error( qq[No files found for ] . $self->_file ); + return; + } + + ### now extract them + for my $entry ( @files ) { + unless( $self->_extract_file( $entry ) ) { + $self->_error(q[Could not extract ']. $entry->full_path .q['] ); + return; + } + } + + return @files; +} + + +sub extract_file { + my $self = shift; + my $file = shift; return unless defined $file; + my $alt = shift; + + my $entry = $self->_find_entry( $file ) + or $self->_error( qq[Could not find an entry for '$file'] ), return; + + return $self->_extract_file( $entry, $alt ); +} + +sub _extract_file { + my $self = shift; + my $entry = shift or return; + my $alt = shift; + + ### you wanted an alternate extraction location ### + my $name = defined $alt ? $alt : $entry->full_path; + + ### splitpath takes a bool at the end to indicate + ### that it's splitting a dir + my ($vol,$dirs,$file); + if ( defined $alt ) { # It's a local-OS path + ($vol,$dirs,$file) = File::Spec->splitpath( $alt, + $entry->is_dir ); + } else { + ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name, + $entry->is_dir ); + } + + my $dir; + ### is $name an absolute path? ### + if( $vol || File::Spec->file_name_is_absolute( $dirs ) ) { + + ### absolute names are not allowed to be in tarballs under + ### strict mode, so only allow it if a user tells us to do it + if( not defined $alt and not $INSECURE_EXTRACT_MODE ) { + $self->_error( + q[Entry ']. $entry->full_path .q[' is an absolute path. ]. + q[Not extracting absolute paths under SECURE EXTRACT MODE] + ); + return; + } + + ### user asked us to, it's fine. + $dir = File::Spec->catpath( $vol, $dirs, "" ); + + ### it's a relative path ### + } else { + my $cwd = (ref $self and defined $self->{cwd}) + ? $self->{cwd} + : cwd(); + + my @dirs = defined $alt + ? File::Spec->splitdir( $dirs ) # It's a local-OS path + : File::Spec::Unix->splitdir( $dirs ); # it's UNIX-style, likely + # straight from the tarball + + if( not defined $alt and + not $INSECURE_EXTRACT_MODE + ) { + + ### paths that leave the current directory are not allowed under + ### strict mode, so only allow it if a user tells us to do this. + if( grep { $_ eq '..' } @dirs ) { + + $self->_error( + q[Entry ']. $entry->full_path .q[' is attempting to leave ]. + q[the current working directory. Not extracting under ]. + q[SECURE EXTRACT MODE] + ); + return; + } + + ### the archive may be asking us to extract into a symlink. This + ### is not sane and a possible security issue, as outlined here: + ### https://rt.cpan.org/Ticket/Display.html?id=30380 + ### https://bugzilla.redhat.com/show_bug.cgi?id=295021 + ### https://issues.rpath.com/browse/RPL-1716 + my $full_path = $cwd; + for my $d ( @dirs ) { + $full_path = File::Spec->catdir( $full_path, $d ); + + ### we've already checked this one, and it's safe. Move on. + next if ref $self and $self->{_link_cache}->{$full_path}; + + if( -l $full_path ) { + my $to = readlink $full_path; + my $diag = "symlinked directory ($full_path => $to)"; + + $self->_error( + q[Entry ']. $entry->full_path .q[' is attempting to ]. + qq[extract to a $diag. This is considered a security ]. + q[vulnerability and not allowed under SECURE EXTRACT ]. + q[MODE] + ); + return; + } + + ### XXX keep a cache if possible, so the stats become cheaper: + $self->{_link_cache}->{$full_path} = 1 if ref $self; + } + } + + ### '.' is the directory delimiter on VMS, which has to be escaped + ### or changed to '_' on vms. vmsify is used, because older versions + ### of vmspath do not handle this properly. + ### Must not add a '/' to an empty directory though. + map { length() ? VMS::Filespec::vmsify($_.'/') : $_ } @dirs if ON_VMS; + + my ($cwd_vol,$cwd_dir,$cwd_file) + = File::Spec->splitpath( $cwd ); + my @cwd = File::Spec->splitdir( $cwd_dir ); + push @cwd, $cwd_file if length $cwd_file; + + ### We need to pass '' as the last element to catpath. Craig Berry + ### explains why (msgid ): + ### The root problem is that splitpath on UNIX always returns the + ### final path element as a file even if it is a directory, and of + ### course there is no way it can know the difference without checking + ### against the filesystem, which it is documented as not doing. When + ### you turn around and call catpath, on VMS you have to know which bits + ### are directory bits and which bits are file bits. In this case we + ### know the result should be a directory. I had thought you could omit + ### the file argument to catpath in such a case, but apparently on UNIX + ### you can't. + $dir = File::Spec->catpath( + $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' + ); + + ### catdir() returns undef if the path is longer than 255 chars on + ### older VMS systems. + unless ( defined $dir ) { + $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] ); + return; + } + + } + + if( -e $dir && !-d _ ) { + $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] ); + return; + } + + unless ( -d _ ) { + eval { File::Path::mkpath( $dir, 0, 0777 ) }; + if( $@ ) { + my $fp = $entry->full_path; + $self->_error(qq[Could not create directory '$dir' for '$fp': $@]); + return; + } + + ### XXX chown here? that might not be the same as in the archive + ### as we're only chown'ing to the owner of the file we're extracting + ### not to the owner of the directory itself, which may or may not + ### be another entry in the archive + ### Answer: no, gnu tar doesn't do it either, it'd be the wrong + ### way to go. + #if( $CHOWN && CAN_CHOWN ) { + # chown $entry->uid, $entry->gid, $dir or + # $self->_error( qq[Could not set uid/gid on '$dir'] ); + #} + } + + ### we're done if we just needed to create a dir ### + return 1 if $entry->is_dir; + + my $full = File::Spec->catfile( $dir, $file ); + + if( $entry->is_unknown ) { + $self->_error( qq[Unknown file type for file '$full'] ); + return; + } + + ### If a file system already contains a block device with the same name as + ### the being extracted regular file, we would write the file's content + ### to the block device. So remove the existing file (block device) now. + ### If an archive contains multiple same-named entries, the last one + ### should replace the previous ones. So remove the old file now. + ### If the old entry is a symlink to a file outside of the CWD, the new + ### entry would create a file there. This is CVE-2018-12015 + ### . + if (-l $full || -e _) { + if (!unlink $full) { + $self->_error( qq[Could not remove old file '$full': $!] ); + return; + } + } + if( length $entry->type && $entry->is_file ) { + my $fh = IO::File->new; + $fh->open( $full, '>' ) or ( + $self->_error( qq[Could not open file '$full': $!] ), + return + ); + + if( $entry->size ) { + binmode $fh; + syswrite $fh, $entry->data or ( + $self->_error( qq[Could not write data to '$full'] ), + return + ); + } + + close $fh or ( + $self->_error( qq[Could not close file '$full'] ), + return + ); + + } else { + $self->_make_special_file( $entry, $full ) or return; + } + + ### only update the timestamp if it's not a symlink; that will change the + ### timestamp of the original. This addresses bug #33669: Could not update + ### timestamp warning on symlinks + if( not -l $full ) { + utime time, $entry->mtime - TIME_OFFSET, $full or + $self->_error( qq[Could not update timestamp] ); + } + + if( $CHOWN && CAN_CHOWN->() and not -l $full ) { + chown $entry->uid, $entry->gid, $full or + $self->_error( qq[Could not set uid/gid on '$full'] ); + } + + ### only chmod if we're allowed to, but never chmod symlinks, since they'll + ### change the perms on the file they're linking too... + if( $CHMOD and not -l $full ) { + my $mode = $entry->mode; + unless ($SAME_PERMISSIONS) { + $mode &= ~(oct(7000) | umask); + } + chmod $mode, $full or + $self->_error( qq[Could not chown '$full' to ] . $entry->mode ); + } + + return 1; +} + +sub _make_special_file { + my $self = shift; + my $entry = shift or return; + my $file = shift; return unless defined $file; + + my $err; + + if( $entry->is_symlink ) { + my $fail; + if( ON_UNIX ) { + symlink( $entry->linkname, $file ) or $fail++; + + } else { + $self->_extract_special_file_as_plain_file( $entry, $file ) + or $fail++; + } + + $err = qq[Making symbolic link '$file' to '] . + $entry->linkname .q[' failed] if $fail; + + } elsif ( $entry->is_hardlink ) { + my $fail; + if( ON_UNIX ) { + link( $entry->linkname, $file ) or $fail++; + + } else { + $self->_extract_special_file_as_plain_file( $entry, $file ) + or $fail++; + } + + $err = qq[Making hard link from '] . $entry->linkname . + qq[' to '$file' failed] if $fail; + + } elsif ( $entry->is_fifo ) { + ON_UNIX && !system('mknod', $file, 'p') or + $err = qq[Making fifo ']. $entry->name .qq[' failed]; + + } elsif ( $entry->is_blockdev or $entry->is_chardev ) { + my $mode = $entry->is_blockdev ? 'b' : 'c'; + + ON_UNIX && !system('mknod', $file, $mode, + $entry->devmajor, $entry->devminor) or + $err = qq[Making block device ']. $entry->name .qq[' (maj=] . + $entry->devmajor . qq[ min=] . $entry->devminor . + qq[) failed.]; + + } elsif ( $entry->is_socket ) { + ### the original doesn't do anything special for sockets.... ### + 1; + } + + return $err ? $self->_error( $err ) : 1; +} + +### don't know how to make symlinks, let's just extract the file as +### a plain file +sub _extract_special_file_as_plain_file { + my $self = shift; + my $entry = shift or return; + my $file = shift; return unless defined $file; + + my $err; + TRY: { + my $orig = $self->_find_entry( $entry->linkname, $entry ); + + unless( $orig ) { + $err = qq[Could not find file '] . $entry->linkname . + qq[' in memory.]; + last TRY; + } + + ### clone the entry, make it appear as a normal file ### + my $clone = $orig->clone; + $clone->_downgrade_to_plainfile; + $self->_extract_file( $clone, $file ) or last TRY; + + return 1; + } + + return $self->_error($err); +} + + +sub list_files { + my $self = shift; + my $aref = shift || [ ]; + + unless( $self->_data ) { + $self->read() or return; + } + + if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) { + return map { $_->full_path } @{$self->_data}; + } else { + + #my @rv; + #for my $obj ( @{$self->_data} ) { + # push @rv, { map { $_ => $obj->$_() } @$aref }; + #} + #return @rv; + + ### this does the same as the above.. just needs a +{ } + ### to make sure perl doesn't confuse it for a block + return map { my $o=$_; + +{ map { $_ => $o->$_() } @$aref } + } @{$self->_data}; + } +} + +sub _find_entry { + my $self = shift; + my $file = shift; + + unless( defined $file ) { + $self->_error( qq[No file specified] ); + return; + } + + ### it's an object already + return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' ); + +seach_entry: + if($self->_data){ + for my $entry ( @{$self->_data} ) { + my $path = $entry->full_path; + return $entry if $path eq $file; + } + } + + if($Archive::Tar::RESOLVE_SYMLINK!~/none/){ + if(my $link_entry = shift()){#fallback mode when symlinks are using relative notations ( ../a/./b/text.bin ) + $file = _symlinks_resolver( $link_entry->name, $file ); + goto seach_entry if $self->_data; + + #this will be slower than never, but won't failed! + + my $iterargs = $link_entry->{'_archive'}; + if($Archive::Tar::RESOLVE_SYMLINK=~/speed/ && @$iterargs==3){ + #faster but whole archive will be read in memory + #read whole archive and share data + my $archive = Archive::Tar->new; + $archive->read( @$iterargs ); + push @$iterargs, $archive; #take a trace for destruction + if($archive->_data){ + $self->_data( $archive->_data ); + goto seach_entry; + } + }#faster + + {#slower but lower memory usage + # $iterargs = [$filename, $compressed, $opts]; + my $next = Archive::Tar->iter( @$iterargs ); + while(my $e = $next->()){ + if($e->full_path eq $file){ + undef $next; + return $e; + } + } + }#slower + } + } + + $self->_error( qq[No such file in archive: '$file'] ); + return; +} + + +sub get_files { + my $self = shift; + + return @{ $self->_data } unless @_; + + my @list; + for my $file ( @_ ) { + push @list, grep { defined } $self->_find_entry( $file ); + } + + return @list; +} + + +sub get_content { + my $self = shift; + my $entry = $self->_find_entry( shift ) or return; + + return $entry->data; +} + + +sub replace_content { + my $self = shift; + my $entry = $self->_find_entry( shift ) or return; + + return $entry->replace_content( shift ); +} + + +sub rename { + my $self = shift; + my $file = shift; return unless defined $file; + my $new = shift; return unless defined $new; + + my $entry = $self->_find_entry( $file ) or return; + + return $entry->rename( $new ); +} + + +sub chmod { + my $self = shift; + my $file = shift; return unless defined $file; + my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/; + my @args = ("$mode"); + + my $entry = $self->_find_entry( $file ) or return; + my $x = $entry->chmod( @args ); + return $x; +} + + +sub chown { + my $self = shift; + my $file = shift; return unless defined $file; + my $uname = shift; return unless defined $uname; + my @args = ($uname); + push(@args, shift); + + my $entry = $self->_find_entry( $file ) or return; + my $x = $entry->chown( @args ); + return $x; +} + + +sub remove { + my $self = shift; + my @list = @_; + + my %seen = map { $_->full_path => $_ } @{$self->_data}; + delete $seen{ $_ } for @list; + + $self->_data( [values %seen] ); + + return values %seen; +} + + +sub clear { + my $self = shift or return; + + $self->_data( [] ); + $self->_file( '' ); + + return 1; +} + + + +sub write { + my $self = shift; + my $file = shift; $file = '' unless defined $file; + my $gzip = shift || 0; + my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; + my $dummy = ''; + + ### only need a handle if we have a file to print to ### + my $handle = length($file) + ? ( $self->_get_handle($file, $gzip, WRITE_ONLY->($gzip) ) + or return ) + : $HAS_PERLIO ? do { open my $h, '>', \$dummy; $h } + : $HAS_IO_STRING ? IO::String->new + : __PACKAGE__->no_string_support(); + + ### Addresses: #41798: Nonempty $\ when writing a TAR file produces a + ### corrupt TAR file. Must clear out $\ to make sure no garbage is + ### printed to the archive + local $\; + + for my $entry ( @{$self->_data} ) { + ### entries to be written to the tarfile ### + my @write_me; + + ### only now will we change the object to reflect the current state + ### of the name and prefix fields -- this needs to be limited to + ### write() only! + my $clone = $entry->clone; + + + ### so, if you don't want use to use the prefix, we'll stuff + ### everything in the name field instead + if( $DO_NOT_USE_PREFIX ) { + + ### you might have an extended prefix, if so, set it in the clone + ### XXX is ::Unix right? + $clone->name( length $ext_prefix + ? File::Spec::Unix->catdir( $ext_prefix, + $clone->full_path) + : $clone->full_path ); + $clone->prefix( '' ); + + ### otherwise, we'll have to set it properly -- prefix part in the + ### prefix and name part in the name field. + } else { + + ### split them here, not before! + my ($prefix,$name) = $clone->_prefix_and_file( $clone->full_path ); + + ### you might have an extended prefix, if so, set it in the clone + ### XXX is ::Unix right? + $prefix = File::Spec::Unix->catdir( $ext_prefix, $prefix ) + if length $ext_prefix; + + $clone->prefix( $prefix ); + $clone->name( $name ); + } + + ### names are too long, and will get truncated if we don't add a + ### '@LongLink' file... + my $make_longlink = ( length($clone->name) > NAME_LENGTH or + length($clone->prefix) > PREFIX_LENGTH + ) || 0; + + ### perhaps we need to make a longlink file? + if( $make_longlink ) { + my $longlink = Archive::Tar::File->new( + data => LONGLINK_NAME, + $clone->full_path, + { type => LONGLINK } + ); + + unless( $longlink ) { + $self->_error( qq[Could not create 'LongLink' entry for ] . + qq[oversize file '] . $clone->full_path ."'" ); + return; + }; + + push @write_me, $longlink; + } + + push @write_me, $clone; + + ### write the one, optionally 2 a::t::file objects to the handle + for my $clone (@write_me) { + + ### if the file is a symlink, there are 2 options: + ### either we leave the symlink intact, but then we don't write any + ### data OR we follow the symlink, which means we actually make a + ### copy. if we do the latter, we have to change the TYPE of the + ### clone to 'FILE' + my $link_ok = $clone->is_symlink && $Archive::Tar::FOLLOW_SYMLINK; + my $data_ok = !$clone->is_symlink && $clone->has_content; + + ### downgrade to a 'normal' file if it's a symlink we're going to + ### treat as a regular file + $clone->_downgrade_to_plainfile if $link_ok; + + ### get the header for this block + my $header = $self->_format_tar_entry( $clone ); + unless( $header ) { + $self->_error(q[Could not format header for: ] . + $clone->full_path ); + return; + } + + unless( print $handle $header ) { + $self->_error(q[Could not write header for: ] . + $clone->full_path); + return; + } + + if( $link_ok or $data_ok ) { + unless( print $handle $clone->data ) { + $self->_error(q[Could not write data for: ] . + $clone->full_path); + return; + } + + ### pad the end of the clone if required ### + print $handle TAR_PAD->( $clone->size ) if $clone->size % BLOCK + } + + } ### done writing these entries + } + + ### write the end markers ### + print $handle TAR_END x 2 or + return $self->_error( qq[Could not write tar end markers] ); + + ### did you want it written to a file, or returned as a string? ### + my $rv = length($file) ? 1 + : $HAS_PERLIO ? $dummy + : do { seek $handle, 0, 0; local $/; <$handle> }; + + ### make sure to close the handle if we created it + if ( $file ne $handle ) { + unless( close $handle ) { + $self->_error( qq[Could not write tar] ); + return; + } + } + + return $rv; +} + +sub _format_tar_entry { + my $self = shift; + my $entry = shift or return; + my $ext_prefix = shift; $ext_prefix = '' unless defined $ext_prefix; + my $no_prefix = shift || 0; + + my $file = $entry->name; + my $prefix = $entry->prefix; $prefix = '' unless defined $prefix; + + ### remove the prefix from the file name + ### not sure if this is still needed --kane + ### no it's not -- Archive::Tar::File->_new_from_file will take care of + ### this for us. Even worse, this would break if we tried to add a file + ### like x/x. + #if( length $prefix ) { + # $file =~ s/^$match//; + #} + + $prefix = File::Spec::Unix->catdir($ext_prefix, $prefix) + if length $ext_prefix; + + ### not sure why this is... ### + my $l = PREFIX_LENGTH; # is ambiguous otherwise... + substr ($prefix, 0, -$l) = "" if length $prefix >= PREFIX_LENGTH; + + my $f1 = "%06o"; my $f2 = $ZERO_PAD_NUMBERS ? "%011o" : "%11o"; + + ### this might be optimizable with a 'changed' flag in the file objects ### + my $tar = pack ( + PACK, + $file, + + (map { sprintf( $f1, $entry->$_() ) } qw[mode uid gid]), + (map { sprintf( $f2, $entry->$_() ) } qw[size mtime]), + + "", # checksum field - space padded a bit down + + (map { $entry->$_() } qw[type linkname magic]), + + $entry->version || TAR_VERSION, + + (map { $entry->$_() } qw[uname gname]), + (map { sprintf( $f1, $entry->$_() ) } qw[devmajor devminor]), + + ($no_prefix ? '' : $prefix) + ); + + ### add the checksum ### + my $checksum_fmt = $ZERO_PAD_NUMBERS ? "%06o\0" : "%06o\0"; + substr($tar,148,7) = sprintf("%6o\0", unpack("%16C*",$tar)); + + return $tar; +} + + +sub add_files { + my $self = shift; + my @files = @_ or return; + + my @rv; + for my $file ( @files ) { + + ### you passed an Archive::Tar::File object + ### clone it so we don't accidentally have a reference to + ### an object from another archive + if( UNIVERSAL::isa( $file,'Archive::Tar::File' ) ) { + push @rv, $file->clone; + next; + } + + eval { + if( utf8::is_utf8( $file )) { + utf8::encode( $file ); + } + }; + + unless( -e $file || -l $file ) { + $self->_error( qq[No such file: '$file'] ); + next; + } + + my $obj = Archive::Tar::File->new( file => $file ); + unless( $obj ) { + $self->_error( qq[Unable to add file: '$file'] ); + next; + } + + push @rv, $obj; + } + + push @{$self->{_data}}, @rv; + + return @rv; +} + + +sub add_data { + my $self = shift; + my ($file, $data, $opt) = @_; + + my $obj = Archive::Tar::File->new( data => $file, $data, $opt ); + unless( $obj ) { + $self->_error( qq[Unable to add file: '$file'] ); + return; + } + + push @{$self->{_data}}, $obj; + + return $obj; +} + + +{ + $error = ''; + my $longmess; + + sub _error { + my $self = shift; + my $msg = $error = shift; + $longmess = Carp::longmess($error); + if (ref $self) { + $self->{_error} = $error; + $self->{_longmess} = $longmess; + } + + ### set Archive::Tar::WARN to 0 to disable printing + ### of errors + if( $WARN ) { + carp $DEBUG ? $longmess : $msg; + } + + return; + } + + sub error { + my $self = shift; + if (ref $self) { + return shift() ? $self->{_longmess} : $self->{_error}; + } else { + return shift() ? $longmess : $error; + } + } +} + + +sub setcwd { + my $self = shift; + my $cwd = shift; + + $self->{cwd} = $cwd; +} + + +sub create_archive { + my $class = shift; + + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + my @files = @_; + + unless( @files ) { + return $class->_error( qq[Cowardly refusing to create empty archive!] ); + } + + my $tar = $class->new; + $tar->add_files( @files ); + return $tar->write( $file, $gzip ); +} + + + +sub iter { + my $class = shift; + my $filename = shift; + return unless defined $filename; + my $compressed = shift || 0; + my $opts = shift || {}; + + ### get a handle to read from. + my $handle = $class->_get_handle( + $filename, + $compressed, + READ_ONLY->( ZLIB ) + ) or return; + + my @data; + my $CONSTRUCT_ARGS = [ $filename, $compressed, $opts ]; + return sub { + return shift(@data) if @data; # more than one file returned? + return unless $handle; # handle exhausted? + + ### read data, should only return file + my $tarfile = $class->_read_tar($handle, { %$opts, limit => 1 }); + @data = @$tarfile if ref $tarfile && ref $tarfile eq 'ARRAY'; + if($Archive::Tar::RESOLVE_SYMLINK!~/none/){ + foreach(@data){ + #may refine this heuristic for ON_UNIX? + if($_->linkname){ + #is there a better slot to store/share it ? + $_->{'_archive'} = $CONSTRUCT_ARGS; + } + } + } + + ### return one piece of data + return shift(@data) if @data; + + ### data is exhausted, free the filehandle + undef $handle; + if(@$CONSTRUCT_ARGS == 4){ + #free archive in memory + undef $CONSTRUCT_ARGS->[-1]; + } + return; + }; +} + + +sub list_archive { + my $class = shift; + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + + my $tar = $class->new($file, $gzip); + return unless $tar; + + return $tar->list_files( @_ ); +} + + +sub extract_archive { + my $class = shift; + my $file = shift; return unless defined $file; + my $gzip = shift || 0; + + my $tar = $class->new( ) or return; + + return $tar->read( $file, $gzip, { extract => 1 } ); +} + + +sub has_io_string { return $HAS_IO_STRING; } + + +sub has_perlio { return $HAS_PERLIO; } + + +sub has_zlib_support { return ZLIB } + + +sub has_bzip2_support { return BZIP } + + +sub can_handle_compressed_files { return ZLIB && BZIP ? 1 : 0 } + +sub no_string_support { + croak("You have to install IO::String to support writing archives to strings"); +} + +sub _symlinks_resolver{ + my ($src, $trg) = @_; + my @src = split /[\/\\]/, $src; + my @trg = split /[\/\\]/, $trg; + pop @src; #strip out current object name + if(@trg and $trg[0] eq ''){ + shift @trg; + #restart path from scratch + @src = ( ); + } + foreach my $part ( @trg ){ + next if $part eq '.'; #ignore current + if($part eq '..'){ + #got to parent + pop @src; + } + else{ + #append it + push @src, $part; + } + } + my $path = join('/', @src); + warn "_symlinks_resolver('$src','$trg') = $path" if $DEBUG; + return $path; +} + +1; + +__END__ + + +package Archive::Tar::Constant; + +BEGIN { + require Exporter; + + $VERSION = '2.30'; + @ISA = qw[Exporter]; + + require Time::Local if $^O eq "MacOS"; +} + +@EXPORT = Archive::Tar::Constant->_list_consts( __PACKAGE__ ); + +use strict; +use warnings; + +use constant FILE => 0; +use constant HARDLINK => 1; +use constant SYMLINK => 2; +use constant CHARDEV => 3; +use constant BLOCKDEV => 4; +use constant DIR => 5; +use constant FIFO => 6; +use constant SOCKET => 8; +use constant UNKNOWN => 9; +use constant LONGLINK => 'L'; +use constant LABEL => 'V'; + +use constant BUFFER => 4096; +use constant HEAD => 512; +use constant BLOCK => 512; + +use constant COMPRESS_GZIP => 9; +use constant COMPRESS_BZIP => 'bzip2'; + +use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK }; +use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) }; +use constant TAR_END => "\0" x BLOCK; + +use constant READ_ONLY => sub { shift() ? 'rb' : 'r' }; +use constant WRITE_ONLY => sub { $_[0] ? 'wb' . shift : 'w' }; +use constant MODE_READ => sub { $_[0] =~ /^r/ ? 1 : 0 }; + +# Pointless assignment to make -w shut up +my $getpwuid; $getpwuid = 'unknown' unless eval { my $f = getpwuid (0); }; +my $getgrgid; $getgrgid = 'unknown' unless eval { my $f = getgrgid (0); }; +use constant UNAME => sub { $getpwuid || scalar getpwuid( shift() ) || '' }; +use constant GNAME => sub { $getgrgid || scalar getgrgid( shift() ) || '' }; +use constant UID => $>; +use constant GID => (split ' ', $) )[0]; + +use constant MODE => do { 0666 & (0777 & ~umask) }; +use constant STRIP_MODE => sub { shift() & 0777 }; +use constant CHECK_SUM => " "; + +use constant UNPACK => 'a100 a8 a8 a8 a12 a12 a8 a1 a100 A6 a2 a32 a32 a8 a8 a155 x12'; # cdrake - size must be a12 - not A12 - or else screws up huge file sizes (>8gb) +use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a8 a8 a155 x12'; +use constant NAME_LENGTH => 100; +use constant PREFIX_LENGTH => 155; + +use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0; +use constant MAGIC => "ustar"; +use constant TAR_VERSION => "00"; +use constant LONGLINK_NAME => '././@LongLink'; +use constant PAX_HEADER => 'pax_global_header'; + + ### allow ZLIB to be turned off using ENV: DEBUG only +use constant ZLIB => do { !$ENV{'PERL5_AT_NO_ZLIB'} and + eval { require IO::Zlib }; + $ENV{'PERL5_AT_NO_ZLIB'} || $@ ? 0 : 1 + }; + + ### allow BZIP to be turned off using ENV: DEBUG only +use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and + eval { require IO::Uncompress::Bunzip2; + require IO::Compress::Bzip2; }; + $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 + }; + +use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; +use constant BZIP_MAGIC_NUM => qr/^BZh\d/; + +use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") }; +use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS'); +use constant ON_UNIX => ($^O ne 'MSWin32' and $^O ne 'MacOS' and $^O ne 'VMS'); +use constant ON_VMS => $^O eq 'VMS'; + +sub _list_consts { + my $class = shift; + my $pkg = shift; + return unless defined $pkg; # some joker might use '0' as a pkg... + + my @rv; + { no strict 'refs'; + my $stash = $pkg . '::'; + + for my $name (sort keys %$stash ) { + + ### is it a subentry? + my $sub = $pkg->can( $name ); + next unless defined $sub; + + next unless defined prototype($sub) and + not length prototype($sub); + + push @rv, $name; + } + } + + return sort @rv; +} + +1; +package Archive::Tar::File; +use strict; + +use Carp (); +use IO::File; +use File::Spec::Unix (); +use File::Spec (); +use File::Basename (); + +### avoid circular use, so only require; +require Archive::Tar; +use Archive::Tar::Constant; + +use vars qw[@ISA $VERSION]; +#@ISA = qw[Archive::Tar]; +$VERSION = '2.30'; + +### set value to 1 to oct() it during the unpack ### + +my $tmpl = [ + name => 0, # string A100 + mode => 1, # octal A8 + uid => 1, # octal A8 + gid => 1, # octal A8 + size => 0, # octal # cdrake - not *always* octal.. A12 + mtime => 1, # octal A12 + chksum => 1, # octal A8 + type => 0, # character A1 + linkname => 0, # string A100 + magic => 0, # string A6 + version => 0, # 2 bytes A2 + uname => 0, # string A32 + gname => 0, # string A32 + devmajor => 1, # octal A8 + devminor => 1, # octal A8 + prefix => 0, # A155 x 12 + +### end UNPACK items ### + raw => 0, # the raw data chunk + data => 0, # the data associated with the file -- + # This might be very memory intensive +]; + +### install get/set accessors for this object. +for ( my $i=0; $i[$i]; + no strict 'refs'; + *{__PACKAGE__."::$key"} = sub { + my $self = shift; + $self->{$key} = $_[0] if @_; + + ### just in case the key is not there or undef or something ### + { local $^W = 0; + return $self->{$key}; + } + } +} + + +sub new { + my $class = shift; + my $what = shift; + + my $obj = ($what eq 'chunk') ? __PACKAGE__->_new_from_chunk( @_ ) : + ($what eq 'file' ) ? __PACKAGE__->_new_from_file( @_ ) : + ($what eq 'data' ) ? __PACKAGE__->_new_from_data( @_ ) : + undef; + + return $obj; +} + +### copies the data, creates a clone ### +sub clone { + my $self = shift; + return bless { %$self }, ref $self; +} + +sub _new_from_chunk { + my $class = shift; + my $chunk = shift or return; # 512 bytes of tar header + my %hash = @_; + + ### filter any arguments on defined-ness of values. + ### this allows overriding from what the tar-header is saying + ### about this tar-entry. Particularly useful for @LongLink files + my %args = map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash; + + ### makes it start at 0 actually... :) ### + my $i = -1; + my %entry = map { + my ($s,$v)=($tmpl->[++$i],$tmpl->[++$i]); # cdrake + ($_)=($_=~/^([^\0]*)/) unless($s eq 'size'); # cdrake + $s=> $v ? oct $_ : $_ # cdrake + # $tmpl->[++$i] => $tmpl->[++$i] ? oct $_ : $_ # removed by cdrake - mucks up binary sizes >8gb + } unpack( UNPACK, $chunk ); # cdrake + # } map { /^([^\0]*)/ } unpack( UNPACK, $chunk ); # old - replaced now by cdrake + + + if(substr($entry{'size'}, 0, 1) eq "\x80") { # binary size extension for files >8gigs (> octal 77777777777777) # cdrake + my @sz=unpack("aCSNN",$entry{'size'}); $entry{'size'}=$sz[4]+(2**32)*$sz[3]+$sz[2]*(2**64); # Use the low 80 bits (should use the upper 15 as well, but as at year 2011, that seems unlikely to ever be needed - the numbers are just too big...) # cdrake + } else { # cdrake + ($entry{'size'})=($entry{'size'}=~/^([^\0]*)/); $entry{'size'}=oct $entry{'size'}; # cdrake + } # cdrake + + + my $obj = bless { %entry, %args }, $class; + + ### magic is a filetype string.. it should have something like 'ustar' or + ### something similar... if the chunk is garbage, skip it + return unless $obj->magic !~ /\W/; + + ### store the original chunk ### + $obj->raw( $chunk ); + + $obj->type(FILE) if ( (!length $obj->type) or ($obj->type =~ /\W/) ); + $obj->type(DIR) if ( ($obj->is_file) && ($obj->name =~ m|/$|) ); + + + return $obj; + +} + +sub _new_from_file { + my $class = shift; + my $path = shift; + + ### path has to at least exist + return unless defined $path; + + my $type = __PACKAGE__->_filetype($path); + my $data = ''; + + READ: { + unless ($type == DIR ) { + my $fh = IO::File->new; + + unless( $fh->open($path) ) { + ### dangling symlinks are fine, stop reading but continue + ### creating the object + last READ if $type == SYMLINK; + + ### otherwise, return from this function -- + ### anything that's *not* a symlink should be + ### resolvable + return; + } + + ### binmode needed to read files properly on win32 ### + binmode $fh; + $data = do { local $/; <$fh> }; + close $fh; + } + } + + my @items = qw[mode uid gid size mtime]; + my %hash = map { shift(@items), $_ } (lstat $path)[2,4,5,7,9]; + + if (ON_VMS) { + ### VMS has two UID modes, traditional and POSIX. Normally POSIX is + ### not used. We currently do not have an easy way to see if we are in + ### POSIX mode. In traditional mode, the UID is actually the VMS UIC. + ### The VMS UIC has the upper 16 bits is the GID, which in many cases + ### the VMS UIC will be larger than 209715, the largest that TAR can + ### handle. So for now, assume it is traditional if the UID is larger + ### than 0x10000. + + if ($hash{uid} > 0x10000) { + $hash{uid} = $hash{uid} & 0xFFFF; + } + + ### The file length from stat() is the physical length of the file + ### However the amount of data read in may be more for some file types. + ### Fixed length files are read past the logical EOF to end of the block + ### containing. Other file types get expanded on read because record + ### delimiters are added. + + my $data_len = length $data; + $hash{size} = $data_len if $hash{size} < $data_len; + + } + ### you *must* set size == 0 on symlinks, or the next entry will be + ### though of as the contents of the symlink, which is wrong. + ### this fixes bug #7937 + $hash{size} = 0 if ($type == DIR or $type == SYMLINK); + $hash{mtime} -= TIME_OFFSET; + + ### strip the high bits off the mode, which we don't need to store + $hash{mode} = STRIP_MODE->( $hash{mode} ); + + + ### probably requires some file path munging here ... ### + ### name and prefix are set later + my $obj = { + %hash, + name => '', + chksum => CHECK_SUM, + type => $type, + linkname => ($type == SYMLINK and CAN_READLINK) + ? readlink $path + : '', + magic => MAGIC, + version => TAR_VERSION, + uname => UNAME->( $hash{uid} ), + gname => GNAME->( $hash{gid} ), + devmajor => 0, # not handled + devminor => 0, # not handled + prefix => '', + data => $data, + }; + + bless $obj, $class; + + ### fix up the prefix and file from the path + my($prefix,$file) = $obj->_prefix_and_file( $path ); + $obj->prefix( $prefix ); + $obj->name( $file ); + + return $obj; +} + +sub _new_from_data { + my $class = shift; + my $path = shift; return unless defined $path; + my $data = shift; return unless defined $data; + my $opt = shift; + + my $obj = { + data => $data, + name => '', + mode => MODE, + uid => UID, + gid => GID, + size => length $data, + mtime => time - TIME_OFFSET, + chksum => CHECK_SUM, + type => FILE, + linkname => '', + magic => MAGIC, + version => TAR_VERSION, + uname => UNAME->( UID ), + gname => GNAME->( GID ), + devminor => 0, + devmajor => 0, + prefix => '', + }; + + ### overwrite with user options, if provided ### + if( $opt and ref $opt eq 'HASH' ) { + for my $key ( keys %$opt ) { + + ### don't write bogus options ### + next unless exists $obj->{$key}; + $obj->{$key} = $opt->{$key}; + } + } + + bless $obj, $class; + + ### fix up the prefix and file from the path + my($prefix,$file) = $obj->_prefix_and_file( $path ); + $obj->prefix( $prefix ); + $obj->name( $file ); + + return $obj; +} + +sub _prefix_and_file { + my $self = shift; + my $path = shift; + + my ($vol, $dirs, $file) = File::Spec->splitpath( $path, $self->is_dir ); + my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) ); + + ### if it's a directory, then $file might be empty + $file = pop @dirs if $self->is_dir and not length $file; + + ### splitting ../ gives you the relative path in native syntax + map { $_ = '..' if $_ eq '-' } @dirs if ON_VMS; + + my $prefix = File::Spec::Unix->catdir(@dirs); + return( $prefix, $file ); +} + +sub _filetype { + my $self = shift; + my $file = shift; + + return unless defined $file; + + return SYMLINK if (-l $file); # Symlink + + return FILE if (-f _); # Plain file + + return DIR if (-d _); # Directory + + return FIFO if (-p _); # Named pipe + + return SOCKET if (-S _); # Socket + + return BLOCKDEV if (-b _); # Block special + + return CHARDEV if (-c _); # Character special + + ### shouldn't happen, this is when making archives, not reading ### + return LONGLINK if ( $file eq LONGLINK_NAME ); + + return UNKNOWN; # Something else (like what?) + +} + +### this method 'downgrades' a file to plain file -- this is used for +### symlinks when FOLLOW_SYMLINKS is true. +sub _downgrade_to_plainfile { + my $entry = shift; + $entry->type( FILE ); + $entry->mode( MODE ); + $entry->linkname(''); + + return 1; +} + + +sub extract { + my $self = shift; + + local $Carp::CarpLevel += 1; + + return Archive::Tar->_extract_file( $self, @_ ); +} + + +sub full_path { + my $self = shift; + + ### if prefix field is empty + return $self->name unless defined $self->prefix and length $self->prefix; + + ### or otherwise, catfile'd + return File::Spec::Unix->catfile( $self->prefix, $self->name ); +} + + + +sub validate { + my $self = shift; + + my $raw = $self->raw; + + ### don't know why this one is different from the one we /write/ ### + substr ($raw, 148, 8) = " "; + + ### bug #43513: [PATCH] Accept wrong checksums from SunOS and HP-UX tar + ### like GNU tar does. See here for details: + ### http://www.gnu.org/software/tar/manual/tar.html#SEC139 + ### so we do both a signed AND unsigned validate. if one succeeds, that's + ### good enough + return ( (unpack ("%16C*", $raw) == $self->chksum) + or (unpack ("%16c*", $raw) == $self->chksum)) ? 1 : 0; +} + + +sub has_content { + my $self = shift; + return defined $self->data() && length $self->data() ? 1 : 0; +} + + +sub get_content { + my $self = shift; + $self->data( ); +} + + +sub get_content_by_ref { + my $self = shift; + + return \$self->{data}; +} + + +sub replace_content { + my $self = shift; + my $data = shift || ''; + + $self->data( $data ); + $self->size( length $data ); + return 1; +} + + +sub rename { + my $self = shift; + my $path = shift; + + return unless defined $path; + + my ($prefix,$file) = $self->_prefix_and_file( $path ); + + $self->name( $file ); + $self->prefix( $prefix ); + + return 1; +} + + +sub chmod { + my $self = shift; + my $mode = shift; return unless defined $mode && $mode =~ /^[0-7]{1,4}$/; + $self->{mode} = oct($mode); + return 1; +} + + +sub chown { + my $self = shift; + my $uname = shift; + return unless defined $uname; + my $gname; + if (-1 != index($uname, ':')) { + ($uname, $gname) = split(/:/, $uname); + } else { + $gname = shift if @_ > 0; + } + + $self->uname( $uname ); + $self->gname( $gname ) if $gname; + return 1; +} + + +#stupid perl5.5.3 needs to warn if it's not numeric +sub is_file { local $^W; FILE == $_[0]->type } +sub is_dir { local $^W; DIR == $_[0]->type } +sub is_hardlink { local $^W; HARDLINK == $_[0]->type } +sub is_symlink { local $^W; SYMLINK == $_[0]->type } +sub is_chardev { local $^W; CHARDEV == $_[0]->type } +sub is_blockdev { local $^W; BLOCKDEV == $_[0]->type } +sub is_fifo { local $^W; FIFO == $_[0]->type } +sub is_socket { local $^W; SOCKET == $_[0]->type } +sub is_unknown { local $^W; UNKNOWN == $_[0]->type } +sub is_longlink { local $^W; LONGLINK eq $_[0]->type } +sub is_label { local $^W; LABEL eq $_[0]->type } + +1; +package Config::Extensions; +use strict; +our (%Extensions, $VERSION, @ISA, @EXPORT_OK); +use Config; +require Exporter; + +$VERSION = '0.02'; +@ISA = 'Exporter'; +@EXPORT_OK = '%Extensions'; + +foreach my $type (qw(static dynamic nonxs)) { + foreach (split /\s+/, $Config{$type . '_ext'}) { + s!/!::!g; + $Extensions{$_} = $type; + } +} + +1; +__END__ +#!/pro/bin/perl + +package Config::Perl::V; + +use strict; +use warnings; + +use Config; +use Exporter; +use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); +$VERSION = "0.29"; +@ISA = qw( Exporter ); +@EXPORT_OK = qw( plv2hash summary myconfig signature ); +%EXPORT_TAGS = ( + all => [ @EXPORT_OK ], + sig => [ "signature" ], + ); + +# Characteristics of this binary (from libperl): +# Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP +# USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO + +# The list are as the perl binary has stored it in PL_bincompat_options +# search for it in +# perl.c line 1643 S_Internals_V () +# perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c +# perl.h line 4566 PL_bincompat_options +# perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h +my %BTD = map { $_ => 0 } qw( + + DEBUGGING + NO_HASH_SEED + NO_MATHOMS + NO_TAINT_SUPPORT + PERL_BOOL_AS_CHAR + PERL_COPY_ON_WRITE + PERL_DISABLE_PMC + PERL_DONT_CREATE_GVSV + PERL_EXTERNAL_GLOB + PERL_HASH_FUNC_DJB2 + PERL_HASH_FUNC_MURMUR3 + PERL_HASH_FUNC_ONE_AT_A_TIME + PERL_HASH_FUNC_ONE_AT_A_TIME_HARD + PERL_HASH_FUNC_ONE_AT_A_TIME_OLD + PERL_HASH_FUNC_SDBM + PERL_HASH_FUNC_SIPHASH + PERL_HASH_FUNC_SUPERFAST + PERL_IS_MINIPERL + PERL_MALLOC_WRAP + PERL_MEM_LOG + PERL_MEM_LOG_ENV + PERL_MEM_LOG_ENV_FD + PERL_MEM_LOG_NOIMPL + PERL_MEM_LOG_STDERR + PERL_MEM_LOG_TIMESTAMP + PERL_NEW_COPY_ON_WRITE + PERL_OP_PARENT + PERL_PERTURB_KEYS_DETERMINISTIC + PERL_PERTURB_KEYS_DISABLED + PERL_PERTURB_KEYS_RANDOM + PERL_PRESERVE_IVUV + PERL_RELOCATABLE_INCPUSH + PERL_USE_DEVEL + PERL_USE_SAFE_PUTENV + SILENT_NO_TAINT_SUPPORT + UNLINK_ALL_VERSIONS + USE_ATTRIBUTES_FOR_PERLIO + USE_FAST_STDIO + USE_HASH_SEED_EXPLICIT + USE_LOCALE + USE_LOCALE_CTYPE + USE_NO_REGISTRY + USE_PERL_ATOF + USE_SITECUSTOMIZE + + DEBUG_LEAKING_SCALARS + DEBUG_LEAKING_SCALARS_FORK_DUMP + DECCRTL_SOCKETS + FAKE_THREADS + FCRYPT + HAS_TIMES + HAVE_INTERP_INTERN + MULTIPLICITY + MYMALLOC + PERL_DEBUG_READONLY_COW + PERL_DEBUG_READONLY_OPS + PERL_GLOBAL_STRUCT + PERL_GLOBAL_STRUCT_PRIVATE + PERL_IMPLICIT_CONTEXT + PERL_IMPLICIT_SYS + PERLIO_LAYERS + PERL_MAD + PERL_MICRO + PERL_NEED_APPCTX + PERL_NEED_TIMESBASE + PERL_OLD_COPY_ON_WRITE + PERL_POISON + PERL_SAWAMPERSAND + PERL_TRACK_MEMPOOL + PERL_USES_PL_PIDSTATUS + PL_OP_SLAB_ALLOC + THREADS_HAVE_PIDS + USE_64_BIT_ALL + USE_64_BIT_INT + USE_IEEE + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE_COLLATE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_QUADMATH + USE_REENTRANT_API + USE_SFIO + USE_SOCKS + VMS_DO_SOCKETS + VMS_SHORTEN_LONG_SYMBOLS + VMS_SYMBOL_CASE_AS_IS + ); + +# These are all the keys that are +# 1. Always present in %Config - lib/Config.pm #87 tie %Config +# 2. Reported by 'perl -V' (the rest) +my @config_vars = qw( + + api_subversion + api_version + api_versionstring + archlibexp + dont_use_nlink + d_readlink + d_symlink + exe_ext + inc_version_list + ldlibpthname + patchlevel + path_sep + perl_patchlevel + privlibexp + scriptdir + sitearchexp + sitelibexp + subversion + usevendorprefix + version + + git_commit_id + git_describe + git_branch + git_uncommitted_changes + git_commit_id_title + git_snapshot_date + + package revision version_patchlevel_string + + osname osvers archname + myuname + config_args + hint useposix d_sigaction + useithreads usemultiplicity + useperlio d_sfio uselargefiles usesocks + use64bitint use64bitall uselongdouble + usemymalloc default_inc_excludes_dot bincompat5005 + + cc ccflags + optimize + cppflags + ccversion gccversion gccosandvers + intsize longsize ptrsize doublesize byteorder + d_longlong longlongsize d_longdbl longdblsize + ivtype ivsize nvtype nvsize lseektype lseeksize + alignbytes prototype + + ld ldflags + libpth + libs + perllibs + libc so useshrplib libperl + gnulibc_version + + dlsrc dlext d_dlsymun ccdlflags + cccdlflags lddlflags + ); + +my %empty_build = ( + osname => "", + stamp => 0, + options => { %BTD }, + patches => [], + ); + +sub _make_derived { + my $conf = shift; + + for ( [ lseektype => "Off_t" ], + [ myuname => "uname" ], + [ perl_patchlevel => "patch" ], + ) { + my ($official, $derived) = @$_; + $conf->{config}{$derived} ||= $conf->{config}{$official}; + $conf->{config}{$official} ||= $conf->{config}{$derived}; + $conf->{derived}{$derived} = delete $conf->{config}{$derived}; + } + + if (exists $conf->{config}{version_patchlevel_string} && + !exists $conf->{config}{api_version}) { + my $vps = $conf->{config}{version_patchlevel_string}; + $vps =~ s{\b revision \s+ (\S+) }{}x and + $conf->{config}{revision} ||= $1; + + $vps =~ s{\b version \s+ (\S+) }{}x and + $conf->{config}{api_version} ||= $1; + $vps =~ s{\b subversion \s+ (\S+) }{}x and + $conf->{config}{subversion} ||= $1; + $vps =~ s{\b patch \s+ (\S+) }{}x and + $conf->{config}{perl_patchlevel} ||= $1; + } + + ($conf->{config}{version_patchlevel_string} ||= join " ", + map { ($_, $conf->{config}{$_} ) } + grep { $conf->{config}{$_} } + qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//; + + $conf->{config}{perl_patchlevel} ||= ""; # 0 is not a valid patchlevel + + if ($conf->{config}{perl_patchlevel} =~ m{^git\w*-([^-]+)}i) { + $conf->{config}{git_branch} ||= $1; + $conf->{config}{git_describe} ||= $conf->{config}{perl_patchlevel}; + } + + $conf->{config}{$_} ||= "undef" for grep m/^(?:use|def)/ => @config_vars; + + $conf; + } # _make_derived + +sub plv2hash { + my %config; + + my $pv = join "\n" => @_; + + if ($pv =~ m/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)/m) { + $config{"package"} = $1; + my $rev = $2; + $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1; + $rev and $config{version_patchlevel_string} = $rev; + my ($rel) = $config{"package"} =~ m{perl(\d)}; + my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)}; + defined $vers && defined $subvers && defined $rel and + $config{version} = "$rel.$vers.$subvers"; + } + + if ($pv =~ m/^\s+(Snapshot of:)\s+(\S+)/) { + $config{git_commit_id_title} = $1; + $config{git_commit_id} = $2; + } + + # these are always last on line and can have multiple quotation styles + for my $k (qw( ccflags ldflags lddlflags )) { + $pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next; + my $v = $1; + $v =~ s/\s*,\s*$//; + $v =~ s/^(['"])(.*)\1$/$2/; + $config{$k} = $v; + } + + if (my %kv = ($pv =~ m{\b + (\w+) # key + \s*= # assign + ( '\s*[^']*?\s*' # quoted value + | \S+[^=]*?\s*\n # unquoted running till end of line + | \S+ # unquoted value + | \s*\n # empty + ) + (?:,?\s+|\s*\n)? # separator (5.8.x reports did not have a ',' + }gx)) { # between every kv pair + + while (my ($k, $v) = each %kv) { + $k =~ s/\s+$//; + $v =~ s/\s*\n\z//; + $v =~ s/,$//; + $v =~ m/^'(.*)'$/ and $v = $1; + $v =~ s/\s+$//; + $config{$k} = $v; + } + } + + my $build = { %empty_build }; + + $pv =~ m{^\s+Compiled at\s+(.*)}m + and $build->{stamp} = $1; + $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms + and $build->{patches} = [ split m/\n+\s*/, $1 ]; + $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms + and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1; + + $build->{osname} = $config{osname}; + $pv =~ m{^\s+Built under\s+(.*)}m + and $build->{osname} = $1; + $config{osname} ||= $build->{osname}; + + return _make_derived ({ + build => $build, + environment => {}, + config => \%config, + derived => {}, + inc => [], + }); + } # plv2hash + +sub summary { + my $conf = shift || myconfig (); + ref $conf eq "HASH" + && exists $conf->{config} + && exists $conf->{build} + && ref $conf->{config} eq "HASH" + && ref $conf->{build} eq "HASH" or return; + + my %info = map { + exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () } + qw( archname osname osvers revision patchlevel subversion version + cc ccversion gccversion config_args inc_version_list + d_longdbl d_longlong use64bitall use64bitint useithreads + uselongdouble usemultiplicity usemymalloc useperlio useshrplib + doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize + default_inc_excludes_dot + ); + $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}}; + + return \%info; + } # summary + +sub signature { + my $no_md5 = "0" x 32; + my $conf = summary (shift) or return $no_md5; + + eval { require Digest::MD5 }; + $@ and return $no_md5; + + $conf->{cc} =~ s{.*\bccache\s+}{}; + $conf->{cc} =~ s{.*[/\\]}{}; + + delete $conf->{config_args}; + return Digest::MD5::md5_hex (join "\xFF" => map { + "$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE"); + } sort keys %$conf); + } # signature + +sub myconfig { + my $args = shift; + my %args = ref $args eq "HASH" ? %$args : + ref $args eq "ARRAY" ? @$args : (); + + my $build = { %empty_build }; + + # 5.14.0 and later provide all the information without shelling out + my $stamp = eval { Config::compile_date () }; + if (defined $stamp) { + $stamp =~ s/^Compiled at //; + $build->{osname} = $^O; + $build->{stamp} = $stamp; + $build->{patches} = [ Config::local_patches () ]; + $build->{options}{$_} = 1 for Config::bincompat_options (), + Config::non_bincompat_options (); + } + else { + #y $pv = qx[$^X -e"sub Config::myconfig{};" -V]; + my $cnf = plv2hash (qx[$^X -V]); + + $build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options ); + } + + my @KEYS = keys %ENV; + my %env = + map { $_ => $ENV{$_} } grep m/^PERL/ => @KEYS; + $args{env} and + map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS; + + my %config = map { $_ => $Config{$_} } @config_vars; + + return _make_derived ({ + build => $build, + environment => \%env, + config => \%config, + derived => {}, + inc => \@INC, + }); + } # myconfig + +1; + +__END__ + +package ExtUtils::MM_UWIN; + +use strict; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + + +sub os_flavor { + return('Unix', 'U/WIN'); +} + + + +sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,.,g; + return $man; +} + + +1; +package ExtUtils::Manifest; + +require Exporter; +use Config; +use File::Basename; +use File::Copy 'copy'; +use File::Find; +use File::Spec 0.8; +use Carp; +use strict; +use warnings; + +our $VERSION = '1.70'; +our @ISA = ('Exporter'); +our @EXPORT_OK = qw(mkmanifest + manicheck filecheck fullcheck skipcheck + manifind maniread manicopy maniadd + maniskip + ); + +our $Is_MacOS = $^O eq 'MacOS'; +our $Is_VMS = $^O eq 'VMS'; +our $Is_VMS_mode = 0; +our $Is_VMS_lc = 0; +our $Is_VMS_nodot = 0; # No dots in dir names or double dots in files + +if ($Is_VMS) { + require VMS::Filespec if $Is_VMS; + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + $Is_VMS_mode = 1; + $Is_VMS_lc = 1; + $Is_VMS_nodot = 1; + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_lc = 0 if ($vms_case); + $Is_VMS_mode = 0 if ($vms_unix_rpt); + $Is_VMS_nodot = 0 if ($vms_efs); +} + +our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; +our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? + $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; +our $Quiet = 0; +our $MANIFEST = 'MANIFEST'; + +our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); + + + +sub _sort { + return sort { lc $a cmp lc $b } @_; +} + +sub mkmanifest { + my $manimiss = 0; + my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; + $read = {} if $manimiss; + local *M; + my $bakbase = $MANIFEST; + $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots + rename $MANIFEST, "$bakbase.bak" unless $manimiss; + open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!"; + binmode M, ':raw'; + my $skip = maniskip(); + my $found = manifind(); + my($key,$val,$file,%all); + %all = (%$found, %$read); + $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') . + 'This list of files' + if $manimiss; # add new MANIFEST to known file list + foreach $file (_sort keys %all) { + if ($skip->($file)) { + # Policy: only remove files if they're listed in MANIFEST.SKIP. + # Don't remove files just because they don't exist. + warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file}; + next; + } + if ($Verbose){ + warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; + } + my $text = $all{$file}; + $file = _unmacify($file); + my $tabs = (5 - (length($file)+1)/8); + $tabs = 1 if $tabs < 1; + $tabs = 0 unless $text; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + print M $file, "\t" x $tabs, $text, "\n"; + } + close M; +} + +# Geez, shouldn't this use File::Spec or File::Basename or something? +# Why so careful about dependencies? +sub clean_up_filename { + my $filename = shift; + $filename =~ s|^\./||; + $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS; + if ( $Is_VMS ) { + $filename =~ s/\.$//; # trim trailing dot + $filename = VMS::Filespec::unixify($filename); # unescape spaces, etc. + if( $Is_VMS_lc ) { + $filename = lc($filename); + $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i; + } + } + return $filename; +} + + + +sub manifind { + my $p = shift || {}; + my $found = {}; + + my $wanted = sub { + my $name = clean_up_filename($File::Find::name); + warn "Debug: diskfile $name\n" if $Debug; + return if -d $_; + $found->{$name} = ""; + }; + + # We have to use "$File::Find::dir/$_" in preprocess, because + # $File::Find::name is unavailable. + # Also, it's okay to use / here, because MANIFEST files use Unix-style + # paths. + find({wanted => $wanted, follow_fast => 1}, + $Is_MacOS ? ":" : "."); + + return $found; +} + + + +sub manicheck { + return _check_files(); +} + + + +sub filecheck { + return _check_manifest(); +} + + + +sub fullcheck { + return [_check_files()], [_check_manifest()]; +} + + + +sub skipcheck { + my($p) = @_; + my $found = manifind(); + my $matches = maniskip(); + + my @skipped = (); + foreach my $file (_sort keys %$found){ + if (&$matches($file)){ + warn "Skipping $file\n" unless $Quiet; + push @skipped, $file; + next; + } + } + + return @skipped; +} + + +sub _check_files { + my $p = shift; + my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); + my $read = maniread() || {}; + my $found = manifind($p); + + my(@missfile) = (); + foreach my $file (_sort keys %$read){ + warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; + if ($dosnames){ + $file = lc $file; + $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; + $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; + } + unless ( exists $found->{$file} ) { + warn "No such file: $file\n" unless $Quiet; + push @missfile, $file; + } + } + + return @missfile; +} + + +sub _check_manifest { + my($p) = @_; + my $read = maniread() || {}; + my $found = manifind($p); + my $skip = maniskip(); + + my @missentry = (); + foreach my $file (_sort keys %$found){ + next if $skip->($file); + warn "Debug: manicheck checking from disk $file\n" if $Debug; + unless ( exists $read->{$file} ) { + my $canon = $Is_MacOS ? "\t" . _unmacify($file) : ''; + warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; + push @missentry, $file; + } + } + + return @missentry; +} + + + +sub maniread { + my ($mfile) = @_; + $mfile ||= $MANIFEST; + my $read = {}; + local *M; + unless (open M, "< $mfile"){ + warn "Problem opening $mfile: $!"; + return $read; + } + local $_; + while (){ + chomp; + next if /^\s*#/; + + my($file, $comment); + + # filename may contain spaces if enclosed in '' + # (in which case, \\ and \' are escapes) + if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) { + $file =~ s/\\([\\'])/$1/g; + } + else { + ($file, $comment) = /^(\S+)\s*(.*)/; + } + next unless $file; + + if ($Is_MacOS) { + $file = _macify($file); + $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; + } + elsif ($Is_VMS_mode) { + require File::Basename; + my($base,$dir) = File::Basename::fileparse($file); + # Resolve illegal file specifications in the same way as tar + if ($Is_VMS_nodot) { + $dir =~ tr/./_/; + my(@pieces) = split(/\./,$base); + if (@pieces > 2) + { $base = shift(@pieces) . '.' . join('_',@pieces); } + my $okfile = "$dir$base"; + warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; + $file = $okfile; + } + if( $Is_VMS_lc ) { + $file = lc($file); + $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i; + } + } + + $read->{$file} = $comment; + } + close M; + $read; +} + + +# returns an anonymous sub that decides if an argument matches +sub maniskip { + my @skip ; + my $mfile = shift || "$MANIFEST.SKIP"; + _check_mskip_directives($mfile) if -f $mfile; + local(*M, $_); + open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0}; + while (){ + chomp; + s/\r//; + $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; + #my $comment = $3; + my $filename = $2; + if ( defined($1) ) { + $filename = $1; + $filename =~ s/\\(['\\])/$1/g; + } + next if (not defined($filename) or not $filename); + push @skip, _macify($filename); + } + close M; + return sub {0} unless (scalar @skip > 0); + + my $opts = $Is_VMS_mode ? '(?i)' : ''; + + # Make sure each entry is isolated in its own parentheses, in case + # any of them contain alternations + my $regex = join '|', map "(?:$_)", @skip; + + return sub { $_[0] =~ qr{$opts$regex} }; +} + +# checks for the special directives +# #!include_default +# #!include /path/to/some/manifest.skip +# in a custom MANIFEST.SKIP for, for including +# the content of, respectively, the default MANIFEST.SKIP +# and an external manifest.skip file +sub _check_mskip_directives { + my $mfile = shift; + local (*M, $_); + my @lines = (); + my $flag = 0; + unless (open M, "< $mfile") { + warn "Problem opening $mfile: $!"; + return; + } + while () { + if (/^#!include_default\s*$/) { + if (my @default = _include_mskip_file()) { + push @lines, @default; + warn "Debug: Including default MANIFEST.SKIP\n" if $Debug; + $flag++; + } + next; + } + if (/^#!include\s+(.*)\s*$/) { + my $external_file = $1; + if (my @external = _include_mskip_file($external_file)) { + push @lines, @external; + warn "Debug: Including external $external_file\n" if $Debug; + $flag++; + } + next; + } + push @lines, $_; + } + close M; + return unless $flag; + my $bakbase = $mfile; + $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots + rename $mfile, "$bakbase.bak"; + warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug; + unless (open M, "> $mfile") { + warn "Problem opening $mfile: $!"; + return; + } + binmode M, ':raw'; + print M $_ for (@lines); + close M; + return; +} + +# returns an array containing the lines of an external +# manifest.skip file, if given, or $DEFAULT_MSKIP +sub _include_mskip_file { + my $mskip = shift || $DEFAULT_MSKIP; + unless (-f $mskip) { + warn qq{Included file "$mskip" not found - skipping}; + return; + } + local (*M, $_); + unless (open M, "< $mskip") { + warn "Problem opening $mskip: $!"; + return; + } + my @lines = (); + push @lines, "\n#!start included $mskip\n"; + push @lines, $_ while ; + close M; + push @lines, "#!end included $mskip\n\n"; + return @lines; +} + + +sub manicopy { + my($read,$target,$how)=@_; + croak "manicopy() called without target argument" unless defined $target; + $how ||= 'cp'; + require File::Path; + require File::Basename; + + $target = VMS::Filespec::unixify($target) if $Is_VMS_mode; + File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); + foreach my $file (keys %$read){ + if ($Is_MacOS) { + if ($file =~ m!:!) { + my $dir = _maccat($target, $file); + $dir =~ s/[^:]+$//; + File::Path::mkpath($dir,1,0755); + } + cp_if_diff($file, _maccat($target, $file), $how); + } else { + $file = VMS::Filespec::unixify($file) if $Is_VMS_mode; + if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? + my $dir = File::Basename::dirname($file); + $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode; + File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); + } + cp_if_diff($file, "$target/$file", $how); + } + } +} + +sub cp_if_diff { + my($from, $to, $how)=@_; + if (! -f $from) { + carp "$from not found"; + return; + } + my($diff) = 0; + local(*F,*T); + open(F,"< $from\0") or die "Can't read $from: $!\n"; + if (open(T,"< $to\0")) { + local $_; + while () { $diff++,last if $_ ne ; } + $diff++ unless eof(T); + close T; + } + else { $diff++; } + close F; + if ($diff) { + if (-e $to) { + unlink($to) or confess "unlink $to: $!"; + } + STRICT_SWITCH: { + best($from,$to), last STRICT_SWITCH if $how eq 'best'; + cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; + ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; + croak("ExtUtils::Manifest::cp_if_diff " . + "called with illegal how argument [$how]. " . + "Legal values are 'best', 'cp', and 'ln'."); + } + } +} + +sub cp { + my ($srcFile, $dstFile) = @_; + my ($access,$mod) = (stat $srcFile)[8,9]; + + copy($srcFile,$dstFile); + utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; + _manicopy_chmod($srcFile, $dstFile); +} + + +sub ln { + my ($srcFile, $dstFile) = @_; + # Fix-me - VMS can support links. + return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); + link($srcFile, $dstFile); + + unless( _manicopy_chmod($srcFile, $dstFile) ) { + unlink $dstFile; + return; + } + 1; +} + +# 1) Strip off all group and world permissions. +# 2) Let everyone read it. +# 3) If the owner can execute it, everyone can. +sub _manicopy_chmod { + my($srcFile, $dstFile) = @_; + + my $perm = 0444 | (stat $srcFile)[2] & 0700; + chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile ); +} + +# Files that are often modified in the distdir. Don't hard link them. +my @Exceptions = qw(MANIFEST META.yml SIGNATURE); +sub best { + my ($srcFile, $dstFile) = @_; + + my $is_exception = grep $srcFile =~ /$_/, @Exceptions; + if ($is_exception or !$Config{d_link} or -l $srcFile) { + cp($srcFile, $dstFile); + } else { + ln($srcFile, $dstFile) or cp($srcFile, $dstFile); + } +} + +sub _macify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^\./||; + if ($file =~ m|/|) { + $file =~ s|/+|:|g; + $file = ":$file"; + } + + $file; +} + +sub _maccat { + my($f1, $f2) = @_; + + return "$f1/$f2" unless $Is_MacOS; + + $f1 .= ":$f2"; + $f1 =~ s/([^:]:):/$1/g; + return $f1; +} + +sub _unmacify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^:||; + $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; + $file =~ y|:|/|; + + $file; +} + + + +sub maniadd { + my($additions) = shift; + + _normalize($additions); + _fix_manifest($MANIFEST); + + my $manifest = maniread(); + my @needed = grep { !exists $manifest->{$_} } keys %$additions; + return 1 unless @needed; + + open(MANIFEST, ">>$MANIFEST") or + die "maniadd() could not open $MANIFEST: $!"; + binmode MANIFEST, ':raw'; + + foreach my $file (_sort @needed) { + my $comment = $additions->{$file} || ''; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + printf MANIFEST "%-40s %s\n", $file, $comment; + } + close MANIFEST or die "Error closing $MANIFEST: $!"; + + return 1; +} + + +# Make sure this MANIFEST is consistently written with native +# newlines and has a terminal newline. +sub _fix_manifest { + my $manifest_file = shift; + + open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; + local $/; + my @manifest = split /(\015\012|\012|\015)/, , -1; + close MANIFEST; + my $must_rewrite = ""; + if ($manifest[-1] eq ""){ + # sane case: last line had a terminal newline + pop @manifest; + for (my $i=1; $i<=$#manifest; $i+=2) { + unless ($manifest[$i] eq "\n") { + $must_rewrite = "not a newline at pos $i"; + last; + } + } + } else { + $must_rewrite = "last line without newline"; + } + + if ( $must_rewrite ) { + 1 while unlink $MANIFEST; # avoid multiple versions on VMS + open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!"; + binmode MANIFEST, ':raw'; + for (my $i=0; $i<=$#manifest; $i+=2) { + print MANIFEST "$manifest[$i]\n"; + } + close MANIFEST or die "could not write $MANIFEST: $!"; + } +} + + +# UNIMPLEMENTED +sub _normalize { + return; +} + + + +1; +package ExtUtils::Mkbootstrap; + +# There's just too much Dynaloader incest here to turn on strict vars. +use strict 'refs'; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require Exporter; +our @ISA = ('Exporter'); +our @EXPORT = ('&Mkbootstrap'); + +use Config; + +our $Verbose = 0; + + +sub Mkbootstrap { + my($baseext, @bsloadlibs)=@_; + @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs + + print " bsloadlibs=@bsloadlibs\n" if $Verbose; + + # We need DynaLoader here because we and/or the *_BS file may + # call dl_findfile(). We don't say `use' here because when + # first building perl extensions the DynaLoader will not have + # been built when MakeMaker gets first used. + require DynaLoader; + + rename "$baseext.bs", "$baseext.bso" + if -s "$baseext.bs"; + + if (-f "${baseext}_BS"){ + $_ = "${baseext}_BS"; + package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)}; + $bscode = ""; + unshift @INC, "."; + require $_; + shift @INC; + } + + if ($Config{'dlsrc'} =~ /^dl_dld/){ + package DynaLoader; + push(@dl_resolve_using, dl_findfile('-lc')); + } + + my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using); + my($method) = ''; + if (@all || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){ + open my $bs, ">", "$baseext.bs" + or die "Unable to open $baseext.bs: $!"; + print "Writing $baseext.bs\n"; + print " containing: @all" if $Verbose; + print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; + print $bs "# Do not edit this file, changes will be lost.\n"; + print $bs "# This file was automatically generated by the\n"; + print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; + if (@all) { + print $bs "\@DynaLoader::dl_resolve_using = "; + # If @all contains names in the form -lxxx or -Lxxx then it's asking for + # runtime library location so we automatically add a call to dl_findfile() + if (" @all" =~ m/ -[lLR]/){ + print $bs " dl_findfile(qw(\n @all\n ));\n"; + } else { + print $bs " qw(@all);\n"; + } + } + # write extra code if *_BS says so + print $bs $DynaLoader::bscode if $DynaLoader::bscode; + print $bs "\n1;\n"; + close $bs; + } +} + +1; + +__END__ + +package ExtUtils::MM_Win32; + +use strict; + + + +use ExtUtils::MakeMaker::Config; +use File::Basename; +use File::Spec; +use ExtUtils::MakeMaker qw(neatvalue _sprintf562); + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config ); + +sub _identify_compiler_environment { + my ( $config ) = @_; + + my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0; + my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0; + my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C + + return ( $BORLAND, $GCC, $MSVC ); +} + + + +sub dlsyms { + my($self,%attribs) = @_; + return '' if $self->{SKIPHASH}{'dynamic'}; + $self->xs_dlsyms_iterator(\%attribs); +} + + +sub xs_dlsyms_ext { + '.def'; +} + + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + + + +sub maybe_command { + my($self,$file) = @_; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } + return; +} + + + +sub init_DIRFILESEP { + my($self) = shift; + + # The ^ makes sure its not interpreted as an escape in nmake + $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' : + $self->is_make_type('dmake') ? '\\\\' : + $self->is_make_type('gmake') ? '/' + : '\\'; +} + + +sub init_tools { + my ($self) = @_; + + $self->{NOOP} ||= 'rem'; + $self->{DEV_NULL} ||= '> NUL'; + + $self->{FIXIN} ||= $self->{PERL_CORE} ? + "\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : + 'pl2bat.bat'; + + $self->SUPER::init_tools; + + # Setting SHELL from $Config{sh} can break dmake. Its ok without it. + delete $self->{SHELL}; + + return; +} + + + +sub init_others { + my $self = shift; + + $self->{LD} ||= 'link'; + $self->{AR} ||= 'lib'; + + $self->SUPER::init_others; + + $self->{LDLOADLIBS} ||= $Config{libs}; + # -Lfoo must come first for Borland, so we put it in LDDLFLAGS + if ($BORLAND) { + my $libs = $self->{LDLOADLIBS}; + my $libpath = ''; + while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { + $libpath .= ' ' if length $libpath; + $libpath .= $1; + } + $self->{LDLOADLIBS} = $libs; + $self->{LDDLFLAGS} ||= $Config{lddlflags}; + $self->{LDDLFLAGS} .= " $libpath"; + } + + return; +} + + + +sub init_platform { + my($self) = shift; + + $self->{MM_Win32_VERSION} = $VERSION; + + return; +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Win32_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +sub specify_shell { + my $self = shift; + return '' unless $self->is_make_type('gmake'); + "\nSHELL = $ENV{COMSPEC}\n"; +} + + +sub constants { + my $self = shift; + + my $make_text = $self->SUPER::constants; + return $make_text unless $self->is_make_type('dmake'); + + # dmake won't read any single "line" (even those with escaped newlines) + # larger than a certain size which can be as small as 8k. PM_TO_BLIB + # on large modules like DateTime::TimeZone can create lines over 32k. + # So we'll crank it up to a WHOPPING 64k. + # + # This has to come here before all the constants and not in + # platform_constants which is after constants. + my $size = $self->{MAXLINELENGTH} || 800000; + my $prefix = qq{ +# Get dmake to read long commands like PM_TO_BLIB +MAXLINELENGTH = $size + +}; + + return $prefix . $make_text; +} + + + +sub special_targets { + my($self) = @_; + + my $make_frag = $self->SUPER::special_targets; + + $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake'); +.USESHELL : +MAKE_FRAG + + return $make_frag; +} + + +sub static_lib_pure_cmd { + my ($self, $from) = @_; + $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; + sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from + : ($GCC ? '-ru $@ ' . $from + : '-out:$@ ' . $from)); +} + + +sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist; + if ($GCC) { + # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer + # uses dlltool - relies on post 2002 MinGW + # 1 2 + push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom; + $(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base +EOF + } elsif ($BORLAND) { + my $ldargs = $self->is_make_type('dmake') + ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),} + : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),}; + my $subbed; + if ($exportlist eq '$(EXPORT_LIST)') { + $subbed = $self->is_make_type('dmake') + ? q{$(EXPORT_LIST:s,/,\,)} + : q{$(subst /,\,$(EXPORT_LIST))}; + } else { + # in XSMULTI, exportlist is per-XS, so have to sub in perl not make + ($subbed = $exportlist) =~ s#/#\\#g; + } + push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed; + $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES) +EOF + } else { # VC + push @m, sprintf <<'EOF', $ldfrom, $exportlist; + $(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s +EOF + # Embed the manifest file if it exists + push(@m, q{ if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 + if exist $@.manifest del $@.manifest}); + } + push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; + + join '', @m; +} + +sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; +# This section creates the dynamically loadable objects from relevant +# objects and possibly $(MYEXTLIB). +OTHERLDFLAGS = %s +INST_DYNAMIC_DEP = %s +EOF +} + + +sub extra_clean_files { + my $self = shift; + + return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb'); +} + + +sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}"; + $self->{PERL_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$Config{libperl}"; + $self->{PERL_ARCHIVE_AFTER} = ''; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; +} + + + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return "$file.pl" if -r "$file.pl" && -f _; + return "$file.plx" if -r "$file.plx" && -f _; + return "$file.bat" if -r "$file.bat" && -f _; + return; +} + +sub can_dep_space { + my $self = shift; + 1; # with Win32::GetShortPathName +} + + +sub quote_dep { + my ($self, $arg) = @_; + if ($arg =~ / / and not $self->is_make_type('gmake')) { + require Win32; + $arg = Win32::GetShortPathName($arg); + die <SUPER::quote_dep($arg); +} + + + +sub xs_obj_opt { + my ($self, $output_file) = @_; + ($MSVC ? "/Fo" : "-o ") . $output_file; +} + + + +sub pasthru { + my($self) = shift; + my $old = $self->SUPER::pasthru; + return $old unless $self->is_make_type('nmake'); + $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /; + $old; +} + + + +sub arch_check { + my $self = shift; + + # Win32 is an XS module, minperl won't have it. + # arch_check() is not critical, so just fake it. + return 1 unless $self->can_load_xs; + return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_); +} + +sub _normalize_path_name { + my $self = shift; + my $file = shift; + + require Win32; + my $short = Win32::GetShortPathName($file); + return defined $short ? lc $short : lc $file; +} + + + +sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + $cmd = $self->quote_literal($cmd); + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; +} + + +sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP + + # Apply the Microsoft C/C++ parsing rules + $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\" + $text =~ s{(? \\\" + $text =~ s{(? \" + $text = qq{"$text"} if $text =~ /[ \t]/; + + # Apply the Command Prompt parsing rules (cmd.exe) + my @text = split /("[^"]*")/, $text; + # We should also escape parentheses, but it breaks one-liners containing + # $(MACRO)s in makefiles. + s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text; + $text = join('', @text); + + # dmake expands {{ to { and }} to }. + if( $self->is_make_type('dmake') ) { + $text =~ s/{/{{/g; + $text =~ s/}/}}/g; + } + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return $text; +} + + +sub escape_newlines { + my($self, $text) = @_; + + # Escape newlines + $text =~ s{\n}{\\\n}g; + + return $text; +} + + + +sub cd { + my($self, $dir, @cmds) = @_; + + return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake'); + + my $cmd = join "\n\t", map "$_", @cmds; + + my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir)); + + # No leading tab and no trailing newline makes for easier embedding. + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs; +cd %s + %s + cd %s +MAKE_FRAG + + chomp $make_frag; + + return $make_frag; +} + + + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 2 * 1024; +} + + + +sub os_flavor { + return('Win32'); +} + + + +sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static'); + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; + +} + + +sub make_type { + my ($self) = @_; + my $make = $self->make; + $make = +( File::Spec->splitpath( $make ) )[-1]; + $make =~ s!\.exe$!!i; + if ( $make =~ m![^A-Z0-9]!i ) { + ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make; + } + return "$make-style"; +} + +1; +__END__ + +package ExtUtils::Mksymlists; + +use 5.006; +use strict qw[ subs refs ]; +# no strict 'vars'; # until filehandles are exempted + +use Carp; +use Exporter; +use Config; + +our @ISA = qw(Exporter); +our @EXPORT = qw(&Mksymlists); +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +sub Mksymlists { + my(%spec) = @_; + my($osname) = $^O; + + croak("Insufficient information specified to Mksymlists") + unless ( $spec{NAME} or + ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) ); + + $spec{DL_VARS} = [] unless $spec{DL_VARS}; + ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + $spec{DL_FUNCS} = { $spec{NAME} => [] } + unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or + @{$spec{FUNCLIST}}); + if (defined $spec{DL_FUNCS}) { + foreach my $package (sort keys %{$spec{DL_FUNCS}}) { + my($packprefix,$bootseen); + ($packprefix = $package) =~ s/\W/_/g; + foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) { + if ($sym =~ /^boot_/) { + push(@{$spec{FUNCLIST}},$sym); + $bootseen++; + } + else { + push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym"); + } + } + push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen; + } + } + +# We'll need this if we ever add any OS which uses mod2fname +# not as pseudo-builtin. +# require DynaLoader; + if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { + $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); + } + + if ($osname eq 'aix') { _write_aix(\%spec); } + elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } + elsif ($osname eq 'VMS') { _write_vms(\%spec) } + elsif ($osname eq 'os2') { _write_os2(\%spec) } + elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } + else { + croak("Don't know how to create linker option file for $osname\n"); + } +} + + +sub _write_aix { + my($data) = @_; + + rename "$data->{FILE}.exp", "$data->{FILE}.exp_old"; + + open( my $exp, ">", "$data->{FILE}.exp") + or croak("Can't create $data->{FILE}.exp: $!\n"); + print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + close $exp; +} + + +sub _write_os2 { + my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); + + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + my $distname = $data->{DISTNAME} || $data->{NAME}; + $distname = "Distribution $distname"; + my $patchlevel = " pl$Config{perl_patchlevel}" || ''; + my $comment = sprintf "Perl (v%s%s%s) module %s", + $Config::Config{version}, $threaded, $patchlevel, $data->{NAME}; + chomp $comment; + if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { + $distname = 'perl5-porters@perl.org'; + $comment = "Core $comment"; + } + $comment = "$comment (Perl-config: $Config{config_args})"; + $comment = substr($comment, 0, 200) . "...)" if length $comment > 203; + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open(my $def, ">", "$data->{FILE}.def") + or croak("Can't create $data->{FILE}.def: $!\n"); + print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n"; + print $def "CODE LOADONCALL\n"; + print $def "DATA LOADONCALL NONSHARED MULTIPLE\n"; + print $def "EXPORTS\n "; + print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + _print_imports($def, $data); + close $def; +} + +sub _print_imports { + my ($def, $data)= @_; + my $imports= $data->{IMPORTS} + or return; + if ( keys %$imports ) { + print $def "IMPORTS\n"; + foreach my $name (sort keys %$imports) { + print $def " $name=$imports->{$name}\n"; + } + } +} + +sub _write_win32 { + my($data) = @_; + + require Config; + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open( my $def, ">", "$data->{FILE}.def" ) + or croak("Can't create $data->{FILE}.def: $!\n"); + # put library name in quotes (it could be a keyword, like 'Alias') + if ($Config::Config{'cc'} !~ /\bgcc/i) { + print $def "LIBRARY \"$data->{DLBASE}\"\n"; + } + print $def "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from Borland C and Visual C + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 + + #bcc dropped in 5.16, so dont create useless extra symbols for export table + unless($] >= 5.016) { + if ($Config::Config{'cc'} =~ /^bcc/i) { + push @syms, "_$_", "$_ = _$_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + else { + push @syms, "$_", "_$_ = $_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + } else { + push @syms, "$_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + print $def join("\n ",@syms, "\n") if @syms; + _print_imports($def, $data); + close $def; +} + + +sub _write_vms { + my($data) = @_; + + require Config; # a reminder for once we do $^O + require ExtUtils::XSSymSet; + + my($isvax) = $Config::Config{'archname'} =~ /VAX/i; + my($set) = new ExtUtils::XSSymSet; + + rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; + + open(my $opt,">", "$data->{FILE}.opt") + or croak("Can't create $data->{FILE}.opt: $!\n"); + + # Options file declaring universal symbols + # Used when linking shareable image for dynamic extension, + # or when linking PerlShr into which we've added this package + # as a static extension + # We don't do anything to preserve order, so we won't relax + # the GSMATCH criteria for a dynamic extension + + print $opt "case_sensitive=yes\n" + if $Config::Config{d_vms_case_sensitive_symbols}; + + foreach my $sym (@{$data->{FUNCLIST}}) { + my $safe = $set->addsym($sym); + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } + } + + foreach my $sym (@{$data->{DL_VARS}}) { + my $safe = $set->addsym($sym); + print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; } + } + + close $opt; +} + +1; + +__END__ + +#!perl +use 5.006; +BEGIN { pop @INC if $INC[-1] eq '.' } +use strict; +eval { + require ExtUtils::ParseXS; + 1; +} +or do { + my $err = $@ || 'Zombie error'; + my $v = $ExtUtils::ParseXS::VERSION; + $v = '' if not defined $v; + die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err"; +}; + +use Getopt::Long; + +my %args = (); + +my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n"; + +Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case); + +@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility +GetOptions(\%args, qw(hiertype! + prototypes! + versioncheck! + linenumbers! + optimize! + inout! + argtypes! + object_capi! + except! + v + typemap=s@ + output=s + s|strip=s + csuffix=s + )) + or die $usage; + +if ($args{v}) { + print "xsubpp version $ExtUtils::ParseXS::VERSION\n"; + exit; +} + +@ARGV == 1 or die $usage; + +$args{filename} = shift @ARGV; + +my $pxs = ExtUtils::ParseXS->new; +$pxs->process_file(%args); +exit( $pxs->report_error_count() ? 1 : 0 ); + +__END__ + +=head1 NAME + +xsubpp - compiler to convert Perl XS code into C code + +=head1 SYNOPSIS + +B [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs + +=head1 DESCRIPTION + +This compiler is typically run by the makefiles created by L +or by L or other Perl module build tools. + +I will compile XS code into C code by embedding the constructs +necessary to let C functions manipulate Perl values and creates the glue +necessary to let Perl access those functions. The compiler uses typemaps to +determine how to map C function parameters and variables to Perl values. + +The compiler will search for typemap files called I. It will use +the following search path to find default typemaps, with the rightmost +typemap taking precedence. + + ../../../typemap:../../typemap:../typemap:typemap + +It will also use a default typemap installed as C. + +=head1 OPTIONS + +Note that the C MakeMaker option may be used to add these options to +any makefiles generated by MakeMaker. + +=over 5 + +=item B<-hiertype> + +Retains '::' in type names so that C++ hierarchical types can be mapped. + +=item B<-except> + +Adds exception handling stubs to the C code. + +=item B<-typemap typemap> + +Indicates that a user-supplied typemap should take precedence over the +default typemaps. This option may be used multiple times, with the last +typemap having the highest precedence. + +=item B<-output filename> + +Specifies the name of the output file to generate. If no file is +specified, output will be written to standard output. + +=item B<-v> + +Prints the I version number to standard output, then exits. + +=item B<-prototypes> + +By default I will not automatically generate prototype code for +all xsubs. This flag will enable prototypes. + +=item B<-noversioncheck> + +Disables the run time test that determines if the object file (derived +from the C<.xs> file) and the C<.pm> files have the same version +number. + +=item B<-nolinenumbers> + +Prevents the inclusion of '#line' directives in the output. + +=item B<-nooptimize> + +Disables certain optimizations. The only optimization that is currently +affected is the use of Is by the output C code (see L). +This may significantly slow down the generated code, but this is the way +B of 5.005 and earlier operated. + +=item B<-noinout> + +Disable recognition of C, C and C declarations. + +=item B<-noargtypes> + +Disable recognition of ANSI-like descriptions of function signature. + +=item B<-C++> + +Currently doesn't do anything at all. This flag has been a no-op for +many versions of perl, at least as far back as perl5.003_07. It's +allowed here for backwards compatibility. + +=item B<-s=...> or B<-strip=...> + +I + +If specified, the given string will be stripped off from the beginning +of the C function name in the generated XS functions (if it starts with that prefix). +This only applies to XSUBs without C or C blocks. +For example, the XS: + + void foo_bar(int i); + +when C is invoked with C<-s foo_> will install a C +function in Perl, but really call C in C. Most of the time, +this is the opposite of what you want and failure modes are somewhat +obscure, so please avoid this option where possible. + +=back + +=head1 ENVIRONMENT + +No environment variables are used. + +=head1 AUTHOR + +Originally by Larry Wall. Turned into the C module +by Ken Williams. + +=head1 MODIFICATION HISTORY + +See the file F. + +=head1 SEE ALSO + +perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS + +=cut + +package ExtUtils::MM_Win95; + +use strict; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Win32; +our @ISA = qw(ExtUtils::MM_Win32); + +use ExtUtils::MakeMaker::Config; + + + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 1024; +} + + + +sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Win9x'); +} + + + + +1; +package ExtUtils::Embed; +require Exporter; +use Config; +require File::Spec; + +our ( @Extensions, $opt_o, $opt_s ); +use strict; + +# This is not a dual-life module, so no need for development version numbers +our $VERSION = '1.35'; + +our @ISA = qw(Exporter); +our @EXPORT = qw(&xsinit &ldopts + &ccopts &ccflags &ccdlflags &perl_inc + &xsi_header &xsi_protos &xsi_body); + +our $Verbose = 0; +our $lib_ext = $Config{lib_ext} || '.a'; + +sub is_cmd { $0 eq '-e' } + +sub my_return { + my $val = shift; + if(is_cmd) { + print $val; + } + else { + return $val; + } +} + +sub xsinit { + my($file, $std, $mods) = @_; + my($fh,@mods,%seen); + $file ||= "perlxsi.c"; + my $xsinit_proto = "pTHX"; + + if (@_) { + @mods = @$mods if $mods; + } + else { + require Getopt::Std; + Getopt::Std::getopts('o:s:'); + $file = $opt_o if defined $opt_o; + $std = $opt_s if defined $opt_s; + @mods = @ARGV; + } + $std = 1 unless scalar @mods; + + if ($file eq "STDOUT") { + $fh = \*STDOUT; + } + else { + open $fh, '>', $file + or die "Can't open '$file': $!"; + } + + push(@mods, static_ext()) if defined $std; + @mods = grep(!$seen{$_}++, @mods); + + print $fh &xsi_header(); + print $fh "\nEXTERN_C void xs_init ($xsinit_proto);\n\n"; + print $fh &xsi_protos(@mods); + + print $fh "\nEXTERN_C void\nxs_init($xsinit_proto)\n{\n"; + print $fh &xsi_body(@mods); + print $fh "}\n"; + +} + +sub xsi_header { + return <catdir(@ns); + + print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose; + foreach (@path) { + next unless -e ($archive = File::Spec->catdir($_,"auto",$root,"$sub$lib_ext")); + push @archives, $archive; + if(-e ($extra = File::Spec->catdir($_,"auto",$root,"extralibs.ld"))) { + local(*FH); + if(open(FH, '<', $extra)) { + my($libs) = ; chomp $libs; + push @potential_libs, split /\s+/, $libs; + } + else { + warn "Couldn't open '$extra'"; + } + } + last; + } + } + #print STDERR "\@potential_libs = @potential_libs\n"; + + my $libperl; + if ($^O eq 'MSWin32') { + $libperl = $Config{libperl}; + } + elsif ($^O eq 'os390' && $Config{usedl}) { + # Nothing for OS/390 (z/OS) dynamic. + } else { + $libperl = (grep(/^-l\w*perl\w*$/, @link_args))[0] + || ($Config{libperl} =~ /^lib(\w+)(\Q$lib_ext\E|\.\Q$Config{dlext}\E)$/ + ? "-l$1" : '') + || "-lperl"; + } + + my $lpath = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $lpath = qq["$lpath"] if $^O eq 'MSWin32'; + my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) = + MM->ext(join ' ', "-L$lpath", $libperl, @potential_libs); + + my $ld_or_bs = $bsloadlibs || $ldloadlibs; + print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose; + my $ccdlflags = _ccdlflags(); + my $ldflags = _ldflags(); + my $linkage = "$ccdlflags $ldflags @archives $ld_or_bs"; + print STDERR "ldopts: '$linkage'\n" if $Verbose; + + return $linkage if scalar @_; + my_return("$linkage\n"); +} + +sub ccflags { + my $ccflags = _ccflags(); + my_return(" $ccflags "); +} + +sub ccdlflags { + my $ccdlflags = _ccdlflags(); + my_return(" $ccdlflags "); +} + +sub perl_inc { + my $dir = File::Spec->catdir($Config{archlibexp}, 'CORE'); + $dir = qq["$dir"] if $^O eq 'MSWin32'; + my_return(" -I$dir "); +} + +sub ccopts { + ccflags . perl_inc; +} + +sub canon { + my($as, @ext) = @_; + foreach(@ext) { + # might be X::Y or lib/auto/X/Y/Y.a + next + if s!::!/!g; + s!^(?:lib|ext|dist|cpan)/(?:auto/)?!!; + s!/\w+\.\w+$!!; + } + if ($as ne '/') { + s!/!$as!g + foreach @ext; + } + @ext; +} + +__END__ + +# basic C types +int T_IV +unsigned T_UV +unsigned int T_UV +long T_IV +unsigned long T_UV +short T_IV +unsigned short T_UV +char T_CHAR +unsigned char T_U_CHAR +char * T_PV +unsigned char * T_PV +const char * T_PV +caddr_t T_PV +wchar_t * T_PV +wchar_t T_IV +# bool_t is defined in +bool_t T_IV +size_t T_UV +ssize_t T_IV +time_t T_NV +unsigned long * T_OPAQUEPTR +char ** T_PACKEDARRAY +void * T_PTR +Time_t * T_PV +SV * T_SV + +# These are the backwards-compatibility AV*/HV* typemaps that +# do not decrement refcounts. Locally override with +# "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED", +# "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED", +# to get the fixed versions. +SVREF T_SVREF +CV * T_CVREF +AV * T_AVREF +HV * T_HVREF + +IV T_IV +UV T_UV +NV T_NV +I32 T_IV +I16 T_IV +I8 T_IV +STRLEN T_UV +U32 T_U_LONG +U16 T_U_SHORT +U8 T_UV +Result T_U_CHAR +Boolean T_BOOL +float T_FLOAT +double T_DOUBLE +SysRet T_SYSRET +SysRetLong T_SYSRET +FILE * T_STDIO +PerlIO * T_INOUT +FileHandle T_PTROBJ +InputStream T_IN +InOutStream T_INOUT +OutputStream T_OUT +bool T_BOOL + +############################################################################# +INPUT +T_SV + $var = $arg +T_SVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv)){ + $var = SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_SVREF_REFCOUNT_FIXED + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv)){ + $var = SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_AVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ + $var = (AV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_AVREF_REFCOUNT_FIXED + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){ + $var = (AV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_HVREF + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ + $var = (HV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not a HASH reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_HVREF_REFCOUNT_FIXED + STMT_START { + SV* const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){ + $var = (HV*)SvRV(xsub_tmp_sv); + } + else{ + Perl_croak_nocontext(\"%s: %s is not a HASH reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_CVREF + STMT_START { + HV *st; + GV *gvp; + SV * const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0); + if (!$var) { + Perl_croak_nocontext(\"%s: %s is not a CODE reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_CVREF_REFCOUNT_FIXED + STMT_START { + HV *st; + GV *gvp; + SV * const xsub_tmp_sv = $arg; + SvGETMAGIC(xsub_tmp_sv); + $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0); + if (!$var) { + Perl_croak_nocontext(\"%s: %s is not a CODE reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\"); + } + } STMT_END +T_SYSRET + $var NOT IMPLEMENTED +T_UV + $var = ($type)SvUV($arg) +T_IV + $var = ($type)SvIV($arg) +T_INT + $var = (int)SvIV($arg) +T_ENUM + $var = ($type)SvIV($arg) +T_BOOL + $var = (bool)SvTRUE($arg) +T_U_INT + $var = (unsigned int)SvUV($arg) +T_SHORT + $var = (short)SvIV($arg) +T_U_SHORT + $var = (unsigned short)SvUV($arg) +T_LONG + $var = (long)SvIV($arg) +T_U_LONG + $var = (unsigned long)SvUV($arg) +T_CHAR + $var = (char)*SvPV_nolen($arg) +T_U_CHAR + $var = (unsigned char)SvUV($arg) +T_FLOAT + $var = (float)SvNV($arg) +T_NV + $var = ($type)SvNV($arg) +T_DOUBLE + $var = (double)SvNV($arg) +T_PV + $var = ($type)SvPV_nolen($arg) +T_PTR + $var = INT2PTR($type,SvIV($arg)) +T_PTRREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REF_IV_REF + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type *, tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REF_IV_PTR + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type, tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTROBJ + if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_PTRDESC + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + ${type}_desc = (\U${type}_DESC\E*) tmp; + $var = ${type}_desc->ptr; + } + else + Perl_croak_nocontext(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_REFREF + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not a reference\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\") +T_REFOBJ + if (sv_isa($arg, \"${ntype}\")) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = *INT2PTR($type,tmp); + } + else + Perl_croak_nocontext(\"%s: %s is not of type %s\", + ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, + \"$var\", \"$ntype\") +T_OPAQUE + $var = *($type *)SvPV_nolen($arg) +T_OPAQUEPTR + $var = ($type)SvPV_nolen($arg) +T_PACKED + $var = XS_unpack_$ntype($arg) +T_PACKEDARRAY + $var = XS_unpack_$ntype($arg) +T_ARRAY + U32 ix_$var = $argoff; + $var = $ntype(items -= $argoff); + while (items--) { + DO_ARRAY_ELEM; + ix_$var++; + } + /* this is the number of elements in the array */ + ix_$var -= $argoff +T_STDIO + $var = PerlIO_findFILE(IoIFP(sv_2io($arg))) +T_IN + $var = IoIFP(sv_2io($arg)) +T_INOUT + $var = IoIFP(sv_2io($arg)) +T_OUT + $var = IoOFP(sv_2io($arg)) +############################################################################# +OUTPUT +T_SV + $arg = $var; +T_SVREF + $arg = newRV((SV*)$var); +T_SVREF_REFCOUNT_FIXED + $arg = newRV_noinc((SV*)$var); +T_AVREF + $arg = newRV((SV*)$var); +T_AVREF_REFCOUNT_FIXED + $arg = newRV_noinc((SV*)$var); +T_HVREF + $arg = newRV((SV*)$var); +T_HVREF_REFCOUNT_FIXED + $arg = newRV_noinc((SV*)$var); +T_CVREF + $arg = newRV((SV*)$var); +T_CVREF_REFCOUNT_FIXED + $arg = newRV_noinc((SV*)$var); +T_IV + sv_setiv($arg, (IV)$var); +T_UV + sv_setuv($arg, (UV)$var); +T_INT + sv_setiv($arg, (IV)$var); +T_SYSRET + if ($var != -1) { + if ($var == 0) + sv_setpvn($arg, "0 but true", 10); + else + sv_setiv($arg, (IV)$var); + } +T_ENUM + sv_setiv($arg, (IV)$var); +T_BOOL + ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"} +T_U_INT + sv_setuv($arg, (UV)$var); +T_SHORT + sv_setiv($arg, (IV)$var); +T_U_SHORT + sv_setuv($arg, (UV)$var); +T_LONG + sv_setiv($arg, (IV)$var); +T_U_LONG + sv_setuv($arg, (UV)$var); +T_CHAR + sv_setpvn($arg, (char *)&$var, 1); +T_U_CHAR + sv_setuv($arg, (UV)$var); +T_FLOAT + sv_setnv($arg, (double)$var); +T_NV + sv_setnv($arg, (NV)$var); +T_DOUBLE + sv_setnv($arg, (double)$var); +T_PV + sv_setpv((SV*)$arg, $var); +T_PTR + sv_setiv($arg, PTR2IV($var)); +T_PTRREF + sv_setref_pv($arg, Nullch, (void*)$var); +T_REF_IV_REF + sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var)); +T_REF_IV_PTR + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTROBJ + sv_setref_pv($arg, \"${ntype}\", (void*)$var); +T_PTRDESC + sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var)); +T_REFREF + NOT_IMPLEMENTED +T_REFOBJ + NOT IMPLEMENTED +T_OPAQUE + sv_setpvn($arg, (char *)&$var, sizeof($var)); +T_OPAQUEPTR + sv_setpvn($arg, (char *)$var, sizeof(*$var)); +T_PACKED + XS_pack_$ntype($arg, $var); +T_PACKEDARRAY + XS_pack_$ntype($arg, $var, count_$ntype); +T_ARRAY + { + U32 ix_$var; + SSize_t extend_size = + /* The weird way this is written is because g++ is dumb + * enough to warn "comparison is always false" on something + * like: + * + * sizeof(a) > sizeof(b) && a > B_t_MAX + * + * (where the LH condition is false) + */ + (size_$var > (sizeof(size_$var) > sizeof(SSize_t) + ? SSize_t_MAX : size_$var)) + ? -1 : (SSize_t)size_$var; + EXTEND(SP, extend_size); + for (ix_$var = 0; ix_$var < size_$var; ix_$var++) { + ST(ix_$var) = sv_newmortal(); + DO_ARRAY_ELEM + } + } +T_STDIO + { + GV *gv = (GV *)sv_newmortal(); + PerlIO *fp = PerlIO_importFILE($var,0); + gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); + if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) { + SV *rv = newRV_inc((SV*)gv); + rv = sv_bless(rv, GvSTASH(gv)); + ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" + : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} + }${"$var" ne "RETVAL" ? \" + else + sv_setsv($arg, &PL_sv_undef);\n" : \""} + } +T_IN + { + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); + if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) { + SV *rv = newRV_inc((SV*)gv); + rv = sv_bless(rv, GvSTASH(gv)); + ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" + : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} + }${"$var" ne "RETVAL" ? \" + else + sv_setsv($arg, &PL_sv_undef);\n" : \""} + } +T_INOUT + { + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); + if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) { + SV *rv = newRV_inc((SV*)gv); + rv = sv_bless(rv, GvSTASH(gv)); + ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" + : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} + }${"$var" ne "RETVAL" ? \" + else + sv_setsv($arg, &PL_sv_undef);\n" : \""} + } +T_OUT + { + GV *gv = (GV *)sv_newmortal(); + gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0); + if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) { + SV *rv = newRV_inc((SV*)gv); + rv = sv_bless(rv, GvSTASH(gv)); + ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);" + : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"} + }${"$var" ne "RETVAL" ? \" + else + sv_setsv($arg, &PL_sv_undef);\n" : \""} + } +package ExtUtils::MM_AIX; + +use strict; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use ExtUtils::MakeMaker::Config; +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + +sub dlsyms { + my($self,%attribs) = @_; + return '' unless $self->needs_linking; + join "\n", $self->xs_dlsyms_iterator(\%attribs); +} + + +sub xs_dlsyms_ext { + '.exp'; +} + +sub xs_dlsyms_arg { + my($self, $file) = @_; + return qq{-bE:${file}}; +} + +sub init_others { + my $self = shift; + $self->SUPER::init_others; + # perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out + # so right value can be added by xs_make_dynamic_lib to work for XSMULTI + $self->{LDDLFLAGS} ||= $Config{lddlflags}; + $self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#; + return; +} + + + +1; +package ExtUtils::Constant; +use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); +$VERSION = '0.25'; + + +if ($] >= 5.006) { + eval "use warnings; 1" or die $@; +} +use strict; +use Carp qw(croak cluck); + +use Exporter; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet); + +@ISA = 'Exporter'; + +%EXPORT_TAGS = ( 'all' => [ qw( + XS_constant constant_types return_clause memEQ_clause C_stringify + C_constant autoload WriteConstants WriteMakefileSnippet +) ] ); + +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + + +sub constant_types { + ExtUtils::Constant::XS->header(); +} + +sub memEQ_clause { + cluck "ExtUtils::Constant::memEQ_clause is deprecated"; + ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1], + indent=>$_[2]}); +} + +sub return_clause ($$) { + cluck "ExtUtils::Constant::return_clause is deprecated"; + my $indent = shift; + ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_); +} + +sub switch_clause { + cluck "ExtUtils::Constant::switch_clause is deprecated"; + my $indent = shift; + my $comment = shift; + ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment}, + @_); +} + +sub C_constant { + my ($package, $subname, $default_type, $what, $indent, $breakout, @items) + = @_; + ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname, + default_type => $default_type, + types => $what, indent => $indent, + breakout => $breakout}, @items); +} + + +sub XS_constant { + my $package = shift; + my $what = shift; + my $XS_subname = shift; + my $C_subname = shift; + $XS_subname ||= 'constant'; + $C_subname ||= $XS_subname; + + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what)}; + } + my $params = ExtUtils::Constant::XS->params ($what); + my $type; + + my $xs = <<"EOT"; +void +$XS_subname(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; +EOT + + if ($params->{IV}) { + $xs .= " IV iv = 0; /* avoid uninit var warning */\n"; + } else { + $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; + } + if ($params->{NV}) { + $xs .= " NV nv = 0.0; /* avoid uninit var warning */\n"; + } else { + $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; + } + if ($params->{PV}) { + $xs .= " const char *pv = NULL; /* avoid uninit var warning */\n"; + } else { + $xs .= + " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; + } + + $xs .= << 'EOT'; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); +EOT + if ($params->{''}) { + $xs .= << 'EOT'; + INPUT: + int utf8 = SvUTF8(sv); +EOT + } + $xs .= << 'EOT'; + PPCODE: +EOT + + if ($params->{IV} xor $params->{NV}) { + $xs .= << "EOT"; + /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ +EOT + } + $xs .= " type = $C_subname(aTHX_ s, len"; + $xs .= ', utf8' if $params->{''}; + $xs .= ', &iv' if $params->{IV}; + $xs .= ', &nv' if $params->{NV}; + $xs .= ', &pv' if $params->{PV}; + $xs .= ', &sv' if $params->{SV}; + $xs .= ");\n"; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + $xs .= << "EOT"; + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = + sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined $package_sprintf_safe macro %s, used", + s)); + PUSHs(sv); + break; +EOT + + foreach $type (sort keys %XS_Constant) { + # '' marks utf8 flag needed. + next if $type eq ''; + $xs .= "\t/* Uncomment this if you need to return ${type}s\n" + unless $what->{$type}; + $xs .= " case PERL_constant_IS$type:\n"; + if (length $XS_Constant{$type}) { + $xs .= << "EOT"; + EXTEND(SP, 2); + PUSHs(&PL_sv_undef); + $XS_Constant{$type}; +EOT + } else { + # Do nothing. return (), which will be correctly interpreted as + # (undef, undef) + } + $xs .= " break;\n"; + unless ($what->{$type}) { + chop $xs; # Yes, another need for chop not chomp. + $xs .= " */\n"; + } + } + $xs .= << "EOT"; + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing $package_sprintf_safe macro %s, used", + type, s)); + PUSHs(sv); + } +EOT + + return $xs; +} + + + +# ' # Grr. syntax highlighters that don't grok pod. + +sub autoload { + my ($module, $compat_version, $autoloader) = @_; + $compat_version ||= $]; + croak "Can't maintain compatibility back as far as version $compat_version" + if $compat_version < 5; + my $func = "sub AUTOLOAD {\n" + . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" + . " # XS function."; + $func .= " If a constant is not found then control is passed\n" + . " # to the AUTOLOAD in AutoLoader." if $autoloader; + + + $func .= "\n\n" + . " my \$constname;\n"; + $func .= + " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); + + $func .= <<"EOT"; + (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&${module}::constant not defined" if \$constname eq 'constant'; + my (\$error, \$val) = constant(\$constname); +EOT + + if ($autoloader) { + $func .= <<'EOT'; + if ($error) { + if ($error =~ /is not a valid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + croak $error; + } + } +EOT + } else { + $func .= + " if (\$error) { croak \$error; }\n"; + } + + $func .= <<'END'; + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 +#XXX if ($] >= 5.00561) { +#XXX *$AUTOLOAD = sub () { $val }; +#XXX } +#XXX else { + *$AUTOLOAD = sub { $val }; +#XXX } + } + goto &$AUTOLOAD; +} + +END + + return $func; +} + + + +sub WriteMakefileSnippet { + my %args = @_; + my $indent = $args{INDENT} || 2; + + my $result = <<"EOT"; +ExtUtils::Constant::WriteConstants( + NAME => '$args{NAME}', + NAMES => \\\@names, + DEFAULT_TYPE => '$args{DEFAULT_TYPE}', +EOT + foreach (qw (C_FILE XS_FILE)) { + next unless exists $args{$_}; + $result .= sprintf " %-12s => '%s',\n", + $_, $args{$_}; + } + $result .= <<'EOT'; + ); +EOT + + $result =~ s/^/' 'x$indent/gem; + return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, + indent=>$indent,}, + @{$args{NAMES}}) + . $result; +} + + +sub WriteConstants { + my %ARGS = + ( # defaults + C_FILE => 'const-c.inc', + XS_FILE => 'const-xs.inc', + XS_SUBNAME => 'constant', + DEFAULT_TYPE => 'IV', + @_); + + $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0' + + croak "Module name not specified" unless length $ARGS{NAME}; + + # Do this before creating (empty) files, in case it fails: + require ExtUtils::Constant::ProxySubs if $ARGS{PROXYSUBS}; + + my $c_fh = $ARGS{C_FH}; + if (!$c_fh) { + if ($] <= 5.008) { + # We need these little games, rather than doing things + # unconditionally, because we're used in core Makefile.PLs before + # IO is available (needed by filehandle), but also we want to work on + # older perls where undefined scalars do not automatically turn into + # anonymous file handles. + require FileHandle; + $c_fh = FileHandle->new(); + } + open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; + } + + my $xs_fh = $ARGS{XS_FH}; + if (!$xs_fh) { + if ($] <= 5.008) { + require FileHandle; + $xs_fh = FileHandle->new(); + } + open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; + } + + # As this subroutine is intended to make code that isn't edited, there's no + # need for the user to specify any types that aren't found in the list of + # names. + + if ($ARGS{PROXYSUBS}) { + $ARGS{C_FH} = $c_fh; + $ARGS{XS_FH} = $xs_fh; + ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS); + } else { + my $types = {}; + + print $c_fh constant_types(); # macro defs + print $c_fh "\n"; + + # indent is still undef. Until anyone implements indent style rules with + # it. + foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, + subname => $ARGS{C_SUBNAME}, + default_type => + $ARGS{DEFAULT_TYPE}, + types => $types, + breakout => + $ARGS{BREAKOUT_AT}}, + @{$ARGS{NAMES}})) { + print $c_fh $_, "\n"; # C constant subs + } + print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, + $ARGS{C_SUBNAME}); + } + + close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH}; + close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH}; +} + +1; +__END__ + +package ExtUtils::MM_OS2; + +use strict; + +use ExtUtils::MakeMaker qw(neatvalue); +use File::Spec; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix); + + +sub init_dist { + my($self) = @_; + + $self->{TO_UNIX} ||= <<'MAKE_TEXT'; +$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip +MAKE_TEXT + + $self->SUPER::init_dist; +} + +sub dlsyms { + my($self,%attribs) = @_; + if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp"; + foreach my $name (sort keys %{$self->{IMPORTS}}) { + my $exp = $self->{IMPORTS}->{$name}; + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print $imp "$name $lib $id ?\n"; + } + close $imp or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + # May be running under miniperl, so have no glob... + eval { unlink ; 1 } or system "rm tmp_imp/*"; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } + return '' if $self->{SKIPHASH}{'dynamic'}; + $self->xs_dlsyms_iterator(\%attribs); +} + +sub xs_dlsyms_ext { + '.def'; +} + +sub xs_dlsyms_extra { + join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS); +} + +sub static_lib_pure_cmd { + my($self) = @_; + my $old = $self->SUPER::static_lib_pure_cmd; + return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; + $old . <<'EOC'; + $(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/* + $(RANLIB) "$@" +EOC +} + +sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; +} + +sub maybe_command { + my($self,$file) = @_; + $file =~ s,[/\\]+,/,g; + return $file if -x $file && ! -d _; + return "$file.exe" if -x "$file.exe" && ! -d _; + return "$file.cmd" if -x "$file.cmd" && ! -d _; + return; +} + + +sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)"; + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout + ? '' + : '$(PERL_INC)/libperl_override$(LIB_EXT)'; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; +} + + +sub os_flavor { + return('OS/2'); +} + + +sub xs_static_lib_is_xs { + return 1; +} + + +1; +package ExtUtils::CBuilder; + +use File::Spec (); +use File::Path (); +use File::Basename (); +use Perl::OSType qw/os_type/; + +use warnings; +use strict; +our $VERSION = '0.280230'; # VERSION +our @ISA; + +# We only use this once - don't waste a symbol table entry on it. +# More importantly, don't make it an inheritable method. +my $load = sub { + my $mod = shift; + eval "use $mod"; + die $@ if $@; + @ISA = ($mod); +}; + +{ + my @package = split /::/, __PACKAGE__; + + my $ostype = os_type(); + + if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) { + $load->(__PACKAGE__ . "::Platform::$^O"); + + } elsif ( $ostype && + grep {-e File::Spec->catfile($_, @package, 'Platform', $ostype) . '.pm'} @INC) { + $load->(__PACKAGE__ . "::Platform::$ostype"); + + } else { + $load->(__PACKAGE__ . "::Base"); + } +} + +1; +__END__ + +package ExtUtils::Install; +use strict; + +use Config qw(%Config); +use Cwd qw(cwd); +use Exporter (); +use File::Basename qw(dirname); +use File::Copy; +use File::Path; +use File::Spec; + +our @ISA = ('Exporter'); +our @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); + +our $MUST_REBOOT; + + +our $VERSION = '2.14'; # <-- do not forget to update the POD section just above this line! +$VERSION = eval $VERSION; + + +BEGIN { + *Is_VMS = $^O eq 'VMS' ? sub(){1} : sub(){0}; + *Is_Win32 = $^O eq 'MSWin32' ? sub(){1} : sub(){0}; + *Is_cygwin = $^O eq 'cygwin' ? sub(){1} : sub(){0}; + *CanMoveAtBoot = ($^O eq 'MSWin32' || $^O eq 'cygwin') ? sub(){1} : sub(){0}; +} + +my $Inc_uninstall_warn_handler; + +# install relative to here + +my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; +my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET}; +$INSTALL_QUIET = 1 + if (!exists $ENV{PERL_INSTALL_QUIET} and + defined $ENV{MAKEFLAGS} and + $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/); + +my $Curdir = File::Spec->curdir; + +sub _estr(@) { + return join "\n",'!' x 72,@_,'!' x 72,''; +} + +{my %warned; +sub _warnonce(@) { + my $first=shift; + my $msg=_estr "WARNING: $first",@_; + warn $msg unless $warned{$msg}++; +}} + +sub _choke(@) { + my $first=shift; + my $msg=_estr "ERROR: $first",@_; + require Carp; + Carp::croak($msg); +} + +sub _croak { + require Carp; + Carp::croak(@_); +} +sub _confess { + require Carp; + Carp::confess(@_); +} + +sub _compare { + require File::Compare; + File::Compare::compare(@_); +} + + +sub _chmod($$;$) { + my ( $mode, $item, $verbose )=@_; + $verbose ||= 0; + if (chmod $mode, $item) { + printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1; + } else { + my $err="$!"; + _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n", + $mode, $item, $err + if -e $item; + } +} + + +{ + my $Has_Win32API_File; + sub _move_file_at_boot { #XXX OS-SPECIFIC + my ( $file, $target, $moan )= @_; + _confess("Panic: Can't _move_file_at_boot on this platform!") + unless CanMoveAtBoot; + + my $descr= ref $target + ? "'$file' for deletion" + : "'$file' for installation as '$target'"; + + # *note* CanMoveAtBoot is only incidentally the same condition as below + # this needs not hold true in the future. + $Has_Win32API_File = (Is_Win32 || Is_cygwin) + ? (eval {require Win32API::File; 1} || 0) + : 0 unless defined $Has_Win32API_File; + if ( ! $Has_Win32API_File ) { + + my @msg=( + "Cannot schedule $descr at reboot.", + "Try installing Win32API::File to allow operations on locked files", + "to be scheduled during reboot. Or try to perform the operation by", + "hand yourself. (You may need to close other perl processes first)" + ); + if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } + return 0; + } + my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); + $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() + unless ref $target; + + _chmod( 0666, $file ); + _chmod( 0666, $target ) unless ref $target; + + if (Win32API::File::MoveFileEx( $file, $target, $opts )) { + $MUST_REBOOT ||= ref $target ? 0 : 1; + return 1; + } else { + my @msg=( + "MoveFileEx $descr at reboot failed: $^E", + "You may try to perform the operation by hand yourself. ", + "(You may need to close other perl processes first).", + ); + if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } + } + return 0; + } +} + + + + + +sub _unlink_or_rename { #XXX OS-SPECIFIC + my ( $file, $tryhard, $installing )= @_; + + # this chmod was originally unconditional. However, its not needed on + # POSIXy systems since permission to unlink a file is specified by the + # directory rather than the file; and in fact it screwed up hard- and + # symlinked files. Keep it for other platforms in case its still + # needed there. + if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) { + _chmod( 0666, $file ); + } + my $unlink_count = 0; + while (unlink $file) { $unlink_count++; } + return $file if $unlink_count > 0; + my $error="$!"; + + _choke("Cannot unlink '$file': $!") + unless CanMoveAtBoot && $tryhard; + + my $tmp= "AAA"; + ++$tmp while -e "$file.$tmp"; + $tmp= "$file.$tmp"; + + warn "WARNING: Unable to unlink '$file': $error\n", + "Going to try to rename it to '$tmp'.\n"; + + if ( rename $file, $tmp ) { + warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n"; + # when $installing we can set $moan to true. + # IOW, if we cant delete the renamed file at reboot its + # not the end of the world. The other cases are more serious + # and need to be fatal. + _move_file_at_boot( $tmp, [], $installing ); + return $file; + } elsif ( $installing ) { + _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor". + " installation as '$file' at reboot.\n"); + _move_file_at_boot( $tmp, $file ); + return $tmp; + } else { + _choke("Rename failed:$!", "Cannot proceed."); + } + +} + + + + + +sub _get_install_skip { + my ( $skip, $verbose )= @_; + if ($ENV{EU_INSTALL_IGNORE_SKIP}) { + print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" + if $verbose>2; + return []; + } + if ( ! defined $skip ) { + print "Looking for install skip list\n" + if $verbose>2; + for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) { + next unless $file; + print "\tChecking for $file\n" + if $verbose>2; + if (-e $file) { + $skip= $file; + last; + } + } + } + if ($skip && !ref $skip) { + print "Reading skip patterns from '$skip'.\n" + if $verbose; + if (open my $fh,$skip ) { + my @patterns; + while (<$fh>) { + chomp; + next if /^\s*(?:#|$)/; + print "\tSkip pattern: $_\n" if $verbose>3; + push @patterns, $_; + } + $skip= \@patterns; + } else { + warn "Can't read skip file:'$skip':$!\n"; + $skip=[]; + } + } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) { + print "Using array for skip list\n" + if $verbose>2; + } elsif ($verbose) { + print "No skip list found.\n" + if $verbose>1; + $skip= []; + } + warn "Got @{[0+@$skip]} skip patterns.\n" + if $verbose>3; + return $skip +} + + +{ + my $has_posix; + sub _have_write_access { + my $dir=shift; + unless (defined $has_posix) { + $has_posix = (!Is_cygwin && !Is_Win32 + && eval { local $^W; require POSIX; 1} ) || 0; + } + if ($has_posix) { + return POSIX::access($dir, POSIX::W_OK()); + } else { + return -w $dir; + } + } +} + + + +sub _can_write_dir { + my $dir=shift; + return + unless defined $dir and length $dir; + + my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1); + my @dirs = File::Spec->splitdir($dirs); + unshift @dirs, File::Spec->curdir + unless File::Spec->file_name_is_absolute($dir); + + my $path=''; + my @make; + while (@dirs) { + if (Is_VMS) { + $dir = File::Spec->catdir($vol,@dirs); + } + else { + $dir = File::Spec->catdir(@dirs); + $dir = File::Spec->catpath($vol,$dir,'') + if defined $vol and length $vol; + } + next if ( $dir eq $path ); + if ( ! -e $dir ) { + unshift @make,$dir; + next; + } + if ( _have_write_access($dir) ) { + return 1,$dir,@make + } else { + return 0,$dir,@make + } + } continue { + pop @dirs; + } + return 0; +} + + +sub _mkpath { + my ($dir,$show,$mode,$verbose,$dry_run)=@_; + if ( $verbose && $verbose > 1 && ! -d $dir) { + $show= 1; + printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; + } + if (!$dry_run) { + if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) { + _choke("Can't create '$dir'","$@"); + } + + } + my ($can,$root,@make)=_can_write_dir($dir); + if (!$can) { + my @msg=( + "Can't create '$dir'", + $root ? "Do not have write permissions on '$root'" + : "Unknown Error" + ); + if ($dry_run) { + _warnonce @msg; + } else { + _choke @msg; + } + } elsif ($show and $dry_run) { + print "$_\n" for @make; + } + +} + + + +sub _copy { + my ( $from, $to, $verbose, $dry_run)=@_; + if ($verbose && $verbose>1) { + printf "copy(%s,%s)\n", $from, $to; + } + if (!$dry_run) { + File::Copy::copy($from,$to) + or _croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" ); + } +} + + +sub _chdir { + my ($dir)= @_; + my $ret; + if (defined wantarray) { + $ret= cwd; + } + chdir $dir + or _choke("Couldn't chdir to '$dir': $!"); + return $ret; +} + + +sub install { #XXX OS-SPECIFIC + my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_; + if (@_==1 and eval { 1+@$from_to }) { + my %opts = @$from_to; + $from_to = $opts{from_to} + or _confess("from_to is a mandatory parameter"); + $verbose = $opts{verbose}; + $dry_run = $opts{dry_run}; + $uninstall_shadows = $opts{uninstall_shadows}; + $skip = $opts{skip}; + $always_copy = $opts{always_copy}; + $result = $opts{result}; + } + + $result ||= {}; + $verbose ||= 0; + $dry_run ||= 0; + + $skip= _get_install_skip($skip,$verbose); + $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY} + || $ENV{EU_ALWAYS_COPY} + || 0 + unless defined $always_copy; + + my(%from_to) = %$from_to; + my(%pack, $dir, %warned); + require ExtUtils::Packlist; + my($packlist) = ExtUtils::Packlist->new(); + + local(*DIR); + for (qw/read write/) { + $pack{$_}=$from_to{$_}; + delete $from_to{$_}; + } + my $tmpfile = install_rooted_file($pack{"read"}); + $packlist->read($tmpfile) if (-f $tmpfile); + my $cwd = cwd(); + my @found_files; + my %check_dirs; + require File::Find; + + my $blib_lib = File::Spec->catdir('blib', 'lib'); + my $blib_arch = File::Spec->catdir('blib', 'arch'); + + # File::Find seems to always be Unixy except on MacPerl :( + my $current_directory = $^O eq 'MacOS' ? $Curdir : '.'; + + MOD_INSTALL: foreach my $source (sort keys %from_to) { + #copy the tree to the target directory without altering + #timestamp and permission and remember for the .packlist + #file. The packlist file contains the absolute paths of the + #install locations. AFS users may call this a bug. We'll have + #to reconsider how to add the means to satisfy AFS users also. + + #October 1997: we want to install .pm files into archlib if + #there are any files in arch. So we depend on having ./blib/arch + #hardcoded here. + + my $targetroot = install_rooted_dir($from_to{$source}); + + if ($source eq $blib_lib and + exists $from_to{$blib_arch} and + directory_not_empty($blib_arch) + ){ + $targetroot = install_rooted_dir($from_to{$blib_arch}); + print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; + } + + next unless -d $source; + _chdir($source); + # 5.5.3's File::Find missing no_chdir option + # XXX OS-SPECIFIC + File::Find::find(sub { + my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; + + return if !-f _; + my $origfile = $_; + + return if $origfile eq ".exists"; + my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); + my $targetfile = File::Spec->catfile($targetdir, $origfile); + my $sourcedir = File::Spec->catdir($source, $File::Find::dir); + my $sourcefile = File::Spec->catfile($sourcedir, $origfile); + + for my $pat (@$skip) { + if ( $sourcefile=~/$pat/ ) { + print "Skipping $targetfile (filtered)\n" + if $verbose>1; + $result->{install_filtered}{$sourcefile} = $pat; + return; + } + } + # we have to do this for back compat with old File::Finds + # and because the target is relative + my $save_cwd = _chdir($cwd); + my $diff = 0; + # XXX: I wonder how useful this logic is actually -- demerphq + if ( $always_copy or !-f $targetfile or -s $targetfile != $size) { + $diff++; + } else { + # we might not need to copy this file + $diff = _compare($sourcefile, $targetfile); + } + $check_dirs{$targetdir}++ + unless -w $targetfile; + + push @found_files, + [ $diff, $File::Find::dir, $origfile, + $mode, $size, $atime, $mtime, + $targetdir, $targetfile, $sourcedir, $sourcefile, + + ]; + #restore the original directory we were in when File::Find + #called us so that it doesn't get horribly confused. + _chdir($save_cwd); + }, $current_directory ); + _chdir($cwd); + } + foreach my $targetdir (sort keys %check_dirs) { + _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); + } + foreach my $found (@found_files) { + my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, + $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found; + + my $realtarget= $targetfile; + if ($diff) { + eval { + if (-f $targetfile) { + print "_unlink_or_rename($targetfile)\n" if $verbose>1; + $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) + unless $dry_run; + } elsif ( ! -d $targetdir ) { + _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); + } + print "Installing $targetfile\n"; + + _copy( $sourcefile, $targetfile, $verbose, $dry_run, ); + + + #XXX OS-SPECIFIC + print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; + utime($atime,$mtime + Is_VMS,$targetfile) unless $dry_run>1; + + + $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); + $mode = $mode | 0222 + if $realtarget ne $targetfile; + _chmod( $mode, $targetfile, $verbose ); + $result->{install}{$targetfile} = $sourcefile; + 1 + } or do { + $result->{install_fail}{$targetfile} = $sourcefile; + die $@; + }; + } else { + $result->{install_unchanged}{$targetfile} = $sourcefile; + print "Skipping $targetfile (unchanged)\n" if $verbose; + } + + if ( $uninstall_shadows ) { + inc_uninstall($sourcefile,$ffd, $verbose, + $dry_run, + $realtarget ne $targetfile ? $realtarget : "", + $result); + } + + # Record the full pathname. + $packlist->{$targetfile}++; + } + + if ($pack{'write'}) { + $dir = install_rooted_dir(dirname($pack{'write'})); + _mkpath( $dir, 0, 0755, $verbose, $dry_run ); + print "Writing $pack{'write'}\n" if $verbose; + $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; + } + + _do_cleanup($verbose); + return $result; +} + + +sub _do_cleanup { + my ($verbose) = @_; + if ($MUST_REBOOT) { + die _estr "Operation not completed! ", + "You must reboot to complete the installation.", + "Sorry."; + } elsif (defined $MUST_REBOOT & $verbose) { + warn _estr "Installation will be completed at the next reboot.\n", + "However it is not necessary to reboot immediately.\n"; + } +} + + + +sub install_rooted_file { + if (defined $INSTALL_ROOT) { + File::Spec->catfile($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + + +sub install_rooted_dir { + if (defined $INSTALL_ROOT) { + File::Spec->catdir($INSTALL_ROOT, $_[0]); + } else { + $_[0]; + } +} + + + +sub forceunlink { + my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC + _unlink_or_rename( $file, $tryhard, not("installing") ); +} + + +sub directory_not_empty ($) { + my($dir) = @_; + my $files = 0; + require File::Find; + File::Find::find(sub { + return if $_ eq ".exists"; + if (-f) { + $File::Find::prune++; + $files = 1; + } + }, $dir); + return $files; +} + + +sub install_default { + @_ < 2 or _croak("install_default should be called with 0 or 1 argument"); + my $FULLEXT = @_ ? shift : $ARGV[0]; + defined $FULLEXT or die "Do not know to where to write install log"; + my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib"); + my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch"); + my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin'); + my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script'); + my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1'); + my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3'); + + my @INST_HTML; + if($Config{installhtmldir}) { + my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html'); + @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir}); + } + + install({ + read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", + write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", + $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? + $Config{installsitearch} : + $Config{installsitelib}, + $INST_ARCHLIB => $Config{installsitearch}, + $INST_BIN => $Config{installbin} , + $INST_SCRIPT => $Config{installscript}, + $INST_MAN1DIR => $Config{installman1dir}, + $INST_MAN3DIR => $Config{installman3dir}, + @INST_HTML, + },1,0,0); +} + + + +sub uninstall { + my($fil,$verbose,$dry_run) = @_; + $verbose ||= 0; + $dry_run ||= 0; + + die _estr "ERROR: no packlist file found: '$fil'" + unless -f $fil; + # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); + # require $my_req; # Hairy, but for the first + require ExtUtils::Packlist; + my ($packlist) = ExtUtils::Packlist->new($fil); + foreach (sort(keys(%$packlist))) { + chomp; + print "unlink $_\n" if $verbose; + forceunlink($_,'tryhard') unless $dry_run; + } + print "unlink $fil\n" if $verbose; + forceunlink($fil, 'tryhard') unless $dry_run; + _do_cleanup($verbose); +} + + +sub inc_uninstall { + my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_; + my($dir); + $ignore||=""; + my $file = (File::Spec->splitpath($filepath))[2]; + my %seen_dir = (); + + my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} + ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; + + my @dirs=( @PERL_ENV_LIB, + @INC, + @Config{qw(archlibexp + privlibexp + sitearchexp + sitelibexp)}); + + #warn join "\n","---",@dirs,"---"; + my $seen_ours; + foreach $dir ( @dirs ) { + my $canonpath = Is_VMS ? $dir : File::Spec->canonpath($dir); + next if $canonpath eq $Curdir; + next if $seen_dir{$canonpath}++; + my $targetfile = File::Spec->catfile($canonpath,$libdir,$file); + next unless -f $targetfile; + + # The reason why we compare file's contents is, that we cannot + # know, which is the file we just installed (AFS). So we leave + # an identical file in place + my $diff = 0; + if ( -f $targetfile && -s _ == -s $filepath) { + # We have a good chance, we can skip this one + $diff = _compare($filepath,$targetfile); + } else { + $diff++; + } + print "#$file and $targetfile differ\n" if $diff && $verbose > 1; + + if (!$diff or $targetfile eq $ignore) { + $seen_ours = 1; + next; + } + if ($dry_run) { + $results->{uninstall}{$targetfile} = $filepath; + if ($verbose) { + $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new(); + $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. + $Inc_uninstall_warn_handler->add( + File::Spec->catfile($libdir, $file), + $targetfile + ); + } + # if not verbose, we just say nothing + } else { + print "Unlinking $targetfile (shadowing?)\n" if $verbose; + eval { + die "Fake die for testing" + if $ExtUtils::Install::Testing and + ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile); + forceunlink($targetfile,'tryhard'); + $results->{uninstall}{$targetfile} = $filepath; + 1; + } or do { + $results->{fail_uninstall}{$targetfile} = $filepath; + if ($seen_ours) { + warn "Failed to remove probably harmless shadow file '$targetfile'\n"; + } else { + die "$@\n"; + } + }; + } + } +} + + +sub run_filter { + my ($cmd, $src, $dest) = @_; + local(*CMD, *SRC); + open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; + open(SRC, $src) || die "Cannot open $src: $!"; + my $buf; + my $sz = 1024; + while (my $len = sysread(SRC, $buf, $sz)) { + syswrite(CMD, $buf, $len); + } + close SRC; + close CMD or die "Filter command '$cmd' failed for $src"; +} + + +sub pm_to_blib { + my($fromto,$autodir,$pm_filter) = @_; + + _mkpath($autodir,0,0755) if defined $autodir; + while(my($from, $to) = each %$fromto) { + if( -f $to && -s $from == -s $to && -M $to < -M $from ) { + print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; + next; + } + + # When a pm_filter is defined, we need to pre-process the source first + # to determine whether it has changed or not. Therefore, only perform + # the comparison check when there's no filter to be ran. + # -- RAM, 03/01/2001 + + my $need_filtering = defined $pm_filter && length $pm_filter && + $from =~ /\.pm$/; + + if (!$need_filtering && 0 == _compare($from,$to)) { + print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; + next; + } + if (-f $to){ + # we wont try hard here. its too likely to mess things up. + forceunlink($to); + } else { + _mkpath(dirname($to),0,0755); + } + if ($need_filtering) { + run_filter($pm_filter, $from, $to); + print "$pm_filter <$from >$to\n"; + } else { + _copy( $from, $to ); + print "cp $from $to\n" unless $INSTALL_QUIET; + } + my($mode,$atime,$mtime) = (stat $from)[2,8,9]; + utime($atime,$mtime+Is_VMS,$to); + _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); + next unless $from =~ /\.pm$/; + _autosplit($to,$autodir) if defined $autodir; + } +} + + + +sub _autosplit { #XXX OS-SPECIFIC + require AutoSplit; + my $retval = AutoSplit::autosplit(@_); + close *AutoSplit::IN if defined *AutoSplit::IN{IO}; + + return $retval; +} + + +package ExtUtils::Install::Warn; + +sub new { bless {}, shift } + +sub add { + my($self,$file,$targetfile) = @_; + push @{$self->{$file}}, $targetfile; +} + +sub DESTROY { + unless(defined $INSTALL_ROOT) { + my $self = shift; + my($file,$i,$plural); + foreach $file (sort keys %$self) { + $plural = @{$self->{$file}} > 1 ? "s" : ""; + print "## Differing version$plural of $file found. You might like to\n"; + for (0..$#{$self->{$file}}) { + print "rm ", $self->{$file}[$_], "\n"; + $i++; + } + } + $plural = $i>1 ? "all those files" : "this file"; + my $inst = (_invokant() eq 'ExtUtils::MakeMaker') + ? ( $Config::Config{make} || 'make' ).' install' + . ( ExtUtils::Install::Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' ) + : './Build install uninst=1'; + print "## Running '$inst' will unlink $plural for you.\n"; + } +} + + +sub _invokant { + my @stack; + my $frame = 0; + while (my $file = (caller($frame++))[1]) { + push @stack, (File::Spec->splitpath($file))[2]; + } + + my $builder; + my $top = pop @stack; + if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) { + $builder = 'Module::Build'; + } else { + $builder = 'ExtUtils::MakeMaker'; + } + return $builder; +} + + +1; +package ExtUtils::MM_Cygwin; + +use strict; + +use ExtUtils::MakeMaker::Config; +use File::Spec; + +require ExtUtils::MM_Unix; +require ExtUtils::MM_Win32; +our @ISA = qw( ExtUtils::MM_Unix ); + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + + + +sub os_flavor { + return('Unix', 'Cygwin'); +} + + +sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true'); + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; + +} + + + +sub replace_manpage_separator { + my($self, $man) = @_; + $man =~ s{/+}{.}g; + return $man; +} + + +sub init_linker { + my $self = shift; + + if ($Config{useshrplib} eq 'true') { + my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}"; + if( $] >= 5.006002 ) { + $libperl =~ s/(dll\.)?a$/dll.a/; + } + $self->{PERL_ARCHIVE} = $libperl; + } else { + $self->{PERL_ARCHIVE} = + '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a"); + } + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + + +sub maybe_command { + my ($self, $file) = @_; + + my $cygpath = Cygwin::posix_to_win_path('/', 1); + my $filepath = Cygwin::posix_to_win_path($file, 1); + + return (substr($filepath,0,length($cygpath)) eq $cygpath) + ? $self->SUPER::maybe_command($file) # Unix + : ExtUtils::MM_Win32->maybe_command($file); # Win32 +} + + +sub dynamic_lib { + my($self, %attribs) = @_; + my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs); + return '' unless $s; + return $s unless %{$self->{XS}}; + + # do an ephemeral rebase so the new DLL fits to the current rebase map + $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); + $s; +} + + +sub install { + my($self, %attribs) = @_; + my $s = ExtUtils::MM_Unix::install($self, %attribs); + return '' unless $s; + return $s unless %{$self->{XS}}; + + my $INSTALLDIRS = $self->{INSTALLDIRS}; + my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")}; + my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/"; + my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}"; + $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); + $s; +} + + +sub all_target { + ExtUtils::MM_Unix::all_target(shift); +} + + +1; +package ExtUtils::MM_BeOS; + +use strict; + + +use ExtUtils::MakeMaker::Config; +use File::Spec; +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; + +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + + + +sub os_flavor { + return('BeOS'); +} + + +sub init_linker { + my($self) = shift; + + $self->{PERL_ARCHIVE} ||= + File::Spec->catdir('$(PERL_INC)',$Config{libperl}); + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + +package ExtUtils::Packlist; + +use 5.00503; +use strict; +use Carp qw(); +use Config; +use vars qw($VERSION $Relocations); +$VERSION = '2.14'; +$VERSION = eval $VERSION; + +# Used for generating filehandle globs. IO::File might not be available! +my $fhname = "FH1"; + + +sub mkfh() +{ +no strict; +local $^W; +my $fh = \*{$fhname++}; +use strict; +return($fh); +} + + +sub __find_relocations +{ + my %paths; + while (my ($raw_key, $raw_val) = each %Config) { + my $exp_key = $raw_key . "exp"; + next unless exists $Config{$exp_key}; + next unless $raw_val =~ m!\.\.\./!; + $paths{$Config{$exp_key}}++; + } + # Longest prefixes go first in the alternatives + my $alternations = join "|", map {quotemeta $_} + sort {length $b <=> length $a} keys %paths; + qr/^($alternations)/o; +} + +sub new($$) +{ +my ($class, $packfile) = @_; +$class = ref($class) || $class; +my %self; +tie(%self, $class, $packfile); +return(bless(\%self, $class)); +} + +sub TIEHASH +{ +my ($class, $packfile) = @_; +my $self = { packfile => $packfile }; +bless($self, $class); +$self->read($packfile) if (defined($packfile) && -f $packfile); +return($self); +} + +sub STORE +{ +$_[0]->{data}->{$_[1]} = $_[2]; +} + +sub FETCH +{ +return($_[0]->{data}->{$_[1]}); +} + +sub FIRSTKEY +{ +my $reset = scalar(keys(%{$_[0]->{data}})); +return(each(%{$_[0]->{data}})); +} + +sub NEXTKEY +{ +return(each(%{$_[0]->{data}})); +} + +sub EXISTS +{ +return(exists($_[0]->{data}->{$_[1]})); +} + +sub DELETE +{ +return(delete($_[0]->{data}->{$_[1]})); +} + +sub CLEAR +{ +%{$_[0]->{data}} = (); +} + +sub DESTROY +{ +} + +sub read($;$) +{ +my ($self, $packfile) = @_; +$self = tied(%$self) || $self; + +if (defined($packfile)) { $self->{packfile} = $packfile; } +else { $packfile = $self->{packfile}; } +Carp::croak("No packlist filename specified") if (! defined($packfile)); +my $fh = mkfh(); +open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!"); +$self->{data} = {}; +my ($line); +while (defined($line = <$fh>)) + { + chomp $line; + my ($key, $data) = $line; + if ($key =~ /^(.*?)( \w+=.*)$/) + { + $key = $1; + $data = { map { split('=', $_) } split(' ', $2)}; + + if ($Config{userelocatableinc} && $data->{relocate_as}) + { + require File::Spec; + require Cwd; + my ($vol, $dir) = File::Spec->splitpath($packfile); + my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as}); + $key = Cwd::realpath($newpath); + } + } + $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths + $self->{data}->{$key} = $data; + } +close($fh); +} + +sub write($;$) +{ +my ($self, $packfile) = @_; +$self = tied(%$self) || $self; +if (defined($packfile)) { $self->{packfile} = $packfile; } +else { $packfile = $self->{packfile}; } +Carp::croak("No packlist filename specified") if (! defined($packfile)); +my $fh = mkfh(); +open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!"); +foreach my $key (sort(keys(%{$self->{data}}))) + { + my $data = $self->{data}->{$key}; + if ($Config{userelocatableinc}) { + $Relocations ||= __find_relocations(); + if ($packfile =~ $Relocations) { + # We are writing into a subdirectory of a run-time relocated + # path. Figure out if the this file is also within a subdir. + my $prefix = $1; + if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix))) + { + # The relocated path is within the found prefix + my $packfile_prefix; + (undef, $packfile_prefix) + = File::Spec->splitpath($packfile); + + my $relocate_as + = File::Spec->abs2rel($key, $packfile_prefix); + + if (!ref $data) { + $data = {}; + } + $data->{relocate_as} = $relocate_as; + } + } + } + print $fh ("$key"); + if (ref($data)) + { + foreach my $k (sort(keys(%$data))) + { + print $fh (" $k=$data->{$k}"); + } + } + print $fh ("\n"); + } +close($fh); +} + +sub validate($;$) +{ +my ($self, $remove) = @_; +$self = tied(%$self) || $self; +my @missing; +foreach my $key (sort(keys(%{$self->{data}}))) + { + if (! -e $key) + { + push(@missing, $key); + delete($self->{data}{$key}) if ($remove); + } + } +return(@missing); +} + +sub packlist_file($) +{ +my ($self) = @_; +$self = tied(%$self) || $self; +return($self->{packfile}); +} + +1; + +__END__ + +package ExtUtils::MY; + +use strict; +require ExtUtils::MM; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; +our @ISA = qw(ExtUtils::MM); + +{ + package MY; + our @ISA = qw(ExtUtils::MY); +} + +sub DESTROY {} + + +package ExtUtils::Typemaps; +use 5.006001; +use strict; +use warnings; +our $VERSION = '3.38'; + +require ExtUtils::ParseXS; +require ExtUtils::ParseXS::Constants; +require ExtUtils::Typemaps::InputMap; +require ExtUtils::Typemaps::OutputMap; +require ExtUtils::Typemaps::Type; + + + +sub new { + my $class = shift; + my %args = @_; + + if (defined $args{file} and defined $args{string}) { + die("Cannot handle both 'file' and 'string' arguments to constructor"); + } + + my $self = bless { + file => undef, + %args, + typemap_section => [], + typemap_lookup => {}, + input_section => [], + input_lookup => {}, + output_section => [], + output_lookup => {}, + } => $class; + + $self->_init(); + + return $self; +} + +sub _init { + my $self = shift; + if (defined $self->{string}) { + $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); + delete $self->{string}; + } + elsif (defined $self->{file} and -e $self->{file}) { + open my $fh, '<', $self->{file} + or die "Cannot open typemap file '" + . $self->{file} . "' for reading: $!"; + local $/ = undef; + my $string = <$fh>; + $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); + } +} + + + +sub file { + $_[0]->{file} = $_[1] if @_ > 1; + $_[0]->{file} +} + + +sub add_typemap { + my $self = shift; + my $type; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $type = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + + $type = ExtUtils::Typemaps::Type->new( + xstype => $xstype, + 'prototype' => $args{'prototype'}, + ctype => $ctype, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_typemap(ctype => $type->ctype); + } + elsif ($args{skip}) { + return() if exists $self->{typemap_lookup}{$type->ctype}; + } + else { + $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype); + } + + # store + push @{$self->{typemap_section}}, $type; + # remember type for lookup, too. + $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}}; + + return 1; +} + + +sub add_inputmap { + my $self = shift; + my $input; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $input = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + my $code = $args{code}; + die("Need code argument") if not defined $code; + + $input = ExtUtils::Typemaps::InputMap->new( + xstype => $xstype, + code => $code, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_inputmap(xstype => $input->xstype); + } + elsif ($args{skip}) { + return() if exists $self->{input_lookup}{$input->xstype}; + } + else { + $self->validate(inputmap_xstype => $input->xstype); + } + + # store + push @{$self->{input_section}}, $input; + # remember type for lookup, too. + $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}}; + + return 1; +} + + +sub add_outputmap { + my $self = shift; + my $output; + my %args; + + if ((@_ % 2) == 1) { + my $orig = shift; + $output = $orig->new(); + %args = @_; + } + else { + %args = @_; + my $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + my $code = $args{code}; + die("Need code argument") if not defined $code; + + $output = ExtUtils::Typemaps::OutputMap->new( + xstype => $xstype, + code => $code, + ); + } + + if ($args{skip} and $args{replace}) { + die("Cannot use both 'skip' and 'replace'"); + } + + if ($args{replace}) { + $self->remove_outputmap(xstype => $output->xstype); + } + elsif ($args{skip}) { + return() if exists $self->{output_lookup}{$output->xstype}; + } + else { + $self->validate(outputmap_xstype => $output->xstype); + } + + # store + push @{$self->{output_section}}, $output; + # remember type for lookup, too. + $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}}; + + return 1; +} + + +sub add_string { + my $self = shift; + my %args = @_; + die("Need 'string' argument") if not defined $args{string}; + + # no, this is not elegant. + my $other = ExtUtils::Typemaps->new(string => $args{string}); + $self->merge(typemap => $other); +} + + +sub remove_typemap { + my $self = shift; + my $ctype; + if (@_ > 1) { + my %args = @_; + $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + $ctype = tidy_type($ctype); + } + else { + $ctype = $_[0]->tidy_ctype; + } + + return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup}); +} + + +sub remove_inputmap { + my $self = shift; + my $xstype; + if (@_ > 1) { + my %args = @_; + $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + } + else { + $xstype = $_[0]->xstype; + } + + return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup}); +} + + +sub remove_outputmap { + my $self = shift; + my $xstype; + if (@_ > 1) { + my %args = @_; + $xstype = $args{xstype}; + die("Need xstype argument") if not defined $xstype; + } + else { + $xstype = $_[0]->xstype; + } + + return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup}); +} + +sub _remove { + my $self = shift; + my $rm = shift; + my $array = shift; + my $lookup = shift; + + # Just fetch the index of the item from the lookup table + my $index = $lookup->{$rm}; + return() if not defined $index; + + # Nuke the item from storage + splice(@$array, $index, 1); + + # Decrement the storage position of all items thereafter + foreach my $key (keys %$lookup) { + if ($lookup->{$key} > $index) { + $lookup->{$key}--; + } + } + return(); +} + + +sub get_typemap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $ctype = $args{ctype}; + die("Need ctype argument") if not defined $ctype; + $ctype = tidy_type($ctype); + + my $index = $self->{typemap_lookup}{$ctype}; + return() if not defined $index; + return $self->{typemap_section}[$index]; +} + + +sub get_inputmap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $xstype = $args{xstype}; + my $ctype = $args{ctype}; + die("Need xstype or ctype argument") + if not defined $xstype + and not defined $ctype; + die("Need xstype OR ctype arguments, not both") + if defined $xstype and defined $ctype; + + if (defined $ctype) { + my $tm = $self->get_typemap(ctype => $ctype); + $xstype = $tm && $tm->xstype; + return() if not defined $xstype; + } + + my $index = $self->{input_lookup}{$xstype}; + return() if not defined $index; + return $self->{input_section}[$index]; +} + + +sub get_outputmap { + my $self = shift; + die("Need named parameters, got uneven number") if @_ % 2; + + my %args = @_; + my $xstype = $args{xstype}; + my $ctype = $args{ctype}; + die("Need xstype or ctype argument") + if not defined $xstype + and not defined $ctype; + die("Need xstype OR ctype arguments, not both") + if defined $xstype and defined $ctype; + + if (defined $ctype) { + my $tm = $self->get_typemap(ctype => $ctype); + $xstype = $tm && $tm->xstype; + return() if not defined $xstype; + } + + my $index = $self->{output_lookup}{$xstype}; + return() if not defined $index; + return $self->{output_section}[$index]; +} + + +sub write { + my $self = shift; + my %args = @_; + my $file = defined $args{file} ? $args{file} : $self->file(); + die("write() needs a file argument (or set the file name of the typemap using the 'file' method)") + if not defined $file; + + open my $fh, '>', $file + or die "Cannot open typemap file '$file' for writing: $!"; + print $fh $self->as_string(); + close $fh; +} + + +sub as_string { + my $self = shift; + my $typemap = $self->{typemap_section}; + my @code; + push @code, "TYPEMAP\n"; + foreach my $entry (@$typemap) { + # type kind proto + # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o + push @code, $entry->ctype . "\t" . $entry->xstype + . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n"; + } + + my $input = $self->{input_section}; + if (@$input) { + push @code, "\nINPUT\n"; + foreach my $entry (@$input) { + push @code, $entry->xstype, "\n", $entry->code, "\n"; + } + } + + my $output = $self->{output_section}; + if (@$output) { + push @code, "\nOUTPUT\n"; + foreach my $entry (@$output) { + push @code, $entry->xstype, "\n", $entry->code, "\n"; + } + } + return join '', @code; +} + + +sub as_embedded_typemap { + my $self = shift; + my $string = $self->as_string; + + my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END); + my $icand = 0; + my $cand_suffix = ""; + while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) { + $icand++; + if ($icand == @ident_cand) { + $icand = 0; + ++$cand_suffix; + } + } + + my $marker = "$ident_cand[$icand]$cand_suffix"; + return "TYPEMAP: <<$marker;\n$string\n$marker\n"; +} + + +sub merge { + my $self = shift; + my %args = @_; + + if (exists $args{typemap} and exists $args{file}) { + die("Need {file} OR {typemap} argument. Not both!"); + } + elsif (not exists $args{typemap} and not exists $args{file}) { + die("Need {file} or {typemap} argument!"); + } + + my @params; + push @params, 'replace' => $args{replace} if exists $args{replace}; + push @params, 'skip' => $args{skip} if exists $args{skip}; + + my $typemap = $args{typemap}; + if (not defined $typemap) { + $typemap = ref($self)->new(file => $args{file}, @params); + } + + # FIXME breaking encapsulation. Add accessor code. + foreach my $entry (@{$typemap->{typemap_section}}) { + $self->add_typemap( $entry, @params ); + } + + foreach my $entry (@{$typemap->{input_section}}) { + $self->add_inputmap( $entry, @params ); + } + + foreach my $entry (@{$typemap->{output_section}}) { + $self->add_outputmap( $entry, @params ); + } + + return 1; +} + + +sub is_empty { + my $self = shift; + + return @{ $self->{typemap_section} } == 0 + && @{ $self->{input_section} } == 0 + && @{ $self->{output_section} } == 0; +} + + +sub list_mapped_ctypes { + my $self = shift; + return sort keys %{ $self->{typemap_lookup} }; +} + + +sub _get_typemap_hash { + my $self = shift; + my $lookup = $self->{typemap_lookup}; + my $storage = $self->{typemap_section}; + + my %rv; + foreach my $ctype (keys %$lookup) { + $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; + } + + return \%rv; +} + + +sub _get_inputmap_hash { + my $self = shift; + my $lookup = $self->{input_lookup}; + my $storage = $self->{input_section}; + + my %rv; + foreach my $xstype (keys %$lookup) { + $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; + + # Squash trailing whitespace to one line break + # This isn't strictly necessary, but makes the output more similar + # to the original ExtUtils::ParseXS. + $rv{$xstype} =~ s/\s*\z/\n/; + } + + return \%rv; +} + + + +sub _get_outputmap_hash { + my $self = shift; + my $lookup = $self->{output_lookup}; + my $storage = $self->{output_section}; + + my %rv; + foreach my $xstype (keys %$lookup) { + $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; + + # Squash trailing whitespace to one line break + # This isn't strictly necessary, but makes the output more similar + # to the original ExtUtils::ParseXS. + $rv{$xstype} =~ s/\s*\z/\n/; + } + + return \%rv; +} + + +sub _get_prototype_hash { + my $self = shift; + my $lookup = $self->{typemap_lookup}; + my $storage = $self->{typemap_section}; + + my %rv; + foreach my $ctype (keys %$lookup) { + $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; + } + + return \%rv; +} + + + +# make sure that the provided types wouldn't collide with what's +# in the object already. +sub validate { + my $self = shift; + my %args = @_; + + if ( exists $args{ctype} + and exists $self->{typemap_lookup}{tidy_type($args{ctype})} ) + { + die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); + } + + if ( exists $args{inputmap_xstype} + and exists $self->{input_lookup}{$args{inputmap_xstype}} ) + { + die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); + } + + if ( exists $args{outputmap_xstype} + and exists $self->{output_lookup}{$args{outputmap_xstype}} ) + { + die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); + } + + return 1; +} + + +sub clone { + my $proto = shift; + my %args = @_; + + my $self; + if ($args{shallow}) { + $self = bless( { + %$proto, + typemap_section => [@{$proto->{typemap_section}}], + typemap_lookup => {%{$proto->{typemap_lookup}}}, + input_section => [@{$proto->{input_section}}], + input_lookup => {%{$proto->{input_lookup}}}, + output_section => [@{$proto->{output_section}}], + output_lookup => {%{$proto->{output_lookup}}}, + } => ref($proto) ); + } + else { + $self = bless( { + %$proto, + typemap_section => [map $_->new, @{$proto->{typemap_section}}], + typemap_lookup => {%{$proto->{typemap_lookup}}}, + input_section => [map $_->new, @{$proto->{input_section}}], + input_lookup => {%{$proto->{input_lookup}}}, + output_section => [map $_->new, @{$proto->{output_section}}], + output_lookup => {%{$proto->{output_lookup}}}, + } => ref($proto) ); + } + + return $self; +} + + +sub tidy_type { + local $_ = shift; + + # for templated C++ types, do some bit of flawed canonicalization + # wrt. templates at least + if (/[<>]/) { + s/\s*([<>])\s*/$1/g; + s/>>/> >/g; + } + + # rationalise any '*' by joining them into bunches and removing whitespace + s#\s*(\*+)\s*#$1#g; + s#(\*+)# $1 #g ; + + # trim leading & trailing whitespace + s/^\s+//; s/\s+$//; + + # change multiple whitespace into a single space + s/\s+/ /g; + + $_; +} + + + +sub _parse { + my $self = shift; + my $stringref = shift; + my $lineno_offset = shift; + $lineno_offset = 0 if not defined $lineno_offset; + my $filename = shift; + $filename = '' if not defined $filename; + + my $replace = $self->{replace}; + my $skip = $self->{skip}; + die "Can only replace OR skip" if $replace and $skip; + my @add_params; + push @add_params, replace => 1 if $replace; + push @add_params, skip => 1 if $skip; + + # TODO comments should round-trip, currently ignoring + # TODO order of sections, multiple sections of same type + # Heavily influenced by ExtUtils::ParseXS + my $section = 'typemap'; + my $lineno = $lineno_offset; + my $junk = ""; + my $current = \$junk; + my @input_expr; + my @output_expr; + while ($$stringref =~ /^(.*)$/gcm) { + local $_ = $1; + ++$lineno; + chomp; + next if /^\s*#/; + if (/^INPUT\s*$/) { + $section = 'input'; + $current = \$junk; + next; + } + elsif (/^OUTPUT\s*$/) { + $section = 'output'; + $current = \$junk; + next; + } + elsif (/^TYPEMAP\s*$/) { + $section = 'typemap'; + $current = \$junk; + next; + } + + if ($section eq 'typemap') { + my $line = $_; + s/^\s+//; s/\s+$//; + next if $_ eq '' or /^#/; + my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o + or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), + next; + # prototype defaults to '$' + $proto = '$' unless $proto; + warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") + unless _valid_proto_string($proto); + $self->add_typemap( + ExtUtils::Typemaps::Type->new( + xstype => $kind, proto => $proto, ctype => $type + ), + @add_params + ); + } elsif (/^\s/) { + s/\s+$//; + $$current .= $$current eq '' ? $_ : "\n".$_; + } elsif ($_ eq '') { + next; + } elsif ($section eq 'input') { + s/\s+$//; + push @input_expr, {xstype => $_, code => ''}; + $current = \$input_expr[-1]{code}; + } else { # output section + s/\s+$//; + push @output_expr, {xstype => $_, code => ''}; + $current = \$output_expr[-1]{code}; + } + + } # end while lines + + foreach my $inexpr (@input_expr) { + $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); + } + foreach my $outexpr (@output_expr) { + $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); + } + + return 1; +} + +# taken from ExtUtils::ParseXS +sub _valid_proto_string { + my $string = shift; + if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { + return $string; + } + + return 0 ; +} + +# taken from ExtUtils::ParseXS (C_string) +sub _escape_backslashes { + my $string = shift; + $string =~ s[\\][\\\\]g; + $string; +} + + +1; + +package ExtUtils::Command; + +use 5.00503; +use strict; +require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod + dos2unix); +$VERSION = '7.34'; +$VERSION = eval $VERSION; + +my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS_mode = $Is_VMS; +my $Is_VMS_noefs = $Is_VMS; +my $Is_Win32 = $^O eq 'MSWin32'; + +if( $Is_VMS ) { + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + if (eval { local $SIG{__DIE__}; + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_mode = 0 if $vms_unix_rpt; + $Is_VMS_noefs = 0 if ($vms_efs); +} + + + +# VMS uses % instead of ? to mean "one character" +my $wild_regex = $Is_VMS ? '*%' : '*?'; +sub expand_wildcards +{ + @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); +} + + + +sub cat () +{ + expand_wildcards(); + print while (<>); +} + + +sub eqtime +{ + my ($src,$dst) = @ARGV; + local @ARGV = ($dst); touch(); # in case $dst doesn't exist + utime((stat($src))[8,9],$dst); +} + + +sub rm_rf +{ + expand_wildcards(); + require File::Path; + File::Path::rmtree([grep -e $_,@ARGV],0,0); +} + + +sub rm_f { + expand_wildcards(); + + foreach my $file (@ARGV) { + next unless -f $file; + + next if _unlink($file); + + chmod(0777, $file); + + next if _unlink($file); + + require Carp; + Carp::carp("Cannot delete $file: $!"); + } +} + +sub _unlink { + my $files_unlinked = 0; + foreach my $file (@_) { + my $delete_count = 0; + $delete_count++ while unlink $file; + $files_unlinked++ if $delete_count; + } + return $files_unlinked; +} + + + +sub touch { + my $t = time; + expand_wildcards(); + foreach my $file (@ARGV) { + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + utime($t,$t,$file); + } +} + + +sub mv { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + if (@src > 1 && ! -d $dst) { + require Carp; + Carp::croak("Too many arguments"); + } + + require File::Copy; + my $nok = 0; + foreach my $src (@src) { + $nok ||= !File::Copy::move($src,$dst); + } + return !$nok; +} + + +sub cp { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + if (@src > 1 && ! -d $dst) { + require Carp; + Carp::croak("Too many arguments"); + } + + require File::Copy; + my $nok = 0; + foreach my $src (@src) { + $nok ||= !File::Copy::copy($src,$dst); + + # Win32 does not update the mod time of a copied file, just the + # created time which make does not look at. + utime(time, time, $dst) if $Is_Win32; + } + return $nok; +} + + +sub chmod { + local @ARGV = @ARGV; + my $mode = shift(@ARGV); + expand_wildcards(); + + if( $Is_VMS_mode && $Is_VMS_noefs) { + require File::Spec; + foreach my $idx (0..$#ARGV) { + my $path = $ARGV[$idx]; + next unless -d $path; + + # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do + # chmod 0777, [.foo]bar.dir + my @dirs = File::Spec->splitdir( $path ); + $dirs[-1] .= '.dir'; + $path = File::Spec->catfile(@dirs); + + $ARGV[$idx] = $path; + } + } + + chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; +} + + +sub mkpath +{ + expand_wildcards(); + require File::Path; + File::Path::mkpath([@ARGV],0,0777); +} + + +sub test_f +{ + exit(-f $ARGV[0] ? 0 : 1); +} + + +sub test_d +{ + exit(-d $ARGV[0] ? 0 : 1); +} + + +sub dos2unix { + require File::Find; + File::Find::find(sub { + return if -d; + return unless -w _; + return unless -r _; + return if -B _; + + local $\; + + my $orig = $_; + my $temp = '.dos2unix_tmp'; + open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; + open TEMP, ">$temp" or + do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; + binmode ORIG; binmode TEMP; + while (my $line = ) { + $line =~ s/\015\012/\012/g; + print TEMP $line; + } + close ORIG; + close TEMP; + rename $temp, $orig; + + }, @ARGV); +} + + +package ExtUtils::MM_NW5; + + +use strict; +use ExtUtils::MakeMaker::Config; +use File::Basename; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Win32; +our @ISA = qw(ExtUtils::MM_Win32); + +use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562); + +$ENV{EMXSHELL} = 'sh'; # to run `commands` + +my $BORLAND = $Config{'cc'} =~ /\bbcc/i; +my $GCC = $Config{'cc'} =~ /\bgcc/i; + + + +sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Netware'); +} + + +sub init_platform { + my($self) = shift; + + # To get Win32's setup. + $self->SUPER::init_platform; + + # incpath is copied to makefile var INCLUDE in constants sub, here just + # make it empty + my $libpth = $Config{'libpth'}; + $libpth =~ s( )(;); + $self->{'LIBPTH'} = $libpth; + + $self->{'BASE_IMPORT'} = $Config{'base_import'}; + + # Additional import file specified from Makefile.pl + if($self->{'base_import'}) { + $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'}; + } + + $self->{'NLM_VERSION'} = $Config{'nlm_version'}; + $self->{'MPKTOOL'} = $Config{'mpktool'}; + $self->{'TOOLPATH'} = $Config{'toolpath'}; + + (my $boot = $self->{'NAME'}) =~ s/:/_/g; + $self->{'BOOT_SYMBOL'}=$boot; + + # If the final binary name is greater than 8 chars, + # truncate it here. + if(length($self->{'BASEEXT'}) > 8) { + $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); + } + + # Get the include path and replace the spaces with ; + # Copy this to makefile as INCLUDE = d:\...;d:\; + ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; + + # Set the path to CodeWarrior binaries which might not have been set in + # any other place + $self->{PATH} = '$(PATH);$(TOOLPATH)'; + + $self->{MM_NW5_VERSION} = $VERSION; +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + # Setup Win32's constants. + $make_frag .= $self->SUPER::platform_constants; + + foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL + TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH + MM_NW5_VERSION + )) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + +sub static_lib_pure_cmd { + my ($self, $src) = @_; + $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; + sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src + : ($GCC ? '-ru $@ ' . $src + : '-type library -o $@ ' . $src)); +} + + +sub xs_static_lib_is_xs { + return 1; +} + + +sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my @m; + # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc + if ($to =~ /^\$/) { + if ($self->{NLM_SHORT_NAME}) { + # deal with shortnames + my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)}; + push @m, "$to: $newto\n\n"; + $to = $newto; + } + } else { + my ($v, $d, $f) = File::Spec->splitpath($to); + # relies on $f having a literal "." in it, unlike for $(OBJ_EXT) + if ($f =~ /[^\.]{9}\./) { + # 9+ chars before '.', need to shorten + $f = substr $f, 0, 8; + } + my $newto = File::Spec->catpath($v, $d, $f); + push @m, "$to: $newto\n\n"; + $to = $newto; + } + # bits below should be in dlsyms, not here + # 1 2 3 4 + push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist; +# Create xdc data for an MT safe NLM in case of mpk build +%1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists + $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s + $(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s + $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s +MAKE_FRAG + if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { + (my $xdc = $exportlist) =~ s#def\z#xdc#; + $xdc = '$(BASEEXT).xdc'; + push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist; + $(MPKTOOL) $(XDCFLAGS) %s + $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s +MAKE_FRAG + } + # Reconstruct the X.Y.Z version. + my $version = join '.', map { sprintf "%d", $_ } + $] =~ /(\d)\.(\d{3})(\d{2})/; + push @m, sprintf <<'EOF', $from, $version, $to, $exportlist; + $(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s + $(CHMOD) 755 $@ +EOF + join '', @m; +} + +1; +__END__ + +package ExtUtils::MM_Any; + +use strict; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use Carp; +use File::Spec; +use File::Basename; +BEGIN { our @ISA = qw(File::Spec); } + +# We need $Verbose +use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); + +use ExtUtils::MakeMaker::Config; + + +# So we don't have to keep calling the methods over and over again, +# we have these globals to cache the values. Faster and shrtr. +my $Curdir = __PACKAGE__->curdir; +#my $Updir = __PACKAGE__->updir; + +my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec'; +my $METASPEC_V = 2; + + +sub os_flavor_is { + my $self = shift; + my %flavors = map { ($_ => 1) } $self->os_flavor; + return (grep { $flavors{$_} } @_) ? 1 : 0; +} + + + +sub can_load_xs { + return defined &DynaLoader::boot_DynaLoader ? 1 : 0; +} + + + +sub can_run { + my ($self, $command) = @_; + + # a lot of VMS executables have a symbol defined + # check those first + if ( $^O eq 'VMS' ) { + require VMS::DCLsym; + my $syms = VMS::DCLsym->new; + return $command if scalar $syms->getsym( uc $command ); + } + + my @possibles; + + if( File::Spec->file_name_is_absolute($command) ) { + return $self->maybe_command($command); + + } else { + for my $dir ( + File::Spec->path, + File::Spec->curdir + ) { + next if ! $dir || ! -d $dir; + my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command); + push @possibles, $abs if $abs = $self->maybe_command($abs); + } + } + return @possibles if wantarray; + return shift @possibles; +} + + + +sub can_redirect_error { + my $self = shift; + $self->os_flavor_is('Unix') + or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x')) + or $self->os_flavor_is('OS/2') +} + + + +my %maketype2true; +# undocumented - so t/cd.t can still do its thing +sub _clear_maketype_cache { %maketype2true = () } + +sub is_make_type { + my($self, $type) = @_; + return $maketype2true{$type} if defined $maketype2true{$type}; + (undef, undef, my $make_basename) = $self->splitpath($self->make); + return $maketype2true{$type} = 1 + if $make_basename =~ /\b$type\b/i; # executable's filename + return $maketype2true{$type} = 0 + if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake + # now have to run with "-v" and guess + my $redirect = $self->can_redirect_error ? '2>&1' : ''; + my $make = $self->make || $self->{MAKE}; + my $minus_v = `"$make" -v $redirect`; + return $maketype2true{$type} = 1 + if $type eq 'gmake' and $minus_v =~ /GNU make/i; + return $maketype2true{$type} = 1 + if $type eq 'bsdmake' + and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im; + $maketype2true{$type} = 0; # it wasn't whatever you asked +} + + + +my $cached_dep_space; +sub can_dep_space { + my $self = shift; + return $cached_dep_space if defined $cached_dep_space; + return $cached_dep_space = 1 if $self->is_make_type('gmake'); + return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32 + return $cached_dep_space = 0 if $self->is_make_type('bsdmake'); + return $cached_dep_space = 0; # assume no +} + + + +sub quote_dep { + my ($self, $arg) = @_; + die <can_dep_space; +Tried to use make dependency with space for make that can't: + '$arg' +EOF + $arg =~ s/( )/\\$1/g; # how GNU make does it + return $arg; +} + + + +sub split_command { + my($self, $cmd, @args) = @_; + + my @cmds = (); + return(@cmds) unless @args; + + # If the command was given as a here-doc, there's probably a trailing + # newline. + chomp $cmd; + + # set aside 30% for macro expansion. + my $len_left = int($self->max_exec_len * 0.70); + $len_left -= length $self->_expand_macros($cmd); + + do { + my $arg_str = ''; + my @next_args; + while( @next_args = splice(@args, 0, 2) ) { + # Two at a time to preserve pairs. + my $next_arg_str = "\t ". join ' ', @next_args, "\n"; + + if( !length $arg_str ) { + $arg_str .= $next_arg_str + } + elsif( length($arg_str) + length($next_arg_str) > $len_left ) { + unshift @args, @next_args; + last; + } + else { + $arg_str .= $next_arg_str; + } + } + chop $arg_str; + + push @cmds, $self->escape_newlines("$cmd \n$arg_str"); + } while @args; + + return @cmds; +} + + +sub _expand_macros { + my($self, $cmd) = @_; + + $cmd =~ s{\$\((\w+)\)}{ + defined $self->{$1} ? $self->{$1} : "\$($1)" + }e; + return $cmd; +} + + + +# override if this isn't suitable! +sub make_type { return 'Unix-style'; } + + + +sub stashmeta { + my($self, $text, $file) = @_; + $self->echo($text, $file, { allow_variables => 0, append => 0 }); +} + + + +sub echo { + my($self, $text, $file, $opts) = @_; + + # Compatibility with old options + if( !ref $opts ) { + my $append = $opts; + $opts = { append => $append || 0 }; + } + $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; + + my $ql_opts = { allow_variables => $opts->{allow_variables} }; + my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) } + split /\n/, $text; + if( $file ) { + my $redirect = $opts->{append} ? '>>' : '>'; + $cmds[0] .= " $redirect $file"; + $_ .= " >> $file" foreach @cmds[1..$#cmds]; + } + + return @cmds; +} + + + +sub wraplist { + my $self = shift; + return join " \\\n\t", @_; +} + + + +sub maketext_filter { return $_[1] } + + + +sub escape_dollarsigns { + my($self, $text) = @_; + + # Escape dollar signs which are not starting a variable + $text =~ s{\$ (?!\() }{\$\$}gx; + + return $text; +} + + + +sub escape_all_dollarsigns { + my($self, $text) = @_; + + # Escape dollar signs + $text =~ s{\$}{\$\$}gx; + + return $text; +} + + + +sub make { + my $self = shift; + + my $make = lc $self->{MAKE}; + + # Truncate anything like foomake6 to just foomake. + $make =~ s/^(\w+make).*/$1/; + + # Turn gnumake into gmake. + $make =~ s/^gnu/g/; + + return $make; +} + + + +sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; +all :: pure_all + $(NOECHO) $(NOOP) +MAKE_EXT + +} + + + +sub _xs_list_basenames { + my ($self) = @_; + map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} }; +} + +sub blibdirs_target { + my $self = shift; + + my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib + autodir archautodir + bin script + man1dir man3dir + ); + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + } + } + + my @exists = map { $_.'$(DFSEP).exists' } @dirs; + + my $make = sprintf <<'MAKE', join(' ', @exists); +blibdirs : %s + $(NOECHO) $(NOOP) + +# Backwards compat with 6.18 through 6.25 +blibdirs.ts : blibdirs + $(NOECHO) $(NOOP) + +MAKE + + $make .= $self->dir_target(@dirs); + + return $make; +} + + + +sub clean { +# --- Cleanup and Distribution Sections --- + + my($self, %attribs) = @_; + my @m; + push(@m, ' +# Delete temporary files but do not touch installed files. We don\'t delete +# the Makefile here so a later make realclean still has a makefile to use. + +clean :: clean_subdirs +'); + + my @files = sort values %{$self->{XS}}; # .c files from *.xs files + push @files, map { + my $file = $_; + map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base); + } $self->_xs_list_basenames; + my @dirs = qw(blib); + + # Normally these are all under blib but they might have been + # redefined. + # XXX normally this would be a good idea, but the Perl core sets + # INST_LIB = ../../lib rather than actually installing the files. + # So a "make clean" in an ext/ directory would blow away lib. + # Until the core is adjusted let's leave this out. +# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB) +# $(INST_BIN) $(INST_SCRIPT) +# $(INST_MAN1DIR) $(INST_MAN3DIR) +# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR) +# $(INST_STATIC) $(INST_DYNAMIC) +# ); + + + if( $attribs{FILES} ) { + # Use @dirs because we don't know what's in here. + push @dirs, ref $attribs{FILES} ? + @{$attribs{FILES}} : + split /\s+/, $attribs{FILES} ; + } + + push(@files, qw[$(MAKE_APERL_FILE) + MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations + blibdirs.ts pm_to_blib pm_to_blib.ts + *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT) + $(BOOTSTRAP) $(BASEEXT).bso + $(BASEEXT).def lib$(BASEEXT).def + $(BASEEXT).exp $(BASEEXT).x + ]); + + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld')); + + # core files + if ($^O eq 'vos') { + push(@files, qw[perl*.kp]); + } + else { + push(@files, qw[core core.*perl.*.? *perl.core]); + } + + push(@files, map { "core." . "[0-9]"x$_ } (1..5)); + + # OS specific things to clean up. Use @dirs since we don't know + # what might be in here. + push @dirs, $self->extra_clean_files; + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } + + push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files); + push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs); + + # Leave Makefile.old around for realclean + push @m, <<'MAKE'; + $(NOECHO) $(RM_F) $(MAKEFILE_OLD) + - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) +MAKE + + push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; + + join("", @m); +} + + + +sub clean_subdirs_target { + my($self) = shift; + + # No subdirectories, no cleaning. + return <<'NOOP_FRAG' unless @{$self->{DIR}}; +clean_subdirs : + $(NOECHO) $(NOOP) +NOOP_FRAG + + + my $clean = "clean_subdirs :\n"; + + for my $dir (@{$self->{DIR}}) { + my $subclean = $self->oneliner(sprintf <<'CODE', $dir); +exit 0 unless chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)'; +CODE + + $clean .= "\t$subclean\n"; + } + + return $clean; +} + + + +sub dir_target { + my($self, @dirs) = @_; + + my $make = ''; + foreach my $dir (@dirs) { + $make .= sprintf <<'MAKE', ($dir) x 4; +%s$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) %s + $(NOECHO) $(CHMOD) $(PERM_DIR) %s + $(NOECHO) $(TOUCH) %s$(DFSEP).exists + +MAKE + + } + + return $make; +} + + + +# For backwards compatibility. +*dist_dir = *distdir; + +sub distdir { + my($self) = shift; + + my $meta_target = $self->{NO_META} ? '' : 'distmeta'; + my $sign_target = !$self->{SIGN} ? '' : 'distsignature'; + + return sprintf <<'MAKE_FRAG', $meta_target, $sign_target; +create_distdir : + $(RM_RF) $(DISTVNAME) + $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" + +distdir : create_distdir %s %s + $(NOECHO) $(NOOP) + +MAKE_FRAG + +} + + + +sub dist_test { + my($self) = shift; + + my $mpl_args = join " ", map qq["$_"], @ARGV; + + my $test = $self->cd('$(DISTVNAME)', + '$(ABSPERLRUN) Makefile.PL '.$mpl_args, + '$(MAKE) $(PASTHRU)', + '$(MAKE) test $(PASTHRU)' + ); + + return sprintf <<'MAKE_FRAG', $test; +disttest : distdir + %s + +MAKE_FRAG + + +} + + + +sub xs_dlsyms_arg { + return ''; +} + + +sub xs_dlsyms_ext { + die "Pure virtual method"; +} + + +sub xs_dlsyms_extra { + ''; +} + + +sub xs_dlsyms_iterator { + my ($self, $attribs) = @_; + if ($self->{XSMULTI}) { + my @m; + for my $ext ($self->_xs_list_basenames) { + my @parts = File::Spec->splitdir($ext); + shift @parts if $parts[0] eq 'lib'; + my $name = join '::', @parts; + push @m, $self->xs_make_dlsyms( + $attribs, + $ext . $self->xs_dlsyms_ext, + "$ext.xs", + $name, + $parts[-1], + {}, [], {}, [], + $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext), + ); + } + return join "\n", @m; + } else { + return $self->xs_make_dlsyms( + $attribs, + $self->{BASEEXT} . $self->xs_dlsyms_ext, + 'Makefile.PL', + $self->{NAME}, + $self->{DLBASE}, + $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {}, + $attribs->{FUNCLIST} || $self->{FUNCLIST} || [], + $attribs->{IMPORTS} || $self->{IMPORTS} || {}, + $attribs->{DL_VARS} || $self->{DL_VARS} || [], + $self->xs_dlsyms_extra, + ); + } +} + + +sub xs_make_dlsyms { + my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; + my @m = ( + "\n$target: $dep\n", + q! $(PERLRUN) -MExtUtils::Mksymlists \\ + -e "Mksymlists('NAME'=>\"!, $name, + q!\", 'DLBASE' => '!,$dlbase, + # The above two lines quoted differently to work around + # a bug in the 4DOS/4NT command line interpreter. The visible + # result of the bug was files named q('extension_name',) *with the + # single quotes and the comma* in the extension build directories. + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars) + ); + push @m, $extra if defined $extra; + push @m, qq!);"\n!; + join '', @m; +} + + +sub dynamic { +# --- Dynamic Loading Sections --- + + my($self) = shift; + ' +dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC) + $(NOECHO) $(NOOP) +'; +} + + + +sub makemakerdflt_target { + return <<'MAKE_FRAG'; +makemakerdflt : all + $(NOECHO) $(NOOP) +MAKE_FRAG + +} + + + +sub manifypods_target { + my($self) = shift; + + my $man1pods = ''; + my $man3pods = ''; + my $dependencies = ''; + + # populate manXpods & dependencies: + foreach my $name (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) { + $dependencies .= " \\\n\t$name"; + } + + my $manify = <{"MAN${section}PODS"}; + my $p2m = sprintf <<'CMD', $section, $] > 5.008 ? " -u" : ""; + $(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s +CMD + push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods); + } + + $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds; + $manify .= join '', map { "$_\n" } @man_cmds; + + return $manify; +} + +{ + my $has_cpan_meta; + sub _has_cpan_meta { + return $has_cpan_meta if defined $has_cpan_meta; + return $has_cpan_meta = !!eval { + require CPAN::Meta; + CPAN::Meta->VERSION(2.112150); + 1; + }; + } +} + + +sub metafile_target { + my $self = shift; + return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta(); +metafile : + $(NOECHO) $(NOOP) +MAKE_FRAG + + my $metadata = $self->metafile_data( + $self->{META_ADD} || {}, + $self->{META_MERGE} || {}, + ); + + my $meta = $self->_fix_metadata_before_conversion( $metadata ); + + my @write_metayml = $self->stashmeta( + $meta->as_string({version => "1.4"}), 'META_new.yml' + ); + my @write_metajson = $self->stashmeta( + $meta->as_string({version => "2.0"}), 'META_new.json' + ); + + my $metayml = join("\n\t", @write_metayml); + my $metajson = join("\n\t", @write_metajson); + return sprintf <<'MAKE_FRAG', $metayml, $metajson; +metafile : create_distdir + $(NOECHO) $(ECHO) Generating META.yml + %s + -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml + $(NOECHO) $(ECHO) Generating META.json + %s + -$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json +MAKE_FRAG + +} + + +sub _fix_metadata_before_conversion { + my ( $self, $metadata ) = @_; + + # we should never be called unless this already passed but + # prefer to be defensive in case somebody else calls this + + return unless _has_cpan_meta; + + my $bad_version = $metadata->{version} && + !CPAN::Meta::Validator->new->version( 'version', $metadata->{version} ); + # just delete all invalid versions + if( $bad_version ) { + warn "Can't parse version '$metadata->{version}'\n"; + $metadata->{version} = ''; + } + + my $validator2 = CPAN::Meta::Validator->new( $metadata ); + my @errors; + push @errors, $validator2->errors if !$validator2->is_valid; + my $validator14 = CPAN::Meta::Validator->new( + { + %$metadata, + 'meta-spec' => { version => 1.4 }, + } + ); + push @errors, $validator14->errors if !$validator14->is_valid; + # fix non-camelcase custom resource keys (only other trick we know) + for my $error ( @errors ) { + my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ ); + next if !$key; + + # first try to remove all non-alphabetic chars + ( my $new_key = $key ) =~ s/[^_a-zA-Z]//g; + + # if that doesn't work, uppercase first one + $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key ); + + # copy to new key if that worked + $metadata->{resources}{$new_key} = $metadata->{resources}{$key} + if $validator14->custom_1( $new_key ); + + # and delete old one in any case + delete $metadata->{resources}{$key}; + } + + # paper over validation issues, but still complain, necessary because + # there's no guarantee that the above will fix ALL errors + my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) }; + warn $@ if $@ and + $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/; + + # use the original metadata straight if the conversion failed + # or if it can't be stringified. + if( !$meta || + !eval { $meta->as_string( { version => $METASPEC_V } ) } || + !eval { $meta->as_string } + ) { + $meta = bless $metadata, 'CPAN::Meta'; + } + + my $now_license = $meta->as_struct({ version => 2 })->{license}; + if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and + @{$now_license} == 1 and $now_license->[0] eq 'unknown' + ) { + warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n"; + } + + $meta; +} + + + +sub _sort_pairs { + my $sort = shift; + my $pairs = shift; + return map { $_ => $pairs->{$_} } + sort $sort + keys %$pairs; +} + + +# Taken from Module::Build::Base +sub _hash_merge { + my ($self, $h, $k, $v) = @_; + if (ref $h->{$k} eq 'ARRAY') { + push @{$h->{$k}}, ref $v ? @$v : $v; + } elsif (ref $h->{$k} eq 'HASH') { + $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v; + } else { + $h->{$k} = $v; + } +} + + + +sub metafile_data { + my $self = shift; + my($meta_add, $meta_merge) = @_; + + $meta_add ||= {}; + $meta_merge ||= {}; + + my $version = _normalize_version($self->{VERSION}); + my $release_status = ($version =~ /_/) ? 'unstable' : 'stable'; + my %meta = ( + # required + abstract => $self->{ABSTRACT} || 'unknown', + author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'], + dynamic_config => 1, + generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", + license => [ $self->{LICENSE} || 'unknown' ], + 'meta-spec' => { + url => $METASPEC_URL, + version => $METASPEC_V, + }, + name => $self->{DISTNAME}, + release_status => $release_status, + version => $version, + + # optional + no_index => { directory => [qw(t inc)] }, + ); + $self->_add_requirements_to_meta(\%meta); + + if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) { + return \%meta; + } + + # needs to be based on the original version + my $v1_add = _metaspec_version($meta_add) !~ /^2/; + + my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge; + for my $frag ($meta_add, $meta_merge) { + my $def_v = $frag == $meta_add ? $merge_v : $add_v; + $frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment; + } + + # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that + # will override all prereqs, which is more than the user asked for; + # instead, we'll go inside the prereqs and override all those + while( my($key, $val) = each %$meta_add ) { + if ($v1_add and $key eq 'prereqs') { + $meta{$key}{$_} = $val->{$_} for keys %$val; + } elsif ($key ne 'meta-spec') { + $meta{$key} = $val; + } + } + + while( my($key, $val) = each %$meta_merge ) { + next if $key eq 'meta-spec'; + $self->_hash_merge(\%meta, $key, $val); + } + + return \%meta; +} + + + +sub _add_requirements_to_meta { + my ( $self, $meta ) = @_; + # Check the original args so we can tell between the user setting it + # to an empty hash and it just being initialized. + $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES} + ? $self->{CONFIGURE_REQUIRES} + : { 'ExtUtils::MakeMaker' => 0, }; + $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES} + ? $self->{BUILD_REQUIRES} + : { 'ExtUtils::MakeMaker' => 0, }; + $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES} + if $self->{ARGS}{TEST_REQUIRES}; + $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM} + if $self->{ARGS}{PREREQ_PM}; + $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) + if $self->{MIN_PERL_VERSION}; +} + +# spec version of given fragment - if not given, assume 1.4 +sub _metaspec_version { + my ( $meta ) = @_; + return $meta->{'meta-spec'}->{version} + if defined $meta->{'meta-spec'} + and defined $meta->{'meta-spec'}->{version}; + return '1.4'; +} + +sub _add_requirements_to_meta_v1_4 { + my ( $self, $meta ) = @_; + # Check the original args so we can tell between the user setting it + # to an empty hash and it just being initialized. + if( $self->{ARGS}{CONFIGURE_REQUIRES} ) { + $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES}; + } else { + $meta->{configure_requires} = { + 'ExtUtils::MakeMaker' => 0, + }; + } + if( $self->{ARGS}{BUILD_REQUIRES} ) { + $meta->{build_requires} = $self->{BUILD_REQUIRES}; + } else { + $meta->{build_requires} = { + 'ExtUtils::MakeMaker' => 0, + }; + } + if( $self->{ARGS}{TEST_REQUIRES} ) { + $meta->{build_requires} = { + %{ $meta->{build_requires} }, + %{ $self->{TEST_REQUIRES} }, + }; + } + $meta->{requires} = $self->{PREREQ_PM} + if defined $self->{PREREQ_PM}; + $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) + if $self->{MIN_PERL_VERSION}; +} + +# Adapted from Module::Build::Base +sub _normalize_version { + my ($version) = @_; + $version = 0 unless defined $version; + + if ( ref $version eq 'version' ) { # version objects + $version = $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; +} + + +sub _dump_hash { + croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH'; + my $options = shift; + my %hash = @_; + + # Use a list to preserve order. + my @pairs; + + my $k_sort + = exists $options->{key_sort} ? $options->{key_sort} + : sub { lc $a cmp lc $b }; + if ($k_sort) { + croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE'; + @pairs = _sort_pairs($k_sort, \%hash); + } else { # list of pairs, no sorting + @pairs = @_; + } + + my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : ''; + my $indent = $options->{indent} || ''; + my $k_length = min( + ($options->{max_key_length} || 20), + max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash) + ); + my $customs = $options->{customs} || {}; + + # printf format for key + my $k_format = "%-${k_length}s"; + + while( @pairs ) { + my($key, $val) = splice @pairs, 0, 2; + $val = '~' unless defined $val; + if(ref $val eq 'HASH') { + if ( keys %$val ) { + my %k_options = ( # options for recursive call + delta => $options->{delta}, + use_header => 0, + indent => $indent . $options->{delta}, + ); + if (exists $customs->{$key}) { + my %k_custom = %{$customs->{$key}}; + foreach my $k (qw(key_sort max_key_length customs)) { + $k_options{$k} = $k_custom{$k} if exists $k_custom{$k}; + } + } + $yaml .= $indent . "$key:\n" + . _dump_hash(\%k_options, %$val); + } + else { + $yaml .= $indent . "$key: {}\n"; + } + } + elsif (ref $val eq 'ARRAY') { + if( @$val ) { + $yaml .= $indent . "$key:\n"; + + for (@$val) { + croak "only nested arrays of non-refs are supported" if ref $_; + $yaml .= $indent . $options->{delta} . "- $_\n"; + } + } + else { + $yaml .= $indent . "$key: []\n"; + } + } + elsif( ref $val and !blessed($val) ) { + croak "only nested hashes, arrays and objects are supported"; + } + else { # if it's an object, just stringify it + $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val; + } + }; + + return $yaml; + +} + +sub blessed { + return eval { $_[0]->isa("UNIVERSAL"); }; +} + +sub max { + return (sort { $b <=> $a } @_)[0]; +} + +sub min { + return (sort { $a <=> $b } @_)[0]; +} + + +sub metafile_file { + my $self = shift; + + my %dump_options = ( + use_header => 1, + delta => ' ' x 4, + key_sort => undef, + ); + return _dump_hash(\%dump_options, @_); + +} + + + +sub distmeta_target { + my $self = shift; + + my @add_meta = ( + $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']), +exit unless -e q{META.yml}; +eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) } + or die "Could not add META.yml to MANIFEST: ${'@'}" +CODE + $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']) +exit unless -f q{META.json}; +eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) } + or die "Could not add META.json to MANIFEST: ${'@'}" +CODE + ); + + my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta; + + return sprintf <<'MAKE', @add_meta_to_distdir; +distmeta : create_distdir metafile + $(NOECHO) %s + $(NOECHO) %s + +MAKE + +} + + + +sub mymeta { + my $self = shift; + my $file = shift || ''; # for testing + + my $mymeta = $self->_mymeta_from_meta($file); + my $v2 = 1; + + unless ( $mymeta ) { + $mymeta = $self->metafile_data( + $self->{META_ADD} || {}, + $self->{META_MERGE} || {}, + ); + $v2 = 0; + } + + # Overwrite the non-configure dependency hashes + $self->_add_requirements_to_meta($mymeta); + + $mymeta->{dynamic_config} = 0; + + return $mymeta; +} + + +sub _mymeta_from_meta { + my $self = shift; + my $metafile = shift || ''; # for testing + + return unless _has_cpan_meta(); + + my $meta; + for my $file ( $metafile, "META.json", "META.yml" ) { + next unless -e $file; + eval { + $meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } ); + }; + last if $meta; + } + return unless $meta; + + # META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory. + # There was a good chance the author accidentally uploaded a stale META.yml if they + # rolled their own tarball rather than using "make dist". + if ($meta->{generated_by} && + $meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { + my $eummv = do { local $^W = 0; $1+0; }; + if ($eummv < 6.2501) { + return; + } + } + + return $meta; +} + + +sub write_mymeta { + my $self = shift; + my $mymeta = shift; + + return unless _has_cpan_meta(); + + my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta ); + + $meta_obj->save( 'MYMETA.json', { version => "2.0" } ); + $meta_obj->save( 'MYMETA.yml', { version => "1.4" } ); + return 1; +} + + +sub realclean { + my($self, %attribs) = @_; + + my @dirs = qw($(DISTVNAME)); + my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD)); + + # Special exception for the perl core where INST_* is not in blib. + # This cleans up the files built from the ext/ directory (all XS). + if( $self->{PERL_CORE} ) { + push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR)); + push @files, values %{$self->{PM}}; + } + + if( $self->has_link_code ){ + push @files, qw($(OBJECT)); + } + + if( $attribs{FILES} ) { + if( ref $attribs{FILES} ) { + push @dirs, @{ $attribs{FILES} }; + } + else { + push @dirs, split /\s+/, $attribs{FILES}; + } + } + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } + + my $rm_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_F)', @files); + my $rmf_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_RF)', @dirs); + + my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd; +# Delete temporary files (via clean) and also delete dist files +realclean purge :: realclean_subdirs + %s + %s +MAKE + + $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP}; + + return $m; +} + + + +sub realclean_subdirs_target { + my $self = shift; + my @m = <<'EOF'; +# so clean is forced to complete before realclean_subdirs runs +realclean_subdirs : clean +EOF + return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}}; + foreach my $dir (@{$self->{DIR}}) { + foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) { + my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile); +chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s'; +CODE + push @m, "\t- $subrclean\n"; + } + } + return join '', @m; +} + + + +sub signature_target { + my $self = shift; + + return <<'MAKE_FRAG'; +signature : + cpansign -s +MAKE_FRAG + +} + + + +sub distsignature_target { + my $self = shift; + + my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']); +eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } + or die "Could not add SIGNATURE to MANIFEST: ${'@'}" +CODE + + my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s'); + + # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not + # exist + my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE'); + my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign ); + + return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist +distsignature : distmeta + $(NOECHO) %s + $(NOECHO) %s + %s + +MAKE + +} + + + +sub special_targets { + my $make_frag = <<'MAKE_FRAG'; +.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) + +.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static + +MAKE_FRAG + + $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT}; +.NO_CONFIG_REC: Makefile + +MAKE_FRAG + + return $make_frag; +} + + + + + +sub init_ABSTRACT { + my $self = shift; + + if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) { + warn "Both ABSTRACT_FROM and ABSTRACT are set. ". + "Ignoring ABSTRACT_FROM.\n"; + return; + } + + if ($self->{ABSTRACT_FROM}){ + $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or + carp "WARNING: Setting ABSTRACT via file ". + "'$self->{ABSTRACT_FROM}' failed\n"; + } + + if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) { + warn "WARNING: ABSTRACT contains control character(s),". + " they will be removed\n"; + $self->{ABSTRACT} =~ s![[:cntrl:]]+!!g; + return; + } +} + + +sub init_INST { + my($self) = shift; + + $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch"); + $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin'); + + # INST_LIB typically pre-set if building an extension after + # perl has been built and installed. Setting INST_LIB allows + # you to build directly into, say $Config{privlibexp}. + unless ($self->{INST_LIB}){ + if ($self->{PERL_CORE}) { + $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; + } else { + $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib"); + } + } + + my @parentdir = split(/::/, $self->{PARENT_NAME}); + $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir); + $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir); + $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto', + '$(FULLEXT)'); + $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto', + '$(FULLEXT)'); + + $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script'); + + $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1'); + $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3'); + + return 1; +} + + + +sub init_INSTALL { + my($self) = shift; + + if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) { + die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n"; + } + + if( $self->{ARGS}{INSTALL_BASE} ) { + $self->init_INSTALL_from_INSTALL_BASE; + } + else { + $self->init_INSTALL_from_PREFIX; + } +} + + + +sub init_INSTALL_from_PREFIX { + my $self = shift; + + $self->init_lib2arch; + + # There are often no Config.pm defaults for these new man variables so + # we fall back to the old behavior which is to use installman*dir + foreach my $num (1, 3) { + my $k = 'installsiteman'.$num.'dir'; + + $self->{uc $k} ||= uc "\$(installman${num}dir)" + unless $Config{$k}; + } + + foreach my $num (1, 3) { + my $k = 'installvendorman'.$num.'dir'; + + unless( $Config{$k} ) { + $self->{uc $k} ||= $Config{usevendorprefix} + ? uc "\$(installman${num}dir)" + : ''; + } + } + + $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)' + unless $Config{installsitebin}; + $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)' + unless $Config{installsitescript}; + + unless( $Config{installvendorbin} ) { + $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix} + ? $Config{installbin} + : ''; + } + unless( $Config{installvendorscript} ) { + $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix} + ? $Config{installscript} + : ''; + } + + + my $iprefix = $Config{installprefixexp} || $Config{installprefix} || + $Config{prefixexp} || $Config{prefix} || ''; + my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : ''; + my $sprefix = $Config{siteprefixexp} || ''; + + # 5.005_03 doesn't have a siteprefix. + $sprefix = $iprefix unless $sprefix; + + + $self->{PREFIX} ||= ''; + + if( $self->{PREFIX} ) { + @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} = + ('$(PREFIX)') x 3; + } + else { + $self->{PERLPREFIX} ||= $iprefix; + $self->{SITEPREFIX} ||= $sprefix; + $self->{VENDORPREFIX} ||= $vprefix; + + # Lots of MM extension authors like to use $(PREFIX) so we + # put something sensible in there no matter what. + $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)'; + } + + my $arch = $Config{archname}; + my $version = $Config{version}; + + # default style + my $libstyle = $Config{installstyle} || 'lib/perl5'; + my $manstyle = ''; + + if( $self->{LIBSTYLE} ) { + $libstyle = $self->{LIBSTYLE}; + $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : ''; + } + + # Some systems, like VOS, set installman*dir to '' if they can't + # read man pages. + for my $num (1, 3) { + $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none' + unless $Config{'installman'.$num.'dir'}; + } + + my %bin_layouts = + ( + bin => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorbin => { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitebin => { s => $sprefix, + t => 'site', + d => 'bin' }, + script => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorscript=> { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitescript => { s => $sprefix, + t => 'site', + d => 'bin' }, + ); + + my %man_layouts = + ( + man1dir => { s => $iprefix, + t => 'perl', + d => 'man/man1', + style => $manstyle, }, + siteman1dir => { s => $sprefix, + t => 'site', + d => 'man/man1', + style => $manstyle, }, + vendorman1dir => { s => $vprefix, + t => 'vendor', + d => 'man/man1', + style => $manstyle, }, + + man3dir => { s => $iprefix, + t => 'perl', + d => 'man/man3', + style => $manstyle, }, + siteman3dir => { s => $sprefix, + t => 'site', + d => 'man/man3', + style => $manstyle, }, + vendorman3dir => { s => $vprefix, + t => 'vendor', + d => 'man/man3', + style => $manstyle, }, + ); + + my %lib_layouts = + ( + privlib => { s => $iprefix, + t => 'perl', + d => '', + style => $libstyle, }, + vendorlib => { s => $vprefix, + t => 'vendor', + d => '', + style => $libstyle, }, + sitelib => { s => $sprefix, + t => 'site', + d => 'site_perl', + style => $libstyle, }, + + archlib => { s => $iprefix, + t => 'perl', + d => "$version/$arch", + style => $libstyle }, + vendorarch => { s => $vprefix, + t => 'vendor', + d => "$version/$arch", + style => $libstyle }, + sitearch => { s => $sprefix, + t => 'site', + d => "site_perl/$version/$arch", + style => $libstyle }, + ); + + + # Special case for LIB. + if( $self->{LIB} ) { + foreach my $var (keys %lib_layouts) { + my $Installvar = uc "install$var"; + + if( $var =~ /arch/ ) { + $self->{$Installvar} ||= + $self->catdir($self->{LIB}, $Config{archname}); + } + else { + $self->{$Installvar} ||= $self->{LIB}; + } + } + } + + my %type2prefix = ( perl => 'PERLPREFIX', + site => 'SITEPREFIX', + vendor => 'VENDORPREFIX' + ); + + my %layouts = (%bin_layouts, %man_layouts, %lib_layouts); + while( my($var, $layout) = each(%layouts) ) { + my($s, $t, $d, $style) = @{$layout}{qw(s t d style)}; + my $r = '$('.$type2prefix{$t}.')'; + + warn "Prefixing $var\n" if $Verbose >= 2; + + my $installvar = "install$var"; + my $Installvar = uc $installvar; + next if $self->{$Installvar}; + + $d = "$style/$d" if $style; + $self->prefixify($installvar, $s, $r, $d); + + warn " $Installvar == $self->{$Installvar}\n" + if $Verbose >= 2; + } + + # Generate these if they weren't figured out. + $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH}; + $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB}; + + return 1; +} + + + +my %map = ( + lib => [qw(lib perl5)], + arch => [('lib', 'perl5', $Config{archname})], + bin => [qw(bin)], + man1dir => [qw(man man1)], + man3dir => [qw(man man3)] + ); +$map{script} = $map{bin}; + +sub init_INSTALL_from_INSTALL_BASE { + my $self = shift; + + @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} = + '$(INSTALL_BASE)'; + + my %install; + foreach my $thing (keys %map) { + foreach my $dir (('', 'SITE', 'VENDOR')) { + my $uc_thing = uc $thing; + my $key = "INSTALL".$dir.$uc_thing; + + $install{$key} ||= + $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); + } + } + + # Adjust for variable quirks. + $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH}; + $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB}; + + foreach my $key (keys %install) { + $self->{$key} ||= $install{$key}; + } + + return 1; +} + + + +sub init_VERSION { + my($self) = shift; + + $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename; + $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION; + $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision; + $self->{VERSION_FROM} ||= ''; + + if ($self->{VERSION_FROM}){ + $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}); + if( $self->{VERSION} eq 'undef' ) { + carp("WARNING: Setting VERSION via file ". + "'$self->{VERSION_FROM}' failed\n"); + } + } + + if (defined $self->{VERSION}) { + if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) { + require version; + my $normal = eval { version->new( $self->{VERSION} ) }; + $self->{VERSION} = $normal if defined $normal; + } + $self->{VERSION} =~ s/^\s+//; + $self->{VERSION} =~ s/\s+$//; + } + else { + $self->{VERSION} = ''; + } + + + $self->{VERSION_MACRO} = 'VERSION'; + ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g; + $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"'; + + + # Graham Barr and Paul Marquess had some ideas how to ensure + # version compatibility between the *.pm file and the + # corresponding *.xs file. The bottom line was, that we need an + # XS_VERSION macro that defaults to VERSION: + $self->{XS_VERSION} ||= $self->{VERSION}; + + $self->{XS_VERSION_MACRO} = 'XS_VERSION'; + $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"'; + +} + + + +sub init_tools { + my $self = shift; + + $self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']); + $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}'); + + $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]); + $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]); + $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]); + $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]); + $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]); + $self->{TEST_S} ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]); + $self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]); + $self->{FALSE} ||= $self->oneliner('exit 1'); + $self->{TRUE} ||= $self->oneliner('exit 0'); + + $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]); + + $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]); + $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]); + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); +install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); +CODE + $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]); + $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]); + $self->{WARN_IF_OLD_PACKLIST} ||= + $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]); + $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]); + $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]); + + $self->{UNINST} ||= 0; + $self->{VERBINST} ||= 0; + + $self->{SHELL} ||= $Config{sh}; + + # UMASK_NULL is not used by MakeMaker but some CPAN modules + # make use of it. + $self->{UMASK_NULL} ||= "umask 0"; + + # Not the greatest default, but its something. + $self->{DEV_NULL} ||= "> /dev/null 2>&1"; + + $self->{NOOP} ||= '$(TRUE)'; + $self->{NOECHO} = '@' unless defined $self->{NOECHO}; + + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile'; + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; + $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old'; + $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl'; + + # Not everybody uses -f to indicate "use this Makefile instead" + $self->{USEMAKEFILE} ||= '-f'; + + # Some makes require a wrapper around macros passed in on the command + # line. + $self->{MACROSTART} ||= ''; + $self->{MACROEND} ||= ''; + + return; +} + + + +sub init_others { + my $self = shift; + + $self->{LD_RUN_PATH} = ""; + + $self->{LIBS} = $self->_fix_libs($self->{LIBS}); + + # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS} + foreach my $libs ( @{$self->{LIBS}} ){ + $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace + my(@libs) = $self->extliblist($libs); + if ($libs[0] or $libs[1] or $libs[2]){ + # LD_RUN_PATH now computed by ExtUtils::Liblist + ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, + $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; + last; + } + } + + if ( $self->{OBJECT} ) { + $self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT}; + $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; + } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) { + $self->{OBJECT} = join(" ", @{$self->{O_FILES}}); + $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; + } else { + # init_dirscan should have found out, if we have C files + $self->{OBJECT} = ""; + $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; + } + $self->{OBJECT} =~ s/\n+/ \\\n\t/g; + + $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; + $self->{PERLMAINCC} ||= '$(CC)'; + $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; + + # Sanity check: don't define LINKTYPE = dynamic if we're skipping + # the 'dynamic' section of MM. We don't have this problem with + # 'static', since we either must use it (%Config says we can't + # use dynamic loading) or the caller asked for it explicitly. + if (!$self->{LINKTYPE}) { + $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'} + ? 'static' + : ($Config{usedl} ? 'dynamic' : 'static'); + } + + return; +} + + +# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or +# undefined. In any case we turn it into an anon array +sub _fix_libs { + my($self, $libs) = @_; + + return !defined $libs ? [''] : + !ref $libs ? [$libs] : + !defined $libs->[0] ? [''] : + $libs ; +} + + + +sub tools_other { + my($self) = shift; + my @m; + + # We set PM_FILTER as late as possible so it can see all the earlier + # on macro-order sensitive makes such as nmake. + for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH + UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP + FALSE TRUE + ECHO ECHO_N + UNINST VERBINST + MOD_INSTALL DOC_INSTALL UNINSTALL + WARN_IF_OLD_PACKLIST + MACROSTART MACROEND + USEMAKEFILE + PM_FILTER + FIXIN + CP_NONEMPTY + } ) + { + next unless defined $self->{$tool}; + push @m, "$tool = $self->{$tool}\n"; + } + + return join "", @m; +} + + + +sub init_platform { + return ''; +} + + + +sub init_MAKE { + my $self = shift; + + $self->{MAKE} ||= $ENV{MAKE} || $Config{make}; +} + + + +sub manifypods { + my $self = shift; + + my $POD2MAN_macro = $self->POD2MAN_macro(); + my $manifypods_target = $self->manifypods_target(); + + return <oneliner(sprintf <<'PERL_CODE', $maxlen); +use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) +PERL_CODE + + return sprintf <<'MAKE_FRAG', $asplit; +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = %s + +MAKE_FRAG + +} + + + +sub arch_check { + my $self = shift; + my($pconfig, $cconfig) = @_; + + return 1 if $self->{PERL_SRC}; + + my($pvol, $pthinks) = $self->splitpath($pconfig); + my($cvol, $cthinks) = $self->splitpath($cconfig); + + $pthinks = $self->canonpath($pthinks); + $cthinks = $self->canonpath($cthinks); + + my $ret = 1; + if ($pthinks ne $cthinks) { + print "Have $pthinks\n"; + print "Want $cthinks\n"; + + $ret = 0; + + my $arch = (grep length, $self->splitdir($pthinks))[-1]; + + print <{UNINSTALLED_PERL}; +Your perl and your Config.pm seem to have different ideas about the +architecture they are running on. +Perl thinks: [$arch] +Config says: [$Config{archname}] +This may or may not cause problems. Please check your installation of perl +if you have problems building this extension. +END + } + + return $ret; +} + + + + +sub catfile { + my $self = shift; + return $self->canonpath($self->SUPER::catfile(@_)); +} + + + + +sub find_tests { + my($self) = shift; + return -d 't' ? 't/*.t' : ''; +} + + +sub find_tests_recursive { + my $self = shift; + return $self->find_tests_recursive_in('t'); +} + + +sub find_tests_recursive_in { + my($self, $dir) = @_; + return '' unless -d $dir; + + require File::Find; + + my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] ); + my %depths; + + my $wanted = sub { + return unless m!\.t$!; + my ($volume,$directories,$file) = + File::Spec->splitpath( $File::Find::name ); + my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories ); + $depth -= $base_depth; + $depths{ $depth } = 1; + }; + + File::Find::find( $wanted, $dir ); + + return join ' ', + map { $dir . '/*' x $_ . '.t' } + sort { $a <=> $b } + keys %depths; +} + + +# An empty method here tickled a perl 5.8.1 bug and would return its object. +sub extra_clean_files { + return; +} + + + +sub installvars { + return qw(PRIVLIB SITELIB VENDORLIB + ARCHLIB SITEARCH VENDORARCH + BIN SITEBIN VENDORBIN + SCRIPT SITESCRIPT VENDORSCRIPT + MAN1DIR SITEMAN1DIR VENDORMAN1DIR + MAN3DIR SITEMAN3DIR VENDORMAN3DIR + ); +} + + + +sub libscan { + my($self,$path) = @_; + + if ($path =~ m<^README\.pod$>i) { + warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n" + unless $ENV{PERL_CORE}; + return ''; + } + + my($dirs,$file) = ($self->splitpath($path))[1,2]; + return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/, + $self->splitdir($dirs), $file; + + return $path; +} + + + +sub platform_constants { + return ''; +} + + +sub post_constants { + ""; +} + + +sub post_initialize { + ""; +} + + +sub postamble { + ""; +} + + +sub _PREREQ_PRINT { + my $self = shift; + + require Data::Dumper; + my @what = ('PREREQ_PM'); + push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION}; + push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES}; + print Data::Dumper->Dump([@{$self}{@what}], \@what); + exit 0; +} + + + +sub _PRINT_PREREQ { + my $self = shift; + + my $prereqs= $self->{PREREQ_PM}; + my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs; + + if ( $self->{MIN_PERL_VERSION} ) { + push @prereq, ['perl' => $self->{MIN_PERL_VERSION}]; + } + + print join(" ", map { "perl($_->[0])>=$_->[1] " } + sort { $a->[0] cmp $b->[0] } @prereq), "\n"; + exit 0; +} + + + +sub _perl_header_files { + my $self = shift; + + my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE'); + opendir my $dh, $header_dir + or die "Failed to opendir '$header_dir' to find header files: $!"; + + # we need to use a temporary here as the sort in scalar context would have undefined results. + my @perl_headers= sort grep { /\.h\z/ } readdir($dh); + + closedir $dh; + + return @perl_headers; +} + + +sub _perl_header_files_fragment { + my ($self, $separator)= @_; + $separator ||= ""; + return join("\\\n", + "PERL_HDRS = ", + map { + sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ ) + } $self->_perl_header_files() + ) . "\n\n" + . "\$(OBJECT) : \$(PERL_HDRS)\n"; +} + + + +1; +package ExtUtils::MM_QNX; + +use strict; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + + +sub extra_clean_files { + my $self = shift; + + my @errfiles = @{$self->{C}}; + for ( @errfiles ) { + s/.c$/.err/; + } + + return( @errfiles, 'perlmain.err' ); +} + + + + +1; +package ExtUtils::MM_VOS; + +use strict; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Unix; +our @ISA = qw(ExtUtils::MM_Unix); + + + +sub extra_clean_files { + return qw(*.kp); +} + + + + +1; +package ExtUtils::MM_Darwin; + +use strict; + +BEGIN { + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Unix ); +} + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + + + +sub init_dist { + my $self = shift; + + # Thank you, Apple, for breaking tar and then breaking the work around. + # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants + # COPYFILE_DISABLE. I'm not going to push my luck and instead just + # set both. + $self->{TAR} ||= + 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar'; + + $self->SUPER::init_dist(@_); +} + +1; +# $Id$ +package ExtUtils::MakeMaker; + +use strict; + +BEGIN {require 5.006;} + +require Exporter; +use ExtUtils::MakeMaker::Config; +use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm +use Carp; +use File::Path; +my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone +eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') } + if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii'; + +our $Verbose = 0; # exported +our @Parent; # needs to be localized +our @Get_from_Config; # referenced by MM_Unix +our @MM_Sections; +our @Overridable; +my @Prepend_parent; +my %Recognized_Att_Keys; +our %macro_fsentity; # whether a macro is a filesystem name +our %macro_dep; # whether a macro is a dependency + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] + +# Emulate something resembling CVS $Revision$ +(our $Revision = $VERSION) =~ s{_}{}; +$Revision = int $Revision * 10000; + +our $Filename = __FILE__; # referenced outside MakeMaker + +our @ISA = qw(Exporter); +our @EXPORT = qw(&WriteMakefile $Verbose &prompt &os_unsupported); +our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists + &WriteEmptyMakefile &open_for_writing &write_file_via_tmp + &_sprintf562); + +# These will go away once the last of the Win32 & VMS specific code is +# purged. +my $Is_VMS = $^O eq 'VMS'; +my $Is_Win32 = $^O eq 'MSWin32'; +our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our + +full_setup(); + +require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker + # will give them MM. + +require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect + # loading ExtUtils::MakeMaker will give them MY. + # This will go when Embed is its own CPAN module. + + +# 5.6.2 can't do sprintf "%1$s" - this can only do %s +sub _sprintf562 { + my ($format, @args) = @_; + for (my $i = 1; $i <= @args; $i++) { + $format =~ s#%$i\$s#$args[$i-1]#g; + } + $format; +} + +sub WriteMakefile { + croak "WriteMakefile: Need even number of args" if @_ % 2; + + require ExtUtils::MY; + my %att = @_; + + _convert_compat_attrs(\%att); + + _verify_att(\%att); + + my $mm = MM->new(\%att); + $mm->flush; + + return $mm; +} + + +# Basic signatures of the attributes WriteMakefile takes. Each is the +# reference type. Empty value indicate it takes a non-reference +# scalar. +my %Att_Sigs; +my %Special_Sigs = ( + AUTHOR => 'ARRAY', + C => 'ARRAY', + CONFIG => 'ARRAY', + CONFIGURE => 'CODE', + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => ['ARRAY',''], + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + OBJECT => ['ARRAY', ''], + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + BUILD_REQUIRES => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + TEST_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', + XSBUILD => 'HASH', + VERSION => ['version',''], + _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', +); + +@Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys; +@Att_Sigs{keys %Special_Sigs} = values %Special_Sigs; + +sub _convert_compat_attrs { #result of running several times should be same + my($att) = @_; + if (exists $att->{AUTHOR}) { + if ($att->{AUTHOR}) { + if (!ref($att->{AUTHOR})) { + my $t = $att->{AUTHOR}; + $att->{AUTHOR} = [$t]; + } + } else { + $att->{AUTHOR} = []; + } + } +} + +sub _verify_att { + my($att) = @_; + + foreach my $key (sort keys %$att) { + my $val = $att->{$key}; + my $sig = $Att_Sigs{$key}; + unless( defined $sig ) { + warn "WARNING: $key is not a known parameter.\n"; + next; + } + + my @sigs = ref $sig ? @$sig : $sig; + my $given = ref $val; + unless( grep { _is_of_type($val, $_) } @sigs ) { + my $takes = join " or ", map { _format_att($_) } @sigs; + + my $has = _format_att($given); + warn "WARNING: $key takes a $takes not a $has.\n". + " Please inform the author.\n"; + } + } +} + + +# Check if a given thing is a reference or instance of $type +sub _is_of_type { + my($thing, $type) = @_; + + return 1 if ref $thing eq $type; + + local $SIG{__DIE__}; + return 1 if eval{ $thing->isa($type) }; + + return 0; +} + + +sub _format_att { + my $given = shift; + + return $given eq '' ? "string/number" + : uc $given eq $given ? "$given reference" + : "$given object" + ; +} + + +sub prompt ($;$) { ## no critic + my($mess, $def) = @_; + confess("prompt function called without an argument") + unless defined $mess; + + my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; + + my $dispdef = defined $def ? "[$def] " : " "; + $def = defined $def ? $def : ""; + + local $|=1; + local $\; + print "$mess $dispdef"; + + my $ans; + if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) { + print "$def\n"; + } + else { + $ans = ; + if( defined $ans ) { + $ans =~ s{\015?\012$}{}; + } + else { # user hit ctrl-D + print "\n"; + } + } + + return (!defined $ans || $ans eq '') ? $def : $ans; +} + +sub os_unsupported { + die "OS unsupported\n"; +} + +sub eval_in_subdirs { + my($self) = @_; + use Cwd qw(cwd abs_path); + my $pwd = cwd() || die "Can't figure out your cwd!"; + + local @INC = map eval {abs_path($_) if -e} || $_, @INC; + push @INC, '.'; # '.' has to always be at the end of @INC + + foreach my $dir (@{$self->{DIR}}){ + my($abs) = $self->catdir($pwd,$dir); + eval { $self->eval_in_x($abs); }; + last if $@; + } + chdir $pwd; + die $@ if $@; +} + +sub eval_in_x { + my($self,$dir) = @_; + chdir $dir or carp("Couldn't change to directory $dir: $!"); + + { + package main; + do './Makefile.PL'; + }; + if ($@) { +# if ($@ =~ /prerequisites/) { +# die "MakeMaker WARNING: $@"; +# } else { +# warn "WARNING from evaluation of $dir/Makefile.PL: $@"; +# } + die "ERROR from evaluation of $dir/Makefile.PL: $@"; + } +} + + +# package name for the classes into which the first object will be blessed +my $PACKNAME = 'PACK000'; + +sub full_setup { + $Verbose ||= 0; + + my @dep_macros = qw/ + PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP + /; + + my @fs_macros = qw/ + FULLPERL XSUBPPDIR + + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR + INSTALLDIRS + DESTDIR PREFIX INSTALL_BASE + PERLPREFIX SITEPREFIX VENDORPREFIX + INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB + INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH + INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN + INSTALLMAN1DIR INSTALLMAN3DIR + INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR + INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR + INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT + PERL_LIB PERL_ARCHLIB + SITELIBEXP SITEARCHEXP + + MAKE LIBPERL_A LIB PERL_SRC PERL_INC + PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC + PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT + /; + + my @attrib_help = qw/ + + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME + DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE + FULLPERLRUN FULLPERLRUNINST + FUNCLIST H IMPORTS + + INC INCLUDE_EXT LDFROM LIBS LICENSE + LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET + META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES + MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL + NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN + PERLRUNINST PERL_CORE + PERM_DIR PERM_RW PERM_RWX MAGICXS + PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE + PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ + SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS + XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION + clean depend dist dynamic_lib linkext macro realclean tool_autosplit + + MAN1EXT MAN3EXT + + MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC + MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED + /; + push @attrib_help, @fs_macros; + @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros); + @macro_dep{@dep_macros} = (1) x @dep_macros; + + # IMPORTS is used under OS/2 and Win32 + + # @Overridable is close to @MM_Sections but not identical. The + # order is important. Many subroutines declare macros. These + # depend on each other. Let's try to collect the macros up front, + # then pasthru, then the rules. + + # MM_Sections are the sections we have to call explicitly + # in Overridable we have subroutines that are used indirectly + + + @MM_Sections = + qw( + + post_initialize const_config constants platform_constants + tool_autosplit tool_xsubpp tools_other + + makemakerdflt + + dist macro depend cflags const_loadlibs const_cccmd + post_constants + + pasthru + + special_targets + c_o xs_c xs_o + top_targets blibdirs linkext dlsyms dynamic_bs dynamic + dynamic_lib static static_lib manifypods processPL + installbin subdirs + clean_subdirs clean realclean_subdirs realclean + metafile signature + dist_basics dist_core distdir dist_test dist_ci distmeta distsignature + install force perldepend makefile staticmake test ppd + + ); # loses section ordering + + @Overridable = @MM_Sections; + push @Overridable, qw[ + + libscan makeaperl needs_linking + subdir_x test_via_harness test_via_script + + init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan + init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker + ]; + + push @MM_Sections, qw[ + + pm_to_blib selfdocument + + ]; + + # Postamble needs to be the last that was always the case + push @MM_Sections, "postamble"; + push @Overridable, "postamble"; + + # All sections are valid keys. + @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections; + + # we will use all these variables in the Makefile + @Get_from_Config = + qw( + ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld + lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib + sitelibexp sitearchexp so + ); + + # 5.5.3 doesn't have any concept of vendor libs + push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006; + + foreach my $item (@attrib_help){ + $Recognized_Att_Keys{$item} = 1; + } + foreach my $item (@Get_from_Config) { + $Recognized_Att_Keys{uc $item} = $Config{$item}; + print "Attribute '\U$item\E' => '$Config{$item}'\n" + if ($Verbose >= 2); + } + + # + # When we eval a Makefile.PL in a subdirectory, that one will ask + # us (the parent) for the values and will prepend "..", so that + # all files to be installed end up below OUR ./blib + # + @Prepend_parent = qw( + INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT + MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC + PERL FULLPERL + ); +} + +sub _has_cpan_meta_requirements { + return eval { + require CPAN::Meta::Requirements; + CPAN::Meta::Requirements->VERSION(2.130); + require B; # CMR requires this, for core we have to too. + }; +} + +sub new { + my($class,$self) = @_; + my($key); + + _convert_compat_attrs($self) if defined $self && $self; + + # Store the original args passed to WriteMakefile() + foreach my $k (keys %$self) { + $self->{ARGS}{$k} = $self->{$k}; + } + + $self = {} unless defined $self; + + # Temporarily bless it into MM so it can be used as an + # object. It will be blessed into a temp package later. + bless $self, "MM"; + + # Cleanup all the module requirement bits + my %key2cmr; + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + $self->{$key} ||= {}; + if (_has_cpan_meta_requirements) { + my $cmr = CPAN::Meta::Requirements->from_string_hash( + $self->{$key}, + { + bad_version_hook => sub { + #no warnings 'numeric'; # module doesn't use warnings + my $fallback; + if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { + $fallback = sprintf "%f", $_[0]; + } else { + ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0; + $fallback += 0; + carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback"; + } + version->new($fallback); + }, + }, + ); + $self->{$key} = $cmr->as_string_hash; + $key2cmr{$key} = $cmr; + } else { + for my $module (sort keys %{ $self->{$key} }) { + my $version = $self->{$key}->{$module}; + my $fallback = 0; + if (!defined($version) or !length($version)) { + carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)"; + } + elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) { + next; + } + else { + if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { + $fallback = sprintf "%f", $version; + } else { + ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0; + $fallback += 0; + carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)"; + } + } + $self->{$key}->{$module} = $fallback; + } + } + } + + if ("@ARGV" =~ /\bPREREQ_PRINT\b/) { + $self->_PREREQ_PRINT; + } + + # PRINT_PREREQ is RedHatism. + if ("@ARGV" =~ /\bPRINT_PREREQ\b/) { + $self->_PRINT_PREREQ; + } + + print "MakeMaker (v$VERSION)\n" if $Verbose; + if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){ + check_manifest(); + } + + check_hints($self); + + if ( defined $self->{MIN_PERL_VERSION} + && $self->{MIN_PERL_VERSION} !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { + local $SIG{__WARN__} = sub { + # simulate "use warnings FATAL => 'all'" for vintage perls + die @_; + }; + version->new( $self->{MIN_PERL_VERSION} ) + }; + $self->{MIN_PERL_VERSION} = $normal if defined $normal && !$@; + } + + # Translate X.Y.Z to X.00Y00Z + if( defined $self->{MIN_PERL_VERSION} ) { + $self->{MIN_PERL_VERSION} =~ s{ ^v? (\d+) \. (\d+) \. (\d+) $ } + {sprintf "%d.%03d%03d", $1, $2, $3}ex; + } + + my $perl_version_ok = eval { + local $SIG{__WARN__} = sub { + # simulate "use warnings FATAL => 'all'" for vintage perls + die @_; + }; + !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $] + }; + if (!$perl_version_ok) { + if (!defined $perl_version_ok) { + die <<'END'; +Warning: MIN_PERL_VERSION is not in a recognized format. +Recommended is a quoted numerical value like '5.005' or '5.008001'. +END + } + elsif ($self->{PREREQ_FATAL}) { + die sprintf <<"END", $self->{MIN_PERL_VERSION}, $]; +MakeMaker FATAL: perl version too low for this distribution. +Required is %s. We run %s. +END + } + else { + warn sprintf + "Warning: Perl version %s or higher required. We run %s.\n", + $self->{MIN_PERL_VERSION}, $]; + } + } + + my %configure_att; # record &{$self->{CONFIGURE}} attributes + my(%initial_att) = %$self; # record initial attributes + + my(%unsatisfied) = (); + my %prereq2version; + my $cmr; + if (_has_cpan_meta_requirements) { + $cmr = CPAN::Meta::Requirements->new; + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key}; + } + foreach my $prereq ($cmr->required_modules) { + $prereq2version{$prereq} = $cmr->requirements_for_module($prereq); + } + } else { + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + next unless my $module2version = $self->{$key}; + $prereq2version{$_} = $module2version->{$_} for keys %$module2version; + } + } + foreach my $prereq (sort keys %prereq2version) { + my $required_version = $prereq2version{$prereq}; + + my $pr_version = 0; + my $installed_file; + + if ( $prereq eq 'perl' ) { + if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/ + || $required_version !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { version->new( $required_version ) }; + $required_version = $normal if defined $normal; + } + $installed_file = $prereq; + $pr_version = $]; + } + else { + $installed_file = MM->_installed_file_for_module($prereq); + $pr_version = MM->parse_version($installed_file) if $installed_file; + $pr_version = 0 if $pr_version eq 'undef'; + if ( !eval { version->new( $pr_version ); 1 } ) { + #no warnings 'numeric'; # module doesn't use warnings + my $fallback; + if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { + $fallback = sprintf '%f', $pr_version; + } else { + ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0; + $fallback += 0; + carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback"; + } + $pr_version = $fallback; + } + } + + # convert X.Y_Z alpha version #s to X.YZ for easier comparisons + $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/; + + if (!$installed_file) { + warn sprintf "Warning: prerequisite %s %s not found.\n", + $prereq, $required_version + unless $self->{PREREQ_FATAL} + or $UNDER_CORE; + + $unsatisfied{$prereq} = 'not installed'; + } + elsif ( + $cmr + ? !$cmr->accepts_module($prereq, $pr_version) + : $required_version > $pr_version + ) { + warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n", + $prereq, $required_version, ($pr_version || 'unknown version') + unless $self->{PREREQ_FATAL} + or $UNDER_CORE; + + $unsatisfied{$prereq} = $required_version || 'unknown version' ; + } + } + + if (%unsatisfied && $self->{PREREQ_FATAL}){ + my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} + sort { $a cmp $b } keys %unsatisfied; + die <<"END"; +MakeMaker FATAL: prerequisites not found. +$failedprereqs + +Please install these modules first and rerun 'perl Makefile.PL'. +END + } + + if (defined $self->{CONFIGURE}) { + if (ref $self->{CONFIGURE} eq 'CODE') { + %configure_att = %{&{$self->{CONFIGURE}}}; + _convert_compat_attrs(\%configure_att); + $self = { %$self, %configure_att }; + } else { + croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n"; + } + } + + my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits + { + print "Blessing Object into class [$newclass]\n" if $Verbose>=2; + mv_all_methods("MY",$newclass); + bless $self, $newclass; + push @Parent, $self; + require ExtUtils::MY; + + no strict 'refs'; ## no critic; + @{"$newclass\:\:ISA"} = 'MM'; + } + + if (defined $Parent[-2]){ + $self->{PARENT} = $Parent[-2]; + for my $key (@Prepend_parent) { + next unless defined $self->{PARENT}{$key}; + + # Don't stomp on WriteMakefile() args. + next if defined $self->{ARGS}{$key} and + $self->{ARGS}{$key} eq $self->{$key}; + + $self->{$key} = $self->{PARENT}{$key}; + + if ($Is_VMS && $key =~ /PERL$/) { + # PERL or FULLPERL will be a command verb or even a + # command with an argument instead of a full file + # specification under VMS. So, don't turn the command + # into a filespec, but do add a level to the path of + # the argument if not already absolute. + my @cmd = split /\s+/, $self->{$key}; + $cmd[1] = $self->catfile('[-]',$cmd[1]) + unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]); + $self->{$key} = join(' ', @cmd); + } else { + my $value = $self->{$key}; + # not going to test in FS so only stripping start + $value =~ s/^"// if $key =~ /PERL$/; + $value = $self->catdir("..", $value) + unless $self->file_name_is_absolute($value); + $value = qq{"$value} if $key =~ /PERL$/; + $self->{$key} = $value; + } + } + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)) { + if (exists $self->{PARENT}->{$opt} + and not exists $self->{$opt}) + { + # inherit, but only if already unspecified + $self->{$opt} = $self->{PARENT}->{$opt}; + } + } + } + my @fm = grep /^FIRST_MAKEFILE=/, @ARGV; + parse_args($self,@fm) if @fm; + } + else { + parse_args($self, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV); + } + + # RT#91540 PREREQ_FATAL not recognized on command line + if (%unsatisfied && $self->{PREREQ_FATAL}){ + my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} + sort { $a cmp $b } keys %unsatisfied; + die <<"END"; +MakeMaker FATAL: prerequisites not found. +$failedprereqs + +Please install these modules first and rerun 'perl Makefile.PL'. +END + } + + $self->{NAME} ||= $self->guess_name; + + warn "Warning: NAME must be a package name\n" + unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!; + + ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g; + + $self->init_MAKE; + $self->init_main; + $self->init_VERSION; + $self->init_dist; + $self->init_INST; + $self->init_INSTALL; + $self->init_DEST; + $self->init_dirscan; + $self->init_PM; + $self->init_MANPODS; + $self->init_xs; + $self->init_PERL; + $self->init_DIRFILESEP; + $self->init_linker; + $self->init_ABSTRACT; + + $self->arch_check( + $INC{'Config.pm'}, + $self->catfile($Config{'archlibexp'}, "Config.pm") + ); + + $self->init_tools(); + $self->init_others(); + $self->init_platform(); + $self->init_PERM(); + my @args = @ARGV; + @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; + my($argv) = neatvalue(\@args); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; + + push @{$self->{RESULT}}, <{NAME} extension to perl. +# +# It was generated automatically by MakeMaker version +# $VERSION (Revision: $Revision) from the contents of +# Makefile.PL. Don't edit this file, edit Makefile.PL instead. +# +# ANY CHANGES MADE HERE WILL BE LOST! +# +# MakeMaker ARGV: $argv +# +END + + push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att); + + if (defined $self->{CONFIGURE}) { + push @{$self->{RESULT}}, < 0) { + foreach my $key (sort keys %configure_att){ + next if $key eq 'ARGS'; + my($v) = neatvalue($configure_att{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @{$self->{RESULT}}, "# $key => $v"; + } + } + else + { + push @{$self->{RESULT}}, "# no values returned"; + } + undef %configure_att; # free memory + } + + # turn the SKIP array into a SKIPHASH hash + for my $skip (@{$self->{SKIP} || []}) { + $self->{SKIPHASH}{$skip} = 1; + } + delete $self->{SKIP}; # free memory + + if ($self->{PARENT}) { + for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) { + $self->{SKIPHASH}{$_} = 1; + } + } + + # We run all the subdirectories now. They don't have much to query + # from the parent, but the parent has to query them: if they need linking! + unless ($self->{NORECURS}) { + $self->eval_in_subdirs if @{$self->{DIR}}; + } + + foreach my $section ( @MM_Sections ){ + # Support for new foo_target() methods. + my $method = $section; + $method .= '_target' unless $self->can($method); + + print "Processing Makefile '$section' section\n" if ($Verbose >= 2); + my($skipit) = $self->skipcheck($section); + if ($skipit){ + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit."; + } else { + my(%a) = %{$self->{$section} || {}}; + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; + push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; + push @{$self->{RESULT}}, $self->maketext_filter( + $self->$method( %a ) + ); + } + } + + push @{$self->{RESULT}}, "\n# End."; + + $self; +} + +sub WriteEmptyMakefile { + croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; + + my %att = @_; + $att{DIR} = [] unless $att{DIR}; # don't recurse by default + my $self = MM->new(\%att); + + my $new = $self->{MAKEFILE}; + my $old = $self->{MAKEFILE_OLD}; + if (-f $old) { + _unlink($old) or warn "unlink $old: $!"; + } + if ( -f $new ) { + _rename($new, $old) or warn "rename $new => $old: $!" + } + open my $mfh, '>', $new or die "open $new for write: $!"; + print $mfh <<'EOP'; +all : + +manifypods : + +subdirs : + +dynamic : + +static : + +clean : + +install : + +makemakerdflt : + +test : + +test_dynamic : + +test_static : + +EOP + close $mfh or die "close $new for write: $!"; +} + + + +sub _installed_file_for_module { + my $class = shift; + my $prereq = shift; + + my $file = "$prereq.pm"; + $file =~ s{::}{/}g; + + my $path; + for my $dir (@INC) { + my $tmp = File::Spec->catfile($dir, $file); + if ( -r $tmp ) { + $path = $tmp; + last; + } + } + + return $path; +} + + +# Extracted from MakeMaker->new so we can test it +sub _MakeMaker_Parameters_section { + my $self = shift; + my $att = shift; + + my @result = <<'END'; +# MakeMaker Parameters: +END + + foreach my $key (sort keys %$att){ + next if $key eq 'ARGS'; + my $v; + if ($key eq 'PREREQ_PM') { + # CPAN.pm takes prereqs from this field in 'Makefile' + # and does not know about BUILD_REQUIRES + $v = neatvalue({ + %{ $att->{PREREQ_PM} || {} }, + %{ $att->{BUILD_REQUIRES} || {} }, + %{ $att->{TEST_REQUIRES} || {} }, + }); + } else { + $v = neatvalue($att->{$key}); + } + + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @result, "# $key => $v"; + } + + return @result; +} + +# _shellwords and _parseline borrowed from Text::ParseWords +sub _shellwords { + my (@lines) = @_; + my @allwords; + + foreach my $line (@lines) { + $line =~ s/^\s+//; + my @words = _parse_line('\s+', 0, $line); + pop @words if (@words and !defined $words[-1]); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} + +sub _parse_line { + my($delimiter, $keep, $line) = @_; + my($word, @pieces); + + no warnings 'uninitialized'; # we will be testing undef strings + + while (length($line)) { + # This pattern is optimised to be stack conservative on older perls. + # Do not refactor without being careful and testing it on very long strings. + # See Perl bug #42980 for an example of a stack busting input. + $line =~ s/^ + (?: + # double quoted string + (") # $quote + ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted + | # --OR-- + # singe quoted string + (') # $quote + ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted + | # --OR-- + # unquoted string + ( # $unquoted + (?:\\.|[^\\"'])*? + ) + # followed by + ( # $delim + \Z(?!\n) # EOL + | # --OR-- + (?-x:$delimiter) # delimiter + | # --OR-- + (?!^)(?=["']) # a quote + ) + )//xs or return; # extended layout + my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6); + + + return() unless( defined($quote) || length($unquoted) || length($delim)); + + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/sg; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); + #$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= substr($line, 0, 0); # leave results tainted + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } + } + return(@pieces); +} + +sub check_manifest { + print "Checking if your kit is complete...\n"; + require ExtUtils::Manifest; + # avoid warning + $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1; + my(@missed) = ExtUtils::Manifest::manicheck(); + if (@missed) { + print "Warning: the following files are missing in your kit:\n"; + print "\t", join "\n\t", @missed; + print "\n"; + print "Please inform the author.\n"; + } else { + print "Looks good\n"; + } +} + +sub parse_args{ + my($self, @args) = @_; + @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; + foreach (@args) { + unless (m/(.*?)=(.*)/) { + ++$Verbose if m/^verb/; + next; + } + my($name, $value) = ($1, $2); + if ($value =~ m/^~(\w+)?/) { # tilde with optional username + $value =~ s [^~(\w*)] + [$1 ? + ((getpwnam($1))[7] || "~$1") : + (getpwuid($>))[7] + ]ex; + } + + # Remember the original args passed it. It will be useful later. + $self->{ARGS}{uc $name} = $self->{uc $name} = $value; + } + + # catch old-style 'potential_libs' and inform user how to 'upgrade' + if (defined $self->{potential_libs}){ + my($msg)="'potential_libs' => '$self->{potential_libs}' should be"; + if ($self->{potential_libs}){ + print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; + } else { + print "$msg deleted.\n"; + } + $self->{LIBS} = [$self->{potential_libs}]; + delete $self->{potential_libs}; + } + # catch old-style 'ARMAYBE' and inform user how to 'upgrade' + if (defined $self->{ARMAYBE}){ + my($armaybe) = $self->{ARMAYBE}; + print "ARMAYBE => '$armaybe' should be changed to:\n", + "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n"; + my(%dl) = %{$self->{dynamic_lib} || {}}; + $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe}; + delete $self->{ARMAYBE}; + } + if (defined $self->{LDTARGET}){ + print "LDTARGET should be changed to LDFROM\n"; + $self->{LDFROM} = $self->{LDTARGET}; + delete $self->{LDTARGET}; + } + # Turn a DIR argument on the command line into an array + if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { + # So they can choose from the command line, which extensions they want + # the grep enables them to have some colons too much in case they + # have to build a list with the shell + $self->{DIR} = [grep $_, split ":", $self->{DIR}]; + } + # Turn a INCLUDE_EXT argument on the command line into an array + if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') { + $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}]; + } + # Turn a EXCLUDE_EXT argument on the command line into an array + if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') { + $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}]; + } + + foreach my $mmkey (sort keys %$self){ + next if $mmkey eq 'ARGS'; + print " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; + print "'$mmkey' is not a known MakeMaker parameter name.\n" + unless exists $Recognized_Att_Keys{$mmkey}; + } + $| = 1 if $Verbose; +} + +sub check_hints { + my($self) = @_; + # We allow extension-specific hints files. + + require File::Spec; + my $curdir = File::Spec->curdir; + + my $hint_dir = File::Spec->catdir($curdir, "hints"); + return unless -d $hint_dir; + + # First we look for the best hintsfile we have + my($hint)="${^O}_$Config{osvers}"; + $hint =~ s/\./_/g; + $hint =~ s/_$//; + return unless $hint; + + # Also try without trailing minor version numbers. + while (1) { + last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found + } continue { + last unless $hint =~ s/_[^_]*$//; # nothing to cut off + } + my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl"); + + return unless -f $hint_file; # really there + + _run_hintfile($self, $hint_file); +} + +sub _run_hintfile { + our $self; + local($self) = shift; # make $self available to the hint file. + my($hint_file) = shift; + + local($@, $!); + print "Processing hints file $hint_file\n" if $Verbose; + + # Just in case the ./ isn't on the hint file, which File::Spec can + # often strip off, we bung the curdir into @INC + local @INC = (File::Spec->curdir, @INC); + my $ret = do $hint_file; + if( !defined $ret ) { + my $error = $@ || $!; + warn $error; + } +} + +sub mv_all_methods { + my($from,$to) = @_; + local $SIG{__WARN__} = sub { + # can't use 'no warnings redefined', 5.6 only + warn @_ unless $_[0] =~ /^Subroutine .* redefined/ + }; + foreach my $method (@Overridable) { + next unless defined &{"${from}::$method"}; + no strict 'refs'; ## no critic + *{"${to}::$method"} = \&{"${from}::$method"}; + + # If we delete a method, then it will be undefined and cannot + # be called. But as long as we have Makefile.PLs that rely on + # %MY:: being intact, we have to fill the hole with an + # inheriting method: + + { + package MY; + my $super = "SUPER::".$method; + *{$method} = sub { + shift->$super(@_); + }; + } + } +} + +sub skipcheck { + my($self) = shift; + my($section) = @_; + return 'skipped' if $section eq 'metafile' && $UNDER_CORE; + if ($section eq 'dynamic') { + print "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + print "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_lib'\n" + if $self->{SKIPHASH}{dynamic_lib} && $Verbose; + } + if ($section eq 'dynamic_lib') { + print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ", + "targets in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + } + if ($section eq 'static') { + print "Warning (non-fatal): Target 'static' depends on targets ", + "in skipped section 'static_lib'\n" + if $self->{SKIPHASH}{static_lib} && $Verbose; + } + return 'skipped' if $self->{SKIPHASH}{$section}; + return ''; +} + +# returns filehandle, dies on fail. :raw so no :crlf +sub open_for_writing { + my ($file) = @_; + open my $fh ,">", $file or die "Unable to open $file: $!"; + my @layers = ':raw'; + push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE; + binmode $fh, join ' ', @layers; + $fh; +} + +sub flush { + my $self = shift; + + my $finalname = $self->{MAKEFILE}; + printf "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT}; + print "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT}; + + unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); + + write_file_via_tmp($finalname, $self->{RESULT}); + + # Write MYMETA.yml to communicate metadata up to the CPAN clients + print "Writing MYMETA.yml and MYMETA.json\n" + if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta ); + + # save memory + if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) { + my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE); + delete $self->{$_} for grep !$keep{$_}, keys %$self; + } + + system("$Config::Config{eunicefix} $finalname") + if $Config::Config{eunicefix} ne ":"; + + return; +} + +sub write_file_via_tmp { + my ($finalname, $contents) = @_; + my $fh = open_for_writing("MakeMaker.tmp"); + die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents; + for my $chunk (@$contents) { + my $to_write = $chunk; + utf8::encode $to_write if !$CAN_DECODE && $] > 5.008; + print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!"; + } + close $fh or die "Can't write to MakeMaker.tmp: $!"; + _rename("MakeMaker.tmp", $finalname) or + warn "rename MakeMaker.tmp => $finalname: $!"; + chmod 0644, $finalname if !$Is_VMS; + return; +} + +# This is a rename for OS's where the target must be unlinked first. +sub _rename { + my($src, $dest) = @_; + _unlink($dest); + return rename $src, $dest; +} + +# This is an unlink for OS's where the target must be writable first. +sub _unlink { + my @files = @_; + chmod 0666, @files; + return unlink @files; +} + + +# The following mkbootstrap() is only for installations that are calling +# the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker +# writes Makefiles, that use ExtUtils::Mkbootstrap directly. +sub mkbootstrap { + die <".neatvalue($v->{$key}); + } + return "{ ".join(', ',@m)." }"; +} + +sub _find_magic_vstring { + my $value = shift; + return $value if $UNDER_CORE; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; +} + +sub selfdocument { + my($self) = @_; + my(@m); + if ($Verbose){ + push @m, "\n# Full list of MakeMaker attribute values:"; + foreach my $key (sort keys %$self){ + next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/; + my($v) = neatvalue($self->{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @m, "# $key => $v"; + } + } + # added here as selfdocument is not overridable + push @m, <<'EOF'; + +# here so even if top_targets is overridden, these will still be defined +# gmake will silently still work if any are .PHONY-ed but nmake won't +EOF + push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n", + # config is so manifypods won't puke if no subdirs + grep !$self->{SKIPHASH}{$_}, + qw(static dynamic config); + join "\n", @m; +} + +1; + +__END__ + +package ExtUtils::Liblist; + +use strict; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use File::Spec; +require ExtUtils::Liblist::Kid; +our @ISA = qw(ExtUtils::Liblist::Kid File::Spec); + +# Backwards compatibility with old interface. +sub ext { + goto &ExtUtils::Liblist::Kid::ext; +} + +sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir my $dir_fh, $_[0]; + my @out = grep /$rex/, readdir $dir_fh; + closedir $dir_fh; + return @out; +} + +__END__ + + +package ExtUtils::Installed; + +use 5.00503; +use strict; +#use warnings; # XXX requires 5.6 +use Carp qw(); +use ExtUtils::Packlist; +use ExtUtils::MakeMaker; +use Config; +use File::Find; +use File::Basename; +use File::Spec; + +my $Is_VMS = $^O eq 'VMS'; +my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); + +require VMS::Filespec if $Is_VMS; + +use vars qw($VERSION); +$VERSION = '2.14'; +$VERSION = eval $VERSION; + +sub _is_prefix { + my ($self, $path, $prefix) = @_; + return unless defined $prefix && defined $path; + + if( $Is_VMS ) { + $prefix = VMS::Filespec::unixify($prefix); + $path = VMS::Filespec::unixify($path); + } + + # Unix path normalization. + $prefix = File::Spec->canonpath($prefix); + + return 1 if substr($path, 0, length($prefix)) eq $prefix; + + if ($DOSISH) { + $path =~ s|\\|/|g; + $prefix =~ s|\\|/|g; + return 1 if $path =~ m{^\Q$prefix\E}i; + } + return(0); +} + +sub _is_doc { + my ($self, $path) = @_; + + my $man1dir = $self->{':private:'}{Config}{man1direxp}; + my $man3dir = $self->{':private:'}{Config}{man3direxp}; + return(($man1dir && $self->_is_prefix($path, $man1dir)) + || + ($man3dir && $self->_is_prefix($path, $man3dir)) + ? 1 : 0) +} + +sub _is_type { + my ($self, $path, $type) = @_; + return 1 if $type eq "all"; + + return($self->_is_doc($path)) if $type eq "doc"; + my $conf= $self->{':private:'}{Config}; + if ($type eq "prog") { + return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp}) + && !($self->_is_doc($path)) ? 1 : 0); + } + return(0); +} + +sub _is_under { + my ($self, $path, @under) = @_; + $under[0] = "" if (! @under); + foreach my $dir (@under) { + return(1) if ($self->_is_prefix($path, $dir)); + } + + return(0); +} + +sub _fix_dirs { + my ($self, @dirs)= @_; + # File::Find does not know how to deal with VMS filepaths. + if( $Is_VMS ) { + $_ = VMS::Filespec::unixify($_) + for @dirs; + } + + if ($DOSISH) { + s|\\|/|g for @dirs; + } + return wantarray ? @dirs : $dirs[0]; +} + +sub _make_entry { + my ($self, $module, $packlist_file, $modfile)= @_; + + my $data= { + module => $module, + packlist => scalar(ExtUtils::Packlist->new($packlist_file)), + packlist_file => $packlist_file, + }; + + if (!$modfile) { + $data->{version} = $self->{':private:'}{Config}{version}; + } else { + $data->{modfile} = $modfile; + # Find the top-level module file in @INC + $data->{version} = ''; + foreach my $dir (@{$self->{':private:'}{INC}}) { + my $p = File::Spec->catfile($dir, $modfile); + if (-r $p) { + $module = _module_name($p, $module) if $Is_VMS; + + $data->{version} = MM->parse_version($p); + $data->{version_from} = $p; + $data->{packlist_valid} = exists $data->{packlist}{$p}; + last; + } + } + } + $self->{$module}= $data; +} + +our $INSTALLED; +sub new { + my ($class) = shift(@_); + $class = ref($class) || $class; + + my %args = @_; + + return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default}); + + my $self = bless {}, $class; + + $INSTALLED= $self if $args{default_set} || $args{default}; + + + if ($args{config_override}) { + eval { + $self->{':private:'}{Config} = { %{$args{config_override}} }; + } or Carp::croak( + "The 'config_override' parameter must be a hash reference." + ); + } + else { + $self->{':private:'}{Config} = \%Config; + } + + for my $tuple ([inc_override => INC => [ @INC ] ], + [ extra_libs => EXTRA => [] ]) + { + my ($arg,$key,$val)=@$tuple; + if ( $args{$arg} ) { + eval { + $self->{':private:'}{$key} = [ @{$args{$arg}} ]; + } or Carp::croak( + "The '$arg' parameter must be an array reference." + ); + } + elsif ($val) { + $self->{':private:'}{$key} = $val; + } + } + { + my %dupe; + @{$self->{':private:'}{LIBDIRS}} = + grep { $_ ne '.' || ! $args{skip_cwd} } + grep { -e $_ && !$dupe{$_}++ } + @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}}; + } + + my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}}); + + # Read the core packlist + my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp}); + $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist')); + + my $root; + # Read the module packlists + my $sub = sub { + # Only process module .packlists + return if $_ ne ".packlist" || $File::Find::dir eq $archlib; + + # Hack of the leading bits of the paths & convert to a module name + my $module = $File::Find::name; + my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s + or do { + # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n", + # join ("\n",@dirs); + return; + }; + + my $modfile = "$module.pm"; + $module =~ s!/!::!g; + + return if $self->{$module}; #shadowing? + $self->_make_entry($module,$File::Find::name,$modfile); + }; + while (@dirs) { + $root= shift @dirs; + next if !-d $root; + find($sub,$root); + } + + return $self; +} + +# VMS's non-case preserving file-system means the package name can't +# be reconstructed from the filename. +sub _module_name { + my($file, $orig_module) = @_; + + my $module = ''; + if (open PACKFH, $file) { + while () { + if (/package\s+(\S+)\s*;/) { + my $pack = $1; + # Make a sanity check, that lower case $module + # is identical to lowercase $pack before + # accepting it + if (lc($pack) eq lc($orig_module)) { + $module = $pack; + last; + } + } + } + close PACKFH; + } + + print STDERR "Couldn't figure out the package name for $file\n" + unless $module; + + return $module; +} + +sub modules { + my ($self) = @_; + $self= $self->new(default=>1) if !ref $self; + + # Bug/feature of sort in scalar context requires this. + return wantarray + ? sort grep { not /^:private:$/ } keys %$self + : grep { not /^:private:$/ } keys %$self; +} + +sub files { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + + # Validate arguments + Carp::croak("$module is not installed") if (! exists($self->{$module})); + $type = "all" if (! defined($type)); + Carp::croak('type must be "all", "prog" or "doc"') + if ($type ne "all" && $type ne "prog" && $type ne "doc"); + + my (@files); + foreach my $file (keys(%{$self->{$module}{packlist}})) { + push(@files, $file) + if ($self->_is_type($file, $type) && + $self->_is_under($file, @under)); + } + return(@files); +} + +sub directories { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + my (%dirs); + foreach my $file ($self->files($module, $type, @under)) { + $dirs{dirname($file)}++; + } + return sort keys %dirs; +} + +sub directory_tree { + my ($self, $module, $type, @under) = @_; + $self= $self->new(default=>1) if !ref $self; + my (%dirs); + foreach my $dir ($self->directories($module, $type, @under)) { + $dirs{$dir}++; + my ($last) = (""); + while ($last ne $dir) { + $last = $dir; + $dir = dirname($dir); + last if !$self->_is_under($dir, @under); + $dirs{$dir}++; + } + } + return(sort(keys(%dirs))); +} + +sub validate { + my ($self, $module, $remove) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{packlist}->validate($remove)); +} + +sub packlist { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{packlist}); +} + +sub version { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + Carp::croak("$module is not installed") if (! exists($self->{$module})); + return($self->{$module}{version}); +} + +sub debug_dump { + my ($self, $module) = @_; + $self= $self->new(default=>1) if !ref $self; + local $self->{":private:"}{Config}; + require Data::Dumper; + print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump(); +} + + +1; + +__END__ + +package ExtUtils::MM_MacOS; + +use strict; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +sub new { + die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'; +} + + +1; +#!./perl -w +package ExtUtils::Miniperl; +use strict; +require Exporter; +use ExtUtils::Embed 1.31, qw(xsi_header xsi_protos xsi_body); + +our @ISA = qw(Exporter); +our @EXPORT = qw(writemain); +our $VERSION = '1.08'; + +# blead will run this with miniperl, hence we can't use autodie or File::Temp +my $temp; + +END { + return if !defined $temp || !-e $temp; + unlink $temp or warn "Can't unlink '$temp': $!"; +} + +sub writemain{ + my ($fh, $real); + + if (ref $_[0] eq 'SCALAR') { + $real = ${+shift}; + $temp = $real; + $temp =~ s/(?:.c)?\z/.new/; + open $fh, '>', $temp + or die "Can't open '$temp' for writing: $!"; + } elsif (ref $_[0]) { + $fh = shift; + } else { + $fh = \*STDOUT; + } + + my(@exts) = @_; + + printf $fh <<'EOF!HEAD', xsi_header(); +/* miniperlmain.c or perlmain.c - a generated file + * + * Copyright (C) 1994, 1995, 1996, 1997, 1999, 2000, 2001, 2002, 2003, + * 2004, 2005, 2006, 2007, 2016 by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* + * The Road goes ever on and on + * Down from the door where it began. + * + * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] + * [Frodo on p.73 of _The Lord of the Rings_, I/iii: "Three Is Company"] + */ + +/* This file contains the main() function for the perl interpreter. + * Note that miniperlmain.c contains main() for the 'miniperl' binary, + * while perlmain.c contains main() for the 'perl' binary. The typical + * difference being that the latter includes Dynaloader. + * + * Miniperl is like perl except that it does not support dynamic loading, + * and in fact is used to build the dynamic modules needed for the 'real' + * perl executable. + * + * The content of the body of this generated file is mostly contained + * in Miniperl.pm - edit that file if you want to change anything. + * miniperlmain.c is generated by running regen/miniperlmain.pl.pl, while + * perlmain.c is built automatically by Makefile (so the former is + * included in the tarball while the latter isn't). + */ + +#ifdef OEMVS +#ifdef MYMALLOC +/* sbrk is limited to first heap segment so make it big */ +#pragma runopts(HEAP(8M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#else +#pragma runopts(HEAP(2M,500K,ANYWHERE,KEEP,8K,4K) STACK(,,ANY,) ALL31(ON)) +#endif +#endif + +#define PERL_IN_MINIPERLMAIN_C +%s +static void xs_init (pTHX); +static PerlInterpreter *my_perl; + +#if defined(PERL_GLOBAL_STRUCT_PRIVATE) +/* The static struct perl_vars* may seem counterproductive since the + * whole idea PERL_GLOBAL_STRUCT_PRIVATE was to avoid statics, but note + * that this static is not in the shared perl library, the globals PL_Vars + * and PL_VarsPtr will stay away. */ +static struct perl_vars* my_plvarsp; +struct perl_vars* Perl_GetVarsPrivate(void) { return my_plvarsp; } +#endif + +#ifdef NO_ENV_ARRAY_IN_MAIN +extern char **environ; +int +main(int argc, char **argv) +#else +int +main(int argc, char **argv, char **env) +#endif +{ + int exitstatus, i; +#ifdef PERL_GLOBAL_STRUCT + struct perl_vars *my_vars = init_global_struct(); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + int veto; + + my_plvarsp = my_vars; +# endif +#endif /* PERL_GLOBAL_STRUCT */ +#ifndef NO_ENV_ARRAY_IN_MAIN + PERL_UNUSED_ARG(env); +#endif +#ifndef PERL_USE_SAFE_PUTENV + PL_use_safe_putenv = FALSE; +#endif /* PERL_USE_SAFE_PUTENV */ + + /* if user wants control of gprof profiling off by default */ + /* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */ + PERL_GPROF_MONCONTROL(0); + +#ifdef NO_ENV_ARRAY_IN_MAIN + PERL_SYS_INIT3(&argc,&argv,&environ); +#else + PERL_SYS_INIT3(&argc,&argv,&env); +#endif + +#if defined(USE_ITHREADS) + /* XXX Ideally, this should really be happening in perl_alloc() or + * perl_construct() to keep libperl.a transparently fork()-safe. + * It is currently done here only because Apache/mod_perl have + * problems due to lack of a call to cancel pthread_atfork() + * handlers when shared objects that contain the handlers may + * be dlclose()d. This forces applications that embed perl to + * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't + * been called at least once before in the current process. + * --GSAR 2001-07-20 */ + PTHREAD_ATFORK(Perl_atfork_lock, + Perl_atfork_unlock, + Perl_atfork_unlock); +#endif + + PERL_SYS_FPU_INIT; + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct(my_perl); + PL_perl_destruct_level = 0; + } + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + if (!perl_parse(my_perl, xs_init, argc, argv, (char **)NULL)) + perl_run(my_perl); + +#ifndef PERL_MICRO + /* Unregister our signal handler before destroying my_perl */ + for (i = 1; PL_sig_name[i]; i++) { + if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) { + rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL); + } + } +#endif + + exitstatus = perl_destruct(my_perl); + + perl_free(my_perl); + +#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN) + /* + * The old environment may have been freed by perl_free() + * when PERL_TRACK_MEMPOOL is defined, but without having + * been restored by perl_destruct() before (this is only + * done if destruct_level > 0). + * + * It is important to have a valid environment for atexit() + * routines that are eventually called. + */ + environ = env; +#endif + + PERL_SYS_TERM(); + +#ifdef PERL_GLOBAL_STRUCT +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + veto = my_plvarsp->Gveto_cleanup; +# endif + free_global_struct(my_vars); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + if (!veto) + my_plvarsp = NULL; + /* Remember, functions registered with atexit() can run after this point, + and may access "global" variables, and hence end up calling + Perl_GetVarsPrivate() */ +#endif +#endif /* PERL_GLOBAL_STRUCT */ + + exit(exitstatus); +} + +/* Register any extra external extensions */ + +EOF!HEAD + + print $fh xsi_protos(@exts), <<'EOT', xsi_body(@exts), "}\n"; + +static void +xs_init(pTHX) +{ +EOT + + if ($real) { + close $fh or die "Can't close '$temp': $!"; + rename $temp, $real or die "Can't rename '$temp' to '$real': $!"; + } +} + +1; +__END__ + + +# ex: set ts=8 sts=4 sw=4 et: +package ExtUtils::MM_DOS; + +use strict; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + + + +sub os_flavor { + return('DOS'); +} + + +sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,__,g; + return $man; +} + + +sub xs_static_lib_is_xs { + return 1; +} + + +1; +package ExtUtils::testlib; + +use strict; +use warnings; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use Cwd; +use File::Spec; + +# So the tests can chdir around and not break @INC. +# We use getcwd() because otherwise rel2abs will blow up under taint +# mode pre-5.8. We detaint is so @INC won't be tainted. This is +# no worse, and probably better, than just shoving an untainted, +# relative "blib/lib" onto @INC. +my $cwd; +BEGIN { + ($cwd) = getcwd() =~ /(.*)/; +} +use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib); +1; +__END__ + +package ExtUtils::ParseXS; +use strict; + +use 5.006001; +use Cwd; +use Config; +use Exporter 'import'; +use File::Basename; +use File::Spec; +use Symbol; + +our $VERSION; +BEGIN { + $VERSION = '3.39'; + require ExtUtils::ParseXS::Constants; ExtUtils::ParseXS::Constants->VERSION($VERSION); + require ExtUtils::ParseXS::CountLines; ExtUtils::ParseXS::CountLines->VERSION($VERSION); + require ExtUtils::ParseXS::Utilities; ExtUtils::ParseXS::Utilities->VERSION($VERSION); + require ExtUtils::ParseXS::Eval; ExtUtils::ParseXS::Eval->VERSION($VERSION); +} +$VERSION = eval $VERSION if $VERSION =~ /_/; + +use ExtUtils::ParseXS::Utilities qw( + standard_typemap_locations + trim_whitespace + C_string + valid_proto_string + process_typemaps + map_type + standard_XS_defs + assign_func_args + analyze_preprocessor_statements + set_cond + Warn + current_line_number + blurt + death + check_conditional_preprocessor_statements + escape_file_for_line_directive + report_typemap_failure +); + +our @EXPORT_OK = qw( + process_file + report_error_count +); + +############################## +# A number of "constants" + +our ($C_group_rex, $C_arg); +# Group in C (no support for comments or literals) +$C_group_rex = qr/ [({\[] + (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* + [)}\]] /x; +# Chunk in C without comma at toplevel (no comments): +$C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) + | (??{ $C_group_rex }) + | " (?: (?> [^\\"]+ ) + | \\. + )* " # String literal + | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal + )* /xs; + +# "impossible" keyword (multiple newline) +my $END = "!End!\n\n"; +# Match an XS Keyword +my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:"; + + + +sub new { + return bless {} => shift; +} + +our $Singleton = __PACKAGE__->new; + +sub process_file { + my $self; + # Allow for $package->process_file(%hash), $obj->process_file, and process_file() + if (@_ % 2) { + my $invocant = shift; + $self = ref($invocant) ? $invocant : $invocant->new; + } + else { + $self = $Singleton; + } + + my %options = @_; + $self->{ProtoUsed} = exists $options{prototypes}; + + # Set defaults. + my %args = ( + argtypes => 1, + csuffix => '.c', + except => 0, + hiertype => 0, + inout => 1, + linenumbers => 1, + optimize => 1, + output => \*STDOUT, + prototypes => 0, + typemap => [], + versioncheck => 1, + FH => Symbol::gensym(), + %options, + ); + $args{except} = $args{except} ? ' TRY' : ''; + + # Global Constants + + my ($Is_VMS, $SymSet); + if ($^O eq 'VMS') { + $Is_VMS = 1; + # Establish set of global symbols with max length 28, since xsubpp + # will later add the 'XS_' prefix. + require ExtUtils::XSSymSet; + $SymSet = ExtUtils::XSSymSet->new(28); + } + @{ $self->{XSStack} } = ({type => 'none'}); + $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; + $self->{Overload} = 0; # bool + $self->{errors} = 0; # count + $self->{Fallback} = '&PL_sv_undef'; + + # Most of the 1500 lines below uses these globals. We'll have to + # clean this up sometime, probably. For now, we just pull them out + # of %args. -Ken + + $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; + $self->{WantPrototypes} = $args{prototypes}; + $self->{WantVersionChk} = $args{versioncheck}; + $self->{WantLineNumbers} = $args{linenumbers}; + $self->{IncludedFiles} = {}; + + die "Missing required parameter 'filename'" unless $args{filename}; + $self->{filepathname} = $args{filename}; + ($self->{dir}, $self->{filename}) = + (dirname($args{filename}), basename($args{filename})); + $self->{filepathname} =~ s/\\/\\\\/g; + $self->{IncludedFiles}->{$args{filename}}++; + + # Open the output file if given as a string. If they provide some + # other kind of reference, trust them that we can print to it. + if (not ref $args{output}) { + open my($fh), "> $args{output}" or die "Can't create $args{output}: $!"; + $args{outfile} = $args{output}; + $args{output} = $fh; + } + + # Really, we shouldn't have to chdir() or select() in the first + # place. For now, just save and restore. + my $orig_cwd = cwd(); + my $orig_fh = select(); + + chdir($self->{dir}); + my $pwd = cwd(); + my $csuffix = $args{csuffix}; + + if ($self->{WantLineNumbers}) { + my $cfile; + if ( $args{outfile} ) { + $cfile = $args{outfile}; + } + else { + $cfile = $args{filename}; + $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; + } + tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); + select PSEUDO_STDOUT; + } + else { + select $args{output}; + } + + $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); + + # Move more settings from parameters to object + foreach my $datum ( qw| argtypes except inout optimize | ) { + $self->{$datum} = $args{$datum}; + } + $self->{strip_c_func_prefix} = $args{s}; + + # Identify the version of xsubpp used + print <{filename}. Do not edit this file, edit $self->{filename} instead. + * + * ANY CHANGES MADE HERE WILL BE LOST! + * + */ + +EOM + + + print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n") + if $self->{WantLineNumbers}; + + # Open the input file (using $self->{filename} which + # is a basename'd $args{filename} due to chdir above) + open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; + + FIRSTMODULE: + while (readline($self->{FH})) { + if (/^=/) { + my $podstartline = $.; + do { + if (/^=cut\s*$/) { + # We can't just write out a /* */ comment, as our embedded + # POD might itself be in a comment. We can't put a /**/ + # comment inside #if 0, as the C standard says that the source + # file is decomposed into preprocessing characters in the stage + # before preprocessing commands are executed. + # I don't want to leave the text as barewords, because the spec + # isn't clear whether macros are expanded before or after + # preprocessing commands are executed, and someone pathological + # may just have defined one of the 3 words as a macro that does + # something strange. Multiline strings are illegal in C, so + # the "" we write must be a string literal. And they aren't + # concatenated until 2 steps later, so we are safe. + # - Nicholas Clark + print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); + printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) + if $self->{WantLineNumbers}; + next FIRSTMODULE; + } + + } while (readline($self->{FH})); + # At this point $. is at end of file so die won't state the start + # of the problem, and as we haven't yet read any lines &death won't + # show the correct line in the message either. + die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n") + unless $self->{lastline}; + } + last if ($self->{Package}, $self->{Prefix}) = + /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; + + print $_; + } + unless (defined $_) { + warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; + exit 0; # Not a fatal error for the caller process + } + + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; + + standard_XS_defs(); + + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; + + $self->{lastline} = $_; + $self->{lastline_no} = $.; + + my $BootCode_ref = []; + my $XSS_work_idx = 0; + my $cpp_next_tmp = 'XSubPPtmpAAAA'; + PARAGRAPH: + while ($self->fetch_para()) { + my $outlist_ref = []; + # Print initial preprocessor statements and blank lines + while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { + my $ln = shift(@{ $self->{line} }); + print $ln, "\n"; + next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; + my $statement = $+; + ( $self, $XSS_work_idx, $BootCode_ref ) = + analyze_preprocessor_statements( + $self, $statement, $XSS_work_idx, $BootCode_ref + ); + } + + next PARAGRAPH unless @{ $self->{line} }; + + if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) { + # We are inside an #if, but have not yet #defined its xsubpp variable. + print "#define $cpp_next_tmp 1\n\n"; + push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); + push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); + $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; + } + + $self->death( + "Code is not inside a function" + ." (maybe last function was ended by a blank line " + ." followed by a statement on column one?)") + if $self->{line}->[0] =~ /^\s/; + + # initialize info arrays + foreach my $member (qw(args_match var_types defaults arg_list + argtype_seen in_out lengthof)) + { + $self->{$member} = {}; + } + $self->{proto_arg} = []; + $self->{processing_arg_with_types} = 0; # bool + $self->{proto_in_this_xsub} = 0; # counter & bool + $self->{scope_in_this_xsub} = 0; # counter & bool + $self->{interface} = 0; # bool + $self->{interface_macro} = 'XSINTERFACE_FUNC'; + $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; + $self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) + $self->{ScopeThisXSUB} = 0; # bool + + my $xsreturn = 0; + + $_ = shift(@{ $self->{line} }); + while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { + my $method = $kwd . "_handler"; + $self->$method($_); + next PARAGRAPH unless @{ $self->{line} }; + $_ = shift(@{ $self->{line} }); + } + + if ($self->check_keyword("BOOT")) { + check_conditional_preprocessor_statements($self); + push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" + . escape_file_for_line_directive($self->{filepathname}) . "\"") + if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; + push (@{ $BootCode_ref }, @{ $self->{line} }, ""); + next PARAGRAPH; + } + + # extract return type, function name and arguments + ($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_); + my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; + + # Allow one-line ANSI-like declaration + unshift @{ $self->{line} }, $2 + if $self->{argtypes} + and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; + + # a function definition needs at least 2 lines + $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH + unless @{ $self->{line} }; + + my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; + my $static = 1 if $self->{ret_type} =~ s/^static\s+//; + + my $func_header = shift(@{ $self->{line} }); + $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH + unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; + + my ($class, $orig_args); + ($class, $self->{func_name}, $orig_args) = ($1, $2, $3); + $class = "$4 $class" if $4; + ($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; + my $clean_func_name; + ($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//; + $self->{Full_func_name} = "$self->{Packid}_$clean_func_name"; + if ($Is_VMS) { + $self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} ); + } + + # Check for duplicate function definition + for my $tmp (@{ $self->{XSStack} }) { + next unless defined $tmp->{functions}{ $self->{Full_func_name} }; + Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); + last; + } + $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; + delete $self->{XsubAliases}; + delete $self->{XsubAliasValues}; + %{ $self->{Interfaces} } = (); + @{ $self->{Attributes} } = (); + $self->{DoSetMagic} = 1; + + $orig_args =~ s/\\\s*/ /g; # process line continuations + my @args; + + my (@fake_INPUT_pre); # For length(s) generated variables + my (@fake_INPUT); + my $only_C_inlist_ref = {}; # Not in the signature of Perl function + if ($self->{argtypes} and $orig_args =~ /\S/) { + my $args = "$orig_args ,"; + use re 'eval'; + if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { + @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); + no re 'eval'; + for ( @args ) { + s/^\s+//; + s/\s+$//; + my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); + my ($pre, $len_name) = ($arg =~ /(.*?) \s* + \b ( \w+ | length\( \s*\w+\s* \) ) + \s* $ /x); + next unless defined($pre) && length($pre); + my $out_type = ''; + my $inout_var; + if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { + my $type = $1; + $out_type = $type if $type ne 'IN'; + $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; + $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; + } + my $islength; + if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { + $len_name = "XSauto_length_of_$1"; + $islength = 1; + die "Default value on length() argument: '$_'" + if length $default; + } + if (length $pre or $islength) { # Has a type + if ($islength) { + push @fake_INPUT_pre, $arg; + } + else { + push @fake_INPUT, $arg; + } + # warn "pushing '$arg'\n"; + $self->{argtype_seen}->{$len_name}++; + $_ = "$len_name$default"; # Assigns to @args + } + $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; + push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; + $self->{in_out}->{$len_name} = $out_type if $out_type; + } + } + else { + no re 'eval'; + @args = split(/\s*,\s*/, $orig_args); + Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); + } + } + else { + @args = split(/\s*,\s*/, $orig_args); + for (@args) { + if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { + my $out_type = $1; + next if $out_type eq 'IN'; + $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; + if ($out_type =~ /OUTLIST$/) { + push @{ $outlist_ref }, undef; + } + $self->{in_out}->{$_} = $out_type; + } + } + } + if (defined($class)) { + my $arg0 = ((defined($static) or $self->{func_name} eq 'new') + ? "CLASS" : "THIS"); + unshift(@args, $arg0); + } + my $extra_args = 0; + my @args_num = (); + my $num_args = 0; + my $report_args = ''; + my $ellipsis; + foreach my $i (0 .. $#args) { + if ($args[$i] =~ s/\.\.\.//) { + $ellipsis = 1; + if ($args[$i] eq '' && $i == $#args) { + $report_args .= ", ..."; + pop(@args); + last; + } + } + if ($only_C_inlist_ref->{$args[$i]}) { + push @args_num, undef; + } + else { + push @args_num, ++$num_args; + $report_args .= ", $args[$i]"; + } + if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { + $extra_args++; + $args[$i] = $1; + $self->{defaults}->{$args[$i]} = $2; + $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; + } + $self->{proto_arg}->[$i+1] = '$'; + } + my $min_args = $num_args - $extra_args; + $report_args =~ s/"/\\"/g; + $report_args =~ s/^,\s+//; + $self->{func_args} = assign_func_args($self, \@args, $class); + @{ $self->{args_match} }{@args} = @args_num; + + my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); + my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); + # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) + # to set explicit return values. + my $EXPLICIT_RETURN = ($CODE && + ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); + + $self->{ALIAS} = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); + + my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); + + $xsreturn = 1 if $EXPLICIT_RETURN; + + $externC = $externC ? qq[extern "C"] : ""; + + # print function header + print Q(<<"EOF"); +#$externC +#XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */ +#XS_EUPXS(XS_$self->{Full_func_name}) +#[[ +# dVAR; dXSARGS; +EOF + print Q(<<"EOF") if $self->{ALIAS}; +# dXSI32; +EOF + print Q(<<"EOF") if $INTERFACE; +# dXSFUNCTION($self->{ret_type}); +EOF + + $self->{cond} = set_cond($ellipsis, $min_args, $num_args); + + print Q(<<"EOF") if $self->{except}; +# char errbuf[1024]; +# *errbuf = '\\0'; +EOF + + if($self->{cond}) { + print Q(<<"EOF"); +# if ($self->{cond}) +# croak_xs_usage(cv, "$report_args"); +EOF + } + else { + # cv and items likely to be unused + print Q(<<"EOF"); +# PERL_UNUSED_VAR(cv); /* -W */ +# PERL_UNUSED_VAR(items); /* -W */ +EOF + } + + #gcc -Wall: if an xsub has PPCODE is used + #it is possible none of ST, XSRETURN or XSprePUSH macros are used + #hence 'ax' (setup by dXSARGS) is unused + #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS + #but such a move could break third-party extensions + print Q(<<"EOF") if $PPCODE; +# PERL_UNUSED_VAR(ax); /* -Wall */ +EOF + + print Q(<<"EOF") if $PPCODE; +# SP -= items; +EOF + + # Now do a block of some sort. + + $self->{condnum} = 0; + $self->{cond} = ''; # last CASE: conditional + push(@{ $self->{line} }, "$END:"); + push(@{ $self->{line_no} }, $self->{line_no}->[-1]); + $_ = ''; + check_conditional_preprocessor_statements(); + while (@{ $self->{line} }) { + + $self->CASE_handler($_) if $self->check_keyword("CASE"); + print Q(<<"EOF"); +# $self->{except} [[ +EOF + + # do initialization of input variables + $self->{thisdone} = 0; + $self->{retvaldone} = 0; + $self->{deferred} = ""; + %{ $self->{arg_list} } = (); + $self->{gotRETVAL} = 0; + $self->INPUT_handler($_); + $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); + + print Q(<<"EOF") if $self->{ScopeThisXSUB}; +# ENTER; +# [[ +EOF + + if (!$self->{thisdone} && defined($class)) { + if (defined($static) or $self->{func_name} eq 'new') { + print "\tchar *"; + $self->{var_types}->{"CLASS"} = "char *"; + $self->generate_init( { + type => "char *", + num => 1, + var => "CLASS", + printed_name => undef, + } ); + } + else { + print "\t" . map_type($self, "$class *"); + $self->{var_types}->{"THIS"} = "$class *"; + $self->generate_init( { + type => "$class *", + num => 1, + var => "THIS", + printed_name => undef, + } ); + } + } + + # These are set if OUTPUT is found and/or CODE using RETVAL + $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; + + my ($wantRETVAL); + # do code + if (/^\s*NOT_IMPLEMENTED_YET/) { + print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; + $_ = ''; + } + else { + if ($self->{ret_type} ne "void") { + print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" + if !$self->{retvaldone}; + $self->{args_match}->{"RETVAL"} = 0; + $self->{var_types}->{"RETVAL"} = $self->{ret_type}; + my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); + print "\tdXSTARG;\n" + if $self->{optimize} and $outputmap and $outputmap->targetable; + } + + if (@fake_INPUT or @fake_INPUT_pre) { + unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; + $_ = ""; + $self->{processing_arg_with_types} = 1; + $self->INPUT_handler($_); + } + print $self->{deferred}; + + $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); + + if ($self->check_keyword("PPCODE")) { + $self->print_section(); + $self->death("PPCODE must be last thing") if @{ $self->{line} }; + print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; + print "\tPUTBACK;\n\treturn;\n"; + } + elsif ($self->check_keyword("CODE")) { + my $consumed_code = $self->print_section(); + if ($consumed_code =~ /\bRETVAL\b/) { + $self->{have_CODE_with_RETVAL} = 1; + } + } + elsif (defined($class) and $self->{func_name} eq "DESTROY") { + print "\n\t"; + print "delete THIS;\n"; + } + else { + print "\n\t"; + if ($self->{ret_type} ne "void") { + print "RETVAL = "; + $wantRETVAL = 1; + } + if (defined($static)) { + if ($self->{func_name} eq 'new') { + $self->{func_name} = "$class"; + } + else { + print "${class}::"; + } + } + elsif (defined($class)) { + if ($self->{func_name} eq 'new') { + $self->{func_name} .= " $class"; + } + else { + print "THIS->"; + } + } + my $strip = $self->{strip_c_func_prefix}; + $self->{func_name} =~ s/^\Q$strip// + if defined $strip; + $self->{func_name} = 'XSFUNCTION' if $self->{interface}; + print "$self->{func_name}($self->{func_args});\n"; + } + } + + # do output variables + $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; + undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); + # $wantRETVAL set if 'RETVAL =' autogenerated + ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; + undef %{ $self->{outargs} }; + + $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + + # A CODE section with RETVAL, but no OUTPUT? FAIL! + if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { + $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); + } + + $self->generate_output( { + type => $self->{var_types}->{$_}, + num => $self->{args_match}->{$_}, + var => $_, + do_setmagic => $self->{DoSetMagic}, + do_push => undef, + } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; + + my $prepush_done; + # all OUTPUT done, so now push the return value on the stack + if ($self->{gotRETVAL} && $self->{RETVAL_code}) { + print "\t$self->{RETVAL_code}\n"; + } + elsif ($self->{gotRETVAL} || $wantRETVAL) { + my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); + my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; + my $var = 'RETVAL'; + my $type = $self->{ret_type}; + + if ($trgt) { + my $what = $self->eval_output_typemap_code( + qq("$trgt->{what}"), + {var => $var, type => $self->{ret_type}} + ); + if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv + # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly + print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; + $prepush_done = 1; + } + else { + my $tsize = $trgt->{what_size}; + $tsize = '' unless defined $tsize; + $tsize = $self->eval_output_typemap_code( + qq("$tsize"), + {var => $var, type => $self->{ret_type}} + ); + print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; + $prepush_done = 1; + } + } + else { + # RETVAL almost never needs SvSETMAGIC() + $self->generate_output( { + type => $self->{ret_type}, + num => 0, + var => 'RETVAL', + do_setmagic => 0, + do_push => undef, + } ); + } + } + + $xsreturn = 1 if $self->{ret_type} ne "void"; + my $num = $xsreturn; + my $c = @{ $outlist_ref }; + print "\tXSprePUSH;" if $c and not $prepush_done; + print "\tEXTEND(SP,$c);\n" if $c; + $xsreturn += $c; + $self->generate_output( { + type => $self->{var_types}->{$_}, + num => $num++, + var => $_, + do_setmagic => 0, + do_push => 1, + } ) for @{ $outlist_ref }; + + # do cleanup + $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); + + print Q(<<"EOF") if $self->{ScopeThisXSUB}; +# ]] +EOF + print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; +# LEAVE; +EOF + + # print function trailer + print Q(<<"EOF"); +# ]] +EOF + print Q(<<"EOF") if $self->{except}; +# BEGHANDLERS +# CATCHALL +# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); +# ENDHANDLERS +EOF + if ($self->check_keyword("CASE")) { + $self->blurt("Error: No 'CASE:' at top of function") + unless $self->{condnum}; + $_ = "CASE: $_"; # Restore CASE: label + next; + } + last if $_ eq "$END:"; + $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); + } + + print Q(<<"EOF") if $self->{except}; +# if (errbuf[0]) +# Perl_croak(aTHX_ errbuf); +EOF + + if ($xsreturn) { + print Q(<<"EOF") unless $PPCODE; +# XSRETURN($xsreturn); +EOF + } + else { + print Q(<<"EOF") unless $PPCODE; +# XSRETURN_EMPTY; +EOF + } + + print Q(<<"EOF"); +#]] +# +EOF + + $self->{proto} = ""; + unless($self->{ProtoThisXSUB}) { + $self->{newXS} = "newXS_deffile"; + $self->{file} = ""; + } + else { + # Build the prototype string for the xsub + $self->{newXS} = "newXSproto_portable"; + $self->{file} = ", file"; + + if ($self->{ProtoThisXSUB} eq 2) { + # User has specified empty prototype + } + elsif ($self->{ProtoThisXSUB} eq 1) { + my $s = ';'; + if ($min_args < $num_args) { + $s = ''; + $self->{proto_arg}->[$min_args] .= ";"; + } + push @{ $self->{proto_arg} }, "$s\@" + if $ellipsis; + + $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); + } + else { + # User has specified a prototype + $self->{proto} = $self->{ProtoThisXSUB}; + } + $self->{proto} = qq{, "$self->{proto}"}; + } + + if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { + $self->{XsubAliases}->{ $self->{pname} } = 0 + unless defined $self->{XsubAliases}->{ $self->{pname} }; + foreach my $xname (sort keys %{ $self->{XsubAliases} }) { + my $value = $self->{XsubAliases}{$xname}; + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); +# XSANY.any_i32 = $value; +EOF + } + } + elsif (@{ $self->{Attributes} }) { + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); +# apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); +EOF + } + elsif ($self->{interface}) { + foreach my $yname (sort keys %{ $self->{Interfaces} }) { + my $value = $self->{Interfaces}{$yname}; + $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; + push(@{ $self->{InitFileCode} }, Q(<<"EOF")); +# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); +# $self->{interface_macro_set}(cv,$value); +EOF + } + } + elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro + push(@{ $self->{InitFileCode} }, + " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); + } + else { + push(@{ $self->{InitFileCode} }, + " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); + } + } # END 'PARAGRAPH' 'while' loop + + if ($self->{Overload}) { # make it findable with fetchmethod + print Q(<<"EOF"); +#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ +#XS_EUPXS(XS_$self->{Packid}_nil) +#{ +# dXSARGS; +# PERL_UNUSED_VAR(items); +# XSRETURN_EMPTY; +#} +# +EOF + unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); + /* Making a sub named "$self->{Package}::()" allows the package */ + /* to be findable via fetchmethod(), and causes */ + /* overload::Overloaded("$self->{Package}") to return true. */ + (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); +MAKE_FETCHMETHOD_WORK + } + + # print initialization routine + + print Q(<<"EOF"); +##ifdef __cplusplus +#extern "C" +##endif +EOF + + print Q(<<"EOF"); +#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ +#XS_EXTERNAL(boot_$self->{Module_cname}) +#[[ +##if PERL_VERSION_LE(5, 21, 5) +# dVAR; dXSARGS; +##else +# dVAR; ${\($self->{WantVersionChk} ? + 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} +##endif +EOF + + #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const + #file name argument. If the wrong qualifier is used, it causes breakage with + #C++ compilers and warnings with recent gcc. + #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs + #so 'file' is unused + print Q(<<"EOF") if $self->{Full_func_name}; +##if (PERL_REVISION == 5 && PERL_VERSION < 9) +# char* file = __FILE__; +##else +# const char* file = __FILE__; +##endif +# +# PERL_UNUSED_VAR(file); +EOF + + print Q("#\n"); + + print Q(<<"EOF"); +# PERL_UNUSED_VAR(cv); /* -W */ +# PERL_UNUSED_VAR(items); /* -W */ +EOF + + if( $self->{WantVersionChk}){ + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) +# XS_VERSION_BOOTCHECK; +## ifdef XS_APIVERSION_BOOTCHECK +# XS_APIVERSION_BOOTCHECK; +## endif +##endif + +EOF + } else { + print Q(<<"EOF") ; +##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) +# XS_APIVERSION_BOOTCHECK; +##endif + +EOF + } + + print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; +# { +# CV * cv; +# +EOF + + print Q(<<"EOF") if ($self->{Overload}); +# /* register the overloading (type 'A') magic */ +##if (PERL_REVISION == 5 && PERL_VERSION < 9) +# PL_amagic_generation++; +##endif +# /* The magic for overload gets a GV* via gv_fetchmeth as */ +# /* mentioned above, and looks in the SV* slot of it for */ +# /* the "fallback" status. */ +# sv_setsv( +# get_sv( "$self->{Package}::()", TRUE ), +# $self->{Fallback} +# ); +EOF + + print @{ $self->{InitFileCode} }; + + print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; +# } +EOF + + if (@{ $BootCode_ref }) { + print "\n /* Initialisation Section */\n\n"; + @{ $self->{line} } = @{ $BootCode_ref }; + $self->print_section(); + print "\n /* End of Initialisation Section */\n\n"; + } + + print Q(<<'EOF'); +##if PERL_VERSION_LE(5, 21, 5) +## if PERL_VERSION_GE(5, 9, 0) +# if (PL_unitcheckav) +# call_list(PL_scopestack_ix, PL_unitcheckav); +## endif +# XSRETURN_YES; +##else +# Perl_xs_boot_epilog(aTHX_ ax); +##endif +#]] +# +EOF + + warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") + unless $self->{ProtoUsed}; + + chdir($orig_cwd); + select($orig_fh); + untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; + close $self->{FH}; + + return 1; +} + +sub report_error_count { + if (@_) { + return $_[0]->{errors}||0; + } + else { + return $Singleton->{errors}||0; + } +} + +# Input: ($self, $_, @{ $self->{line} }) == unparsed input. +# Output: ($_, @{ $self->{line} }) == (rest of line, following lines). +# Return: the matched keyword if found, otherwise 0 +sub check_keyword { + my $self = shift; + $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; + s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; +} + +sub print_section { + my $self = shift; + + # the "do" is required for right semantics + do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; + + my $consumed_code = ''; + + print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", + escape_file_for_line_directive($self->{filepathname}), "\"\n") + if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; + for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + print "$_\n"; + $consumed_code .= "$_\n"; + } + print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; + + return $consumed_code; +} + +sub merge_section { + my $self = shift; + my $in = ''; + + while (!/\S/ && @{ $self->{line} }) { + $_ = shift(@{ $self->{line} }); + } + + for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + $in .= "$_\n"; + } + chomp $in; + return $in; +} + +sub process_keyword { + my($self, $pattern) = @_; + + while (my $kwd = $self->check_keyword($pattern)) { + my $method = $kwd . "_handler"; + $self->$method($_); + } +} + +sub CASE_handler { + my $self = shift; + $_ = shift; + $self->blurt("Error: 'CASE:' after unconditional 'CASE:'") + if $self->{condnum} && $self->{cond} eq ''; + $self->{cond} = $_; + trim_whitespace($self->{cond}); + print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); + $_ = ''; +} + +sub INPUT_handler { + my $self = shift; + $_ = shift; + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + last if /^\s*NOT_IMPLEMENTED_YET/; + next unless /\S/; # skip blank lines + + trim_whitespace($_); + my $ln = $_; + + # remove trailing semicolon if no initialisation + s/\s*;$//g unless /[=;+].*\S/; + + # Process the length(foo) declarations + if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { + print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; + $self->{lengthof}->{$2} = undef; + $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; + } + + # check for optional initialisation code + my $var_init = ''; + $var_init = $1 if s/\s*([=;+].*)$//s; + $var_init =~ s/"/\\"/g; + # *sigh* It's valid to supply explicit input typemaps in the argument list... + my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; + + s/\s+/ /g; + my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s + or $self->blurt("Error: invalid argument declaration '$ln'"), next; + + # Check for duplicate definitions + $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next + if $self->{arg_list}->{$var_name}++ + or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; + + $self->{thisdone} |= $var_name eq "THIS"; + $self->{retvaldone} |= $var_name eq "RETVAL"; + $self->{var_types}->{$var_name} = $var_type; + # XXXX This check is a safeguard against the unfinished conversion of + # generate_init(). When generate_init() is fixed, + # one can use 2-args map_type() unconditionally. + my $printed_name; + if ($var_type =~ / \( \s* \* \s* \) /x) { + # Function pointers are not yet supported with output_init()! + print "\t" . map_type($self, $var_type, $var_name); + $printed_name = 1; + } + else { + print "\t" . map_type($self, $var_type, undef); + $printed_name = 0; + } + $self->{var_num} = $self->{args_match}->{$var_name}; + + if ($self->{var_num}) { + my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); + $self->report_typemap_failure($self->{typemap}, $var_type, "death") + if not $typemap and not $is_overridden_typemap; + $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; + } + $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; + if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ + or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ + and $var_init !~ /\S/) { + if ($printed_name) { + print ";\n"; + } + else { + print "\t$var_name;\n"; + } + } + elsif ($var_init =~ /\S/) { + $self->output_init( { + type => $var_type, + num => $self->{var_num}, + var => $var_name, + init => $var_init, + printed_name => $printed_name, + } ); + } + elsif ($self->{var_num}) { + $self->generate_init( { + type => $var_type, + num => $self->{var_num}, + var => $var_name, + printed_name => $printed_name, + } ); + } + else { + print ";\n"; + } + } +} + +sub OUTPUT_handler { + my $self = shift; + $self->{have_OUTPUT} = 1; + + $_ = shift; + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { + $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); + next; + } + my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; + $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next + if $self->{outargs}->{$outarg}++; + if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { + # deal with RETVAL last + $self->{RETVAL_code} = $outcode; + $self->{gotRETVAL} = 1; + next; + } + $self->blurt("Error: OUTPUT $outarg not an argument"), next + unless defined($self->{args_match}->{$outarg}); + $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next + unless defined $self->{var_types}->{$outarg}; + $self->{var_num} = $self->{args_match}->{$outarg}; + if ($outcode) { + print "\t$outcode\n"; + print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; + } + else { + $self->generate_output( { + type => $self->{var_types}->{$outarg}, + num => $self->{var_num}, + var => $outarg, + do_setmagic => $self->{DoSetMagic}, + do_push => undef, + } ); + } + delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT + if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; + } +} + +sub C_ARGS_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); + + trim_whitespace($in); + $self->{func_args} = $in; +} + +sub INTERFACE_MACRO_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); + + trim_whitespace($in); + if ($in =~ /\s/) { # two + ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; + } + else { + $self->{interface_macro} = $in; + $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later + } + $self->{interface} = 1; # local + $self->{interfaces} = 1; # global +} + +sub INTERFACE_handler { + my $self = shift; + $_ = shift; + my $in = $self->merge_section(); + + trim_whitespace($in); + + foreach (split /[\s,]+/, $in) { + my $iface_name = $_; + $iface_name =~ s/^$self->{Prefix}//; + $self->{Interfaces}->{$iface_name} = $_; + } + print Q(<<"EOF"); +# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); +EOF + $self->{interface} = 1; # local + $self->{interfaces} = 1; # global +} + +sub CLEANUP_handler { + my $self = shift; + $self->print_section(); +} + +sub PREINIT_handler { + my $self = shift; + $self->print_section(); +} + +sub POSTCALL_handler { + my $self = shift; + $self->print_section(); +} + +sub INIT_handler { + my $self = shift; + $self->print_section(); +} + +sub get_aliases { + my $self = shift; + my ($line) = @_; + my ($orig) = $line; + + # Parse alias definitions + # format is + # alias = value alias = value ... + + while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { + my ($alias, $value) = ($1, $2); + my $orig_alias = $alias; + + # check for optional package definition in the alias + $alias = $self->{Packprefix} . $alias if $alias !~ /::/; + + # check for duplicate alias name & duplicate value + Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") + if defined $self->{XsubAliases}->{$alias}; + + Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") + if $self->{XsubAliasValues}->{$value}; + + $self->{XsubAliases}->{$alias} = $value; + $self->{XsubAliasValues}->{$value} = $orig_alias; + } + + blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") + if $line; +} + +sub ATTRS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + trim_whitespace($_); + push @{ $self->{Attributes} }, $_; + } +} + +sub ALIAS_handler { + my $self = shift; + $_ = shift; + + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + trim_whitespace($_); + $self->get_aliases($_) if $_; + } +} + +sub OVERLOAD_handler { + my $self = shift; + $_ = shift; + + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + trim_whitespace($_); + while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { + $self->{Overload} = 1 unless $self->{Overload}; + my $overload = "$self->{Package}\::(".$1; + push(@{ $self->{InitFileCode} }, + " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); + } + } +} + +sub FALLBACK_handler { + my ($self, $setting) = @_; + + # the rest of the current line should contain either TRUE, + # FALSE or UNDEF + + trim_whitespace($setting); + $setting = uc($setting); + + my %map = ( + TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", + FALSE => "&PL_sv_no", 0 => "&PL_sv_no", + UNDEF => "&PL_sv_undef", + ); + + # check for valid FALLBACK value + $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; + + $self->{Fallback} = $map{$setting}; +} + + +sub REQUIRE_handler { + # the rest of the current line should contain a version number + my ($self, $ver) = @_; + + trim_whitespace($ver); + + $self->death("Error: REQUIRE expects a version number") + unless $ver; + + # check that the version number is of the form n.n + $self->death("Error: REQUIRE: expected a number, got '$ver'") + unless $ver =~ /^\d+(\.\d*)?/; + + $self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.") + unless $VERSION >= $ver; +} + +sub VERSIONCHECK_handler { + # the rest of the current line should contain either ENABLE or + # DISABLE + my ($self, $setting) = @_; + + trim_whitespace($setting); + + # check for ENABLE/DISABLE + $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") + unless $setting =~ /^(ENABLE|DISABLE)/i; + + $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; + $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; + +} + +sub PROTOTYPE_handler { + my $self = shift; + $_ = shift; + + my $specified; + + $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") + if $self->{proto_in_this_xsub}++; + + for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { + next unless /\S/; + $specified = 1; + trim_whitespace($_); + if ($_ eq 'DISABLE') { + $self->{ProtoThisXSUB} = 0; + } + elsif ($_ eq 'ENABLE') { + $self->{ProtoThisXSUB} = 1; + } + else { + # remove any whitespace + s/\s+//g; + $self->death("Error: Invalid prototype '$_'") + unless valid_proto_string($_); + $self->{ProtoThisXSUB} = C_string($_); + } + } + + # If no prototype specified, then assume empty prototype "" + $self->{ProtoThisXSUB} = 2 unless $specified; + + $self->{ProtoUsed} = 1; +} + +sub SCOPE_handler { + # Rest of line should be either ENABLE or DISABLE + my ($self, $setting) = @_; + + $self->death("Error: Only 1 SCOPE declaration allowed per xsub") + if $self->{scope_in_this_xsub}++; + + trim_whitespace($setting); + $self->death("Error: SCOPE: ENABLE/DISABLE") + unless $setting =~ /^(ENABLE|DISABLE)\b/i; + $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); +} + +sub PROTOTYPES_handler { + # the rest of the current line should contain either ENABLE or + # DISABLE + my ($self, $setting) = @_; + + trim_whitespace($setting); + + # check for ENABLE/DISABLE + $self->death("Error: PROTOTYPES: ENABLE/DISABLE") + unless $setting =~ /^(ENABLE|DISABLE)/i; + + $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; + $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; + $self->{ProtoUsed} = 1; +} + +sub EXPORT_XSUB_SYMBOLS_handler { + # the rest of the current line should contain either ENABLE or + # DISABLE + my ($self, $setting) = @_; + + trim_whitespace($setting); + + # check for ENABLE/DISABLE + $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") + unless $setting =~ /^(ENABLE|DISABLE)/i; + + my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; + + print Q(<<"EOF"); +##undef XS_EUPXS +##if defined(PERL_EUPXS_ALWAYS_EXPORT) +## define XS_EUPXS(name) XS_EXTERNAL(name) +##elif defined(PERL_EUPXS_NEVER_EXPORT) +## define XS_EUPXS(name) XS_INTERNAL(name) +##else +## define XS_EUPXS(name) $xs_impl(name) +##endif +EOF +} + + +sub PushXSStack { + my $self = shift; + my %args = @_; + # Save the current file context. + push(@{ $self->{XSStack} }, { + type => 'file', + LastLine => $self->{lastline}, + LastLineNo => $self->{lastline_no}, + Line => $self->{line}, + LineNo => $self->{line_no}, + Filename => $self->{filename}, + Filepathname => $self->{filepathname}, + Handle => $self->{FH}, + IsPipe => scalar($self->{filename} =~ /\|\s*$/), + %args, + }); + +} + +sub INCLUDE_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain a valid filename + + trim_whitespace($_); + + $self->death("INCLUDE: filename missing") + unless $_; + + $self->death("INCLUDE: output pipe is illegal") + if /^\s*\|/; + + # simple minded recursion detector + $self->death("INCLUDE loop detected") + if $self->{IncludedFiles}->{$_}; + + ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; + + if (/\|\s*$/ && /^\s*perl\s/) { + Warn( $self, "The INCLUDE directive with a command is discouraged." . + " Use INCLUDE_COMMAND instead! In particular using 'perl'" . + " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . + " up the correct perl. The INCLUDE_COMMAND directive allows" . + " the use of \$^X as the currently running perl, see" . + " 'perldoc perlxs' for details."); + } + + $self->PushXSStack(); + + $self->{FH} = Symbol::gensym(); + + # open the new file + open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); + + print Q(<<"EOF"); +# +#/* INCLUDE: Including '$_' from '$self->{filename}' */ +# +EOF + + $self->{filename} = $_; + $self->{filepathname} = ( $^O =~ /^mswin/i ) + ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? + : File::Spec->catfile($self->{dir}, $self->{filename}); + + # Prime the pump by reading the first + # non-blank line + + # skip leading blank lines + while (readline($self->{FH})) { + last unless /^\s*$/; + } + + $self->{lastline} = $_; + $self->{lastline_no} = $.; +} + +sub QuoteArgs { + my $cmd = shift; + my @args = split /\s+/, $cmd; + $cmd = shift @args; + for (@args) { + $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; + } + return join (' ', ($cmd, @args)); +} + +# code copied from CPAN::HandleConfig::safe_quote +# - that has doc saying leave if start/finish with same quote, but no code +# given text, will conditionally quote it to protect from shell +{ + my ($quote, $use_quote) = $^O eq 'MSWin32' + ? (q{"}, q{"}) + : (q{"'}, q{'}); + sub _safe_quote { + my ($self, $command) = @_; + # Set up quote/default quote + if (defined($command) + and $command =~ /\s/ + and $command !~ /[$quote]/) { + return qq{$use_quote$command$use_quote} + } + return $command; + } +} + +sub INCLUDE_COMMAND_handler { + my $self = shift; + $_ = shift; + # the rest of the current line should contain a valid command + + trim_whitespace($_); + + $_ = QuoteArgs($_) if $^O eq 'VMS'; + + $self->death("INCLUDE_COMMAND: command missing") + unless $_; + + $self->death("INCLUDE_COMMAND: pipes are illegal") + if /^\s*\|/ or /\|\s*$/; + + $self->PushXSStack( IsPipe => 1 ); + + $self->{FH} = Symbol::gensym(); + + # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be + # the same perl interpreter as we're currently running + my $X = $self->_safe_quote($^X); # quotes if has spaces + s/^\s*\$\^X/$X/; + + # open the new file + open ($self->{FH}, "-|", $_) + or $self->death( $self, "Cannot run command '$_' to include its output: $!"); + + print Q(<<"EOF"); +# +#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ +# +EOF + + $self->{filename} = $_; + $self->{filepathname} = $self->{filename}; + #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 + $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 + + # Prime the pump by reading the first + # non-blank line + + # skip leading blank lines + while (readline($self->{FH})) { + last unless /^\s*$/; + } + + $self->{lastline} = $_; + $self->{lastline_no} = $.; +} + +sub PopFile { + my $self = shift; + + return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; + + my $data = pop @{ $self->{XSStack} }; + my $ThisFile = $self->{filename}; + my $isPipe = $data->{IsPipe}; + + --$self->{IncludedFiles}->{$self->{filename}} + unless $isPipe; + + close $self->{FH}; + + $self->{FH} = $data->{Handle}; + # $filename is the leafname, which for some reason is used for diagnostic + # messages, whereas $filepathname is the full pathname, and is used for + # #line directives. + $self->{filename} = $data->{Filename}; + $self->{filepathname} = $data->{Filepathname}; + $self->{lastline} = $data->{LastLine}; + $self->{lastline_no} = $data->{LastLineNo}; + @{ $self->{line} } = @{ $data->{Line} }; + @{ $self->{line_no} } = @{ $data->{LineNo} }; + + if ($isPipe and $? ) { + --$self->{lastline_no}; + print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; + exit 1; + } + + print Q(<<"EOF"); +# +#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ +# +EOF + + return 1; +} + +sub Q { + my($text) = @_; + $text =~ s/^#//gm; + $text =~ s/\[\[/{/g; + $text =~ s/\]\]/}/g; + $text; +} + +# Process "MODULE = Foo ..." lines and update global state accordingly +sub _process_module_xs_line { + my ($self, $module, $pkg, $prefix) = @_; + + ($self->{Module_cname} = $module) =~ s/\W/_/g; + + $self->{Package} = defined($pkg) ? $pkg : ''; + $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); + + ($self->{Packid} = $self->{Package}) =~ tr/:/_/; + + $self->{Packprefix} = $self->{Package}; + $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; + + $self->{lastline} = ""; +} + +# Skip any embedded POD sections +sub _maybe_skip_pod { + my ($self) = @_; + + while ($self->{lastline} =~ /^=/) { + while ($self->{lastline} = readline($self->{FH})) { + last if ($self->{lastline} =~ /^=cut\s*$/); + } + $self->death("Error: Unterminated pod") unless defined $self->{lastline}; + $self->{lastline} = readline($self->{FH}); + chomp $self->{lastline}; + $self->{lastline} =~ s/^\s+$//; + } +} + +# This chunk of code strips out (and parses) embedded TYPEMAP blocks +# which support a HEREdoc-alike block syntax. +sub _maybe_parse_typemap_block { + my ($self) = @_; + + # This is special cased from the usual paragraph-handler logic + # due to the HEREdoc-ish syntax. + if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) + { + my $end_marker = quotemeta(defined($1) ? $2 : $3); + + # Scan until we find $end_marker alone on a line. + my @tmaplines; + while (1) { + $self->{lastline} = readline($self->{FH}); + $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; + last if $self->{lastline} =~ /^$end_marker\s*$/; + push @tmaplines, $self->{lastline}; + } + + my $tmap = ExtUtils::Typemaps->new( + string => join("", @tmaplines), + lineno_offset => 1 + ($self->current_line_number() || 0), + fake_filename => $self->{filename}, + ); + $self->{typemap}->merge(typemap => $tmap, replace => 1); + + $self->{lastline} = ""; + } +} + +# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). +sub fetch_para { + my $self = shift; + + # parse paragraph + $self->death("Error: Unterminated '#if/#ifdef/#ifndef'") + if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; + @{ $self->{line} } = (); + @{ $self->{line_no} } = (); + return $self->PopFile() if not defined $self->{lastline}; # EOF + + if ($self->{lastline} =~ + /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) + { + $self->_process_module_xs_line($1, $2, $3); + } + + for (;;) { + $self->_maybe_skip_pod; + + $self->_maybe_parse_typemap_block; + + if ($self->{lastline} !~ /^\s*#/ # not a CPP directive + # CPP directives: + # ANSI: if ifdef ifndef elif else endif define undef + # line error pragma + # gcc: warning include_next + # obj-c: import + # others: ident (gcc notes that some cpps have this one) + || $self->{lastline} =~ /^\#[ \t]* + (?: + (?:if|ifn?def|elif|else|endif| + define|undef|pragma|error| + warning|line\s+\d+|ident) + \b + | (?:include(?:_next)?|import) + \s* ["<] .* [>"] + ) + /x + ) + { + last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; + push(@{ $self->{line} }, $self->{lastline}); + push(@{ $self->{line_no} }, $self->{lastline_no}); + } + + # Read next line and continuation lines + last unless defined($self->{lastline} = readline($self->{FH})); + $self->{lastline_no} = $.; + my $tmp_line; + $self->{lastline} .= $tmp_line + while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); + + chomp $self->{lastline}; + $self->{lastline} =~ s/^\s+$//; + } + + # Nuke trailing "line" entries until there's one that's not empty + pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) + while @{ $self->{line} } && $self->{line}->[-1] eq ""; + + return 1; +} + +sub output_init { + my $self = shift; + my $argsref = shift; + + my ($type, $num, $var, $init, $printed_name) + = @{$argsref}{qw(type num var init printed_name)}; + + # local assign for efficiently passing in to eval_input_typemap_code + local $argsref->{arg} = $num + ? "ST(" . ($num-1) . ")" + : "/* not a parameter */"; + + if ( $init =~ /^=/ ) { + if ($printed_name) { + $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); + } + else { + $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); + } + } + else { + if ( $init =~ s/^\+// && $num ) { + $self->generate_init( { + type => $type, + num => $num, + var => $var, + printed_name => $printed_name, + } ); + } + elsif ($printed_name) { + print ";\n"; + $init =~ s/^;//; + } + else { + $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); + $init =~ s/^;//; + } + $self->{deferred} + .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); + } +} + +sub generate_init { + my $self = shift; + my $argsref = shift; + + my ($type, $num, $var, $printed_name) + = @{$argsref}{qw(type num var printed_name)}; + + my $argoff = $num - 1; + my $arg = "ST($argoff)"; + + my $typemaps = $self->{typemap}; + + $type = ExtUtils::Typemaps::tidy_type($type); + if (not $typemaps->get_typemap(ctype => $type)) { + $self->report_typemap_failure($typemaps, $type); + return; + } + + (my $ntype = $type) =~ s/\s*\*/Ptr/g; + (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; + + my $typem = $typemaps->get_typemap(ctype => $type); + my $xstype = $typem->xstype; + #this is an optimization from perl 5.0 alpha 6, class check is skipped + #T_REF_IV_REF is missing since it has no untyped analog at the moment + $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ + if $self->{func_name} =~ /DESTROY$/; + if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { + print "\t$var" unless $printed_name; + print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; + die "default value not supported with length(NAME) supplied" + if defined $self->{defaults}->{$var}; + return; + } + $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; + + my $inputmap = $typemaps->get_inputmap(xstype => $xstype); + if (not defined $inputmap) { + $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); + return; + } + + my $expr = $inputmap->cleaned_code; + # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen + if ($expr =~ /DO_ARRAY_ELEM/) { + my $subtypemap = $typemaps->get_typemap(ctype => $subtype); + if (not $subtypemap) { + $self->report_typemap_failure($typemaps, $subtype); + return; + } + + my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); + if (not $subinputmap) { + $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); + return; + } + + my $subexpr = $subinputmap->cleaned_code; + $subexpr =~ s/\$type/\$subtype/g; + $subexpr =~ s/ntype/subtype/g; + $subexpr =~ s/\$arg/ST(ix_$var)/g; + $subexpr =~ s/\n\t/\n\t\t/g; + $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; + $subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/; + $expr =~ s/DO_ARRAY_ELEM/$subexpr/; + } + if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments + $self->{ScopeThisXSUB} = 1; + } + + my $eval_vars = { + var => $var, + printed_name => $printed_name, + type => $type, + ntype => $ntype, + subtype => $subtype, + num => $num, + arg => $arg, + argoff => $argoff, + }; + + if (defined($self->{defaults}->{$var})) { + $expr =~ s/(\t+)/$1 /g; + $expr =~ s/ /\t/g; + if ($printed_name) { + print ";\n"; + } + else { + $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); + } + if ($self->{defaults}->{$var} eq 'NO_INIT') { + $self->{deferred} .= $self->eval_input_typemap_code( + qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, + $eval_vars + ); + } + else { + $self->{deferred} .= $self->eval_input_typemap_code( + qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, + $eval_vars + ); + } + } + elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { + if ($printed_name) { + print ";\n"; + } + else { + $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); + } + $self->{deferred} + .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); + } + else { + die "panic: do not know how to handle this branch for function pointers" + if $printed_name; + $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); + } +} + +sub generate_output { + my $self = shift; + my $argsref = shift; + my ($type, $num, $var, $do_setmagic, $do_push) + = @{$argsref}{qw(type num var do_setmagic do_push)}; + + my $arg = "ST(" . ($num - ($num != 0)) . ")"; + + my $typemaps = $self->{typemap}; + + $type = ExtUtils::Typemaps::tidy_type($type); + local $argsref->{type} = $type; + + if ($type =~ /^array\(([^,]*),(.*)\)/) { + print "\t$arg = sv_newmortal();\n"; + print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; + } + else { + my $typemap = $typemaps->get_typemap(ctype => $type); + if (not $typemap) { + $self->report_typemap_failure($typemaps, $type); + return; + } + + my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); + if (not $outputmap) { + $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); + return; + } + + (my $ntype = $type) =~ s/\s*\*/Ptr/g; + $ntype =~ s/\(\)//g; + (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; + + my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; + my $expr = $outputmap->cleaned_code; + if ($expr =~ /DO_ARRAY_ELEM/) { + my $subtypemap = $typemaps->get_typemap(ctype => $subtype); + if (not $subtypemap) { + $self->report_typemap_failure($typemaps, $subtype); + return; + } + + my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); + if (not $suboutputmap) { + $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); + return; + } + + my $subexpr = $suboutputmap->cleaned_code; + $subexpr =~ s/ntype/subtype/g; + $subexpr =~ s/\$arg/ST(ix_$var)/g; + $subexpr =~ s/\$var/${var}\[ix_$var]/g; + $subexpr =~ s/\n\t/\n\t\t/g; + $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; + $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); + print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; + } + elsif ($var eq 'RETVAL') { + my $orig_arg = $arg; + my $indent; + my $use_RETVALSV = 1; + my $do_mortal = 0; + my $do_copy_tmp = 1; + my $pre_expr; + local $eval_vars->{arg} = $arg = 'RETVALSV'; + my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); + + if ($expr =~ /^\t\Q$arg\E = new/) { + # We expect that $arg has refcnt 1, so we need to + # mortalize it. + $do_mortal = 1; + } + # If RETVAL is immortal, don't mortalize it. This code is not perfect: + # It won't detect a func or expression that only returns immortals, for + # example, this RE must be tried before next elsif. + elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { + $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV + $use_RETVALSV = 0; + } + elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { + # We expect that $arg has refcnt >=1, so we need + # to mortalize it! + $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block + $do_mortal = 1; + } + else { + # Just hope that the entry would safely write it + # over an already mortalized value. By + # coincidence, something like $arg = &PL_sv_undef + # works too, but should be caught above. + $pre_expr = "RETVALSV = sv_newmortal();\n"; + # new mortals don't have set magic + $do_setmagic = 0; + } + if($use_RETVALSV) { + print "\t{\n\t SV * RETVALSV;\n"; + $indent = "\t "; + } else { + $indent = "\t"; + } + print $indent.$pre_expr if $pre_expr; + + if($use_RETVALSV) { + #take control of 1 layer of indent, may or may not indent more + $evalexpr =~ s/^(\t| )/$indent/gm; + #"\t \t" doesn't draw right in some IDEs + #break down all \t into spaces + $evalexpr =~ s/\t/ /g; + #rebuild back into \t'es, \t==8 spaces, indent==4 spaces + $evalexpr =~ s/ /\t/g; + } + else { + if($do_mortal || $do_setmagic) { + #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace + $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code + } + else { #if no extra boilerplate (no mortal, no set magic) is needed + #after $evalexport, get rid of RETVALSV's visual cluter and change + $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) + } + } + #stop " RETVAL = RETVAL;" for SVPtr type + print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; + print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') + .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; + print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; + #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter + print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" + if $do_mortal || $do_setmagic || $do_copy_tmp; + print "\t}\n" if $use_RETVALSV; + } + elsif ($do_push) { + print "\tPUSHs(sv_newmortal());\n"; + local $eval_vars->{arg} = "ST($num)"; + $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; + } + elsif ($arg =~ /^ST\(\d+\)$/) { + $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); + print "\tSvSETMAGIC($arg);\n" if $do_setmagic; + } + } +} + + +# Just delegates to a clean package. +# Shim to evaluate Perl code in the right variable context +# for typemap code (having things such as $ALIAS set up). +sub eval_output_typemap_code { + my ($self, $code, $other) = @_; + return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); +} + +sub eval_input_typemap_code { + my ($self, $code, $other) = @_; + return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); +} + +1; + +# vim: ts=2 sw=2 et: +package ExtUtils::MM_VMS; + +use strict; + +use ExtUtils::MakeMaker::Config; +require Exporter; + +BEGIN { + # so we can compile the thing on non-VMS platforms. + if( $^O eq 'VMS' ) { + require VMS::Filespec; + VMS::Filespec->import; + } +} + +use File::Basename; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::MM_Any; +require ExtUtils::MM_Unix; +our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + +use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); +our $Revision = $ExtUtils::MakeMaker::Revision; + + + +sub wraplist { + my($self) = shift; + my($line,$hlen) = ('',0); + + foreach my $word (@_) { + # Perl bug -- seems to occasionally insert extra elements when + # traversing array (scalar(@array) doesn't show them, but + # foreach(@array) does) (5.00307) + next unless $word =~ /\w/; + $line .= ' ' if length($line); + if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } + $line .= $word; + $hlen += length($word) + 2; + } + $line; +} + + +# This isn't really an override. It's just here because ExtUtils::MM_VMS +# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() +# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just +# mimic inheritance here and hand off to ExtUtils::Liblist::Kid. +# XXX This hackery will die soon. --Schwern +sub ext { + require ExtUtils::Liblist::Kid; + goto &ExtUtils::Liblist::Kid::ext; +} + + +sub guess_name { + my($self) = @_; + my($defname,$defpm,@pm,%xs); + local *PM; + + $defname = basename(fileify($ENV{'DEFAULT'})); + $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version + $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = glob('*.pm'); + s/.pm$// for @pm; + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic + if (keys %xs) { + foreach my $pm (@pm) { + $defpm = $pm, last if exists $xs{$pm}; + } + } + } + } + if (open(my $pm, '<', "${defpm}.pm")){ + while (<$pm>) { + if (/^\s*package\s+([^;]+)/i) { + $defname = $1; + last; + } + } + print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", + "defaulting package name to $defname\n" + if eof($pm); + close $pm; + } + else { + print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", + "defaulting package name to $defname\n"; + } + $defname =~ s#[\d.\-_]+$##; + $defname; +} + + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + my($vmsfile,@sdirs,@snames,@cand); + my($rslt); + my($inabs) = 0; + local *TCF; + + if( $self->{PERL_CORE} ) { + # Check in relative directories first, so we pick up the current + # version of Perl if we're running MakeMaker as part of the main build. + @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); + my($absb) = $self->file_name_is_absolute($b); + if ($absa && $absb) { return $a cmp $b } + else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } + } @$dirs; + # Check miniperl before perl, and check names likely to contain + # version numbers before "generic" names, so we pick up an + # executable that's less likely to be from an old installation. + @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename + my($bb) = $b =~ m!([^:>\]/]+)$!; + my($ahasdir) = (length($a) - length($ba) > 0); + my($bhasdir) = (length($b) - length($bb) > 0); + if ($ahasdir and not $bhasdir) { return 1; } + elsif ($bhasdir and not $ahasdir) { return -1; } + else { $bb =~ /\d/ <=> $ba =~ /\d/ + or substr($ba,0,1) cmp substr($bb,0,1) + or length($bb) <=> length($ba) } } @$names; + } + else { + @sdirs = @$dirs; + @snames = @$names; + } + + # Image names containing Perl version use '_' instead of '.' under VMS + s/\.(\d+)$/_$1/ for @snames; + if ($trace >= 2){ + print "Looking for perl $ver by these names:\n"; + print "\t@snames,\n"; + print "in these dirs:\n"; + print "\t@sdirs\n"; + } + foreach my $dir (@sdirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + $inabs++ if $self->file_name_is_absolute($dir); + if ($inabs == 1) { + # We've covered relative dirs; everything else is an absolute + # dir (probably an installed location). First, we'll try + # potential command names, to see whether we can avoid a long + # MCR expression. + foreach my $name (@snames) { + push(@cand,$name) if $name =~ /^[\w\-\$]+$/; + } + $inabs++; # Should happen above in next $dir, but just in case... + } + foreach my $name (@snames){ + push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name) + : $self->fixpath($name,0); + } + } + foreach my $name (@cand) { + print "Checking $name\n" if $trace >= 2; + # If it looks like a potential command, try it without the MCR + if ($name =~ /^[\w\-\$]+$/) { + open(my $tcf, ">", "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; + close $tcf; + $rslt = `\@temp_mmvms.com` ; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=$name\n" if $trace; + return $name; + } + } + next unless $vmsfile = $self->maybe_command($name); + $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well + print "Executing $vmsfile\n" if ($trace >= 2); + open(my $tcf, '>', "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; + close $tcf; + $rslt = `\@temp_mmvms.com`; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=MCR $vmsfile\n" if $trace; + return "MCR $vmsfile"; + } + } + print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + +sub _fixin_replace_shebang { + my ( $self, $file, $line ) = @_; + + my ( undef, $arg ) = split ' ', $line, 2; + + return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n"; +} + + +sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d _; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + + if ($file !~ m![/:>\]]!) { + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + my $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach my $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach my $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } + } + return 0; +} + + + +sub pasthru { + my($self) = shift; + my $pasthru = $self->SUPER::pasthru; + $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|; + $pasthru =~ s|\n\z|)\n|m; + $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig; + + return $pasthru; +} + + + +sub pm_to_blib { + my $self = shift; + + my $make = $self->SUPER::pm_to_blib; + + $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m; + $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts}; + + $make = <<'MAKE' . $make; +# Dummy target to match Unix target name; we use pm_to_blib.ts as +# timestamp file to avoid repeated invocations under VMS +pm_to_blib : pm_to_blib.ts + $(NOECHO) $(NOOP) + +MAKE + + return $make; +} + + + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && ! -d _; + return "$file.com" if -r "$file.com"; + return "$file.pl" if -r "$file.pl"; + return ''; +} + + + +sub replace_manpage_separator { + my($self,$man) = @_; + $man = unixify($man); + $man =~ s#/+#__#g; + $man; +} + + +sub init_DEST { + my $self = shift; + + $self->SUPER::init_DEST; + + # Expand DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} = $self->eliminate_macros($self->{$destvar}); + } +} + + + +sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = ''; + return 1; +} + + + +sub init_main { + my($self) = shift; + + $self->SUPER::init_main; + + $self->{DEFINE} ||= ''; + if ($self->{DEFINE} ne '') { + my(@terms) = split(/\s+/,$self->{DEFINE}); + my(@defs,@udefs); + foreach my $def (@terms) { + next unless $def; + my $targ = \@defs; + if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition + $targ = \@udefs if $1 eq 'U'; + $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' + $def =~ s/^'(.*)'$/$1/; # from entire term or argument + } + if ($def =~ /=/) { + $def =~ s/"/""/g; # Protect existing " from DCL + $def = qq["$def"]; # and quote to prevent parsing of = + } + push @$targ, $def; + } + + $self->{DEFINE} = ''; + if (@defs) { + $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; + } + if (@udefs) { + $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; + } + } +} + + +sub init_tools { + my($self) = @_; + + $self->{NOOP} = 'Continue'; + $self->{NOECHO} ||= '@ '; + + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS'; + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; + $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; + $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old'); +# +# If an extension is not specified, then MMS/MMK assumes an +# an extension of .MMS. If there really is no extension, +# then a trailing "." needs to be appended to specify a +# a null extension. +# + $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./; + $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./; + $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./; + $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./; + + $self->{MACROSTART} ||= '/Macro=('; + $self->{MACROEND} ||= ')'; + $self->{USEMAKEFILE} ||= '/Descrip='; + + $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"'; + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); +install([ from_to => {split('\|', )}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); +CODE + + $self->{UMASK_NULL} = '! '; + + $self->SUPER::init_tools; + + # Use the default shell + $self->{SHELL} ||= 'Posix'; + + # Redirection on VMS goes before the command, not after as on Unix. + # $(DEV_NULL) is used once and its not worth going nuts over making + # it work. However, Unix's DEV_NULL is quite wrong for VMS. + $self->{DEV_NULL} = ''; + + return; +} + + +sub init_platform { + my($self) = shift; + + $self->{MM_VMS_REVISION} = $Revision; + $self->{MM_VMS_VERSION} = $VERSION; + $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS') + if $self->{PERL_SRC}; +} + + + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + + +sub init_VERSION { + my $self = shift; + + $self->SUPER::init_VERSION; + + $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""'; + $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'; + $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'}); +} + + + +sub constants { + my($self) = @_; + + # Be kind about case for pollution + for (@ARGV) { $_ = uc($_) if /POLLUTE/i; } + + # Cleanup paths for directories in MMS macros. + foreach my $macro ( qw [ + INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB + PERL_LIB PERL_ARCHLIB + PERL_INC PERL_SRC ], + (map { 'INSTALL'.$_ } $self->installvars) + ) + { + next unless defined $self->{$macro}; + next if $macro =~ /MAN/ && $self->{$macro} eq 'none'; + $self->{$macro} = $self->fixpath($self->{$macro},1); + } + + # Cleanup paths for files in MMS macros. + foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD + MAKE_APERL_FILE MYEXTLIB] ) + { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + # Fixup files for MMS macros + # XXX is this list complete? + for my $macro (qw/ + FULLEXT VERSION_FROM + / ) { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + + for my $macro (qw/ + OBJECT LDFROM + / ) { + next unless defined $self->{$macro}; + + # Must expand macros before splitting on unescaped whitespace. + $self->{$macro} = $self->eliminate_macros($self->{$macro}); + if ($self->{$macro} =~ /(?{$macro} =~ s/(\\)?\n+\s+/ /g; + $self->{$macro} = $self->wraplist( + map $self->fixpath($_,0), split /,?(?{$macro} + ); + } + else { + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + } + + for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) { + # Where is the space coming from? --jhi + next unless $self ne " " && defined $self->{$macro}; + my %tmp = (); + for my $key (keys %{$self->{$macro}}) { + $tmp{$self->fixpath($key,0)} = + $self->fixpath($self->{$macro}{$key},0); + } + $self->{$macro} = \%tmp; + } + + for my $macro (qw/ C O_FILES H /) { + next unless defined $self->{$macro}; + my @tmp = (); + for my $val (@{$self->{$macro}}) { + push(@tmp,$self->fixpath($val,0)); + } + $self->{$macro} = \@tmp; + } + + # mms/k does not define a $(MAKE) macro. + $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)'; + + return $self->SUPER::constants; +} + + + +sub special_targets { + my $self = shift; + + my $make_frag .= <<'MAKE_FRAG'; +.SUFFIXES : +.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs + +MAKE_FRAG + + return $make_frag; +} + + +sub cflags { + my($self,$libperl) = @_; + my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; + my($definestr,$undefstr,$flagoptstr) = ('','',''); + my($incstr) = '/Include=($(PERL_INC)'; + my($name,$sys,@m); + + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. + " required to modify CC command for $self->{'BASEEXT'}\n" + if ($Config{$name}); + + if ($quals =~ / -[DIUOg]/) { + while ($quals =~ / -([Og])(\d*)\b/) { + my($type,$lvl) = ($1,$2); + $quals =~ s/ -$type$lvl\b\s*//; + if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } + else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } + } + while ($quals =~ / -([DIU])(\S+)/) { + my($type,$def) = ($1,$2); + $quals =~ s/ -$type$def\s*//; + $def =~ s/"/""/g; + if ($type eq 'D') { $definestr .= qq["$def",]; } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } + else { $undefstr .= qq["$def",]; } + } + } + if (length $quals and $quals !~ m!/!) { + warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; + $quals = ''; + } + $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE}; + if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } + if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } + # Deal with $self->{DEFINE} here since some C compilers pay attention + # to only one /Define clause on command line, so we have to + # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} + # ($self->{DEFINE} has already been VMSified in constants() above) + if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } + for my $type (qw(Def Undef)) { + my(@terms); + while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { + my $term = $1; + $term =~ s:^\((.+)\)$:$1:; + push @terms, $term; + } + if ($type eq 'Def') { + push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ]; + } + if (@terms) { + $quals =~ s:/${type}i?n?e?=[^/]+::ig; + # PASTHRU_DEFINE will have its own comma + $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')'; + } + } + + $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; + + # Likewise with $self->{INC} and /Include + if ($self->{'INC'}) { + my(@includes) = split(/\s+/,$self->{INC}); + foreach (@includes) { + s/^-I//; + $incstr .= ','.$self->fixpath($_,1); + } + } + $quals .= "$incstr)"; +# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g; + $self->{CCFLAGS} = $quals; + + $self->{PERLTYPE} ||= ''; + + $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; + if ($self->{OPTIMIZE} !~ m!/!) { + if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } + elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { + $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); + } + else { + warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; + $self->{OPTIMIZE} = '/Optimize'; + } + } + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +}; +} + + +sub const_cccmd { + my($self,$libperl) = @_; + my(@m); + + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + if ($Config{'vms_cc_type'} eq 'gcc') { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]'; + } + elsif ($Config{'vms_cc_type'} eq 'vaxc') { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include'; + } + else { + push @m,' +.FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ', + ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),' + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include'; + } + + push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n"); + + $self->{CONST_CCCMD} = join('',@m); +} + + + +sub tools_other { + my($self) = @_; + + # XXX Are these necessary? Does anyone override them? They're longer + # than just typing the literal string. + my $extra_tools = <<'EXTRA_TOOLS'; + +# Just in case anyone is using the old macro. +USEMACROS = $(MACROSTART) +SAY = $(ECHO) + +EXTRA_TOOLS + + return $self->SUPER::tools_other . $extra_tools; +} + + +sub init_dist { + my($self) = @_; + $self->{ZIPFLAGS} ||= '-Vu'; + $self->{COMPRESS} ||= 'gzip'; + $self->{SUFFIX} ||= '-gz'; + $self->{SHAR} ||= 'vms_share'; + $self->{DIST_DEFAULT} ||= 'zipdist'; + + $self->SUPER::init_dist; + + $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}" + unless $self->{ARGS}{DISTVNAME}; + + return; +} + + +sub c_o { + my($self) = @_; + return '' unless $self->needs_linking(); + ' +.c$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + +.cpp$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + +.cxx$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + +'; +} + + +sub xs_c { + my($self) = @_; + return '' unless $self->needs_linking(); + ' +.xs.c : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c +'; +} + + +sub xs_o { + my ($self) = @_; + return '' unless $self->needs_linking(); + my $frag = ' +.xs$(OBJ_EXT) : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) +'; + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my $version = $self->parse_version("$ext.pm"); + my $ccflags = $self->{CCFLAGS}; + $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/; + $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/; + $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC'); + $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE'); + + $frag .= _sprintf562 <<'EOF', $ext, $ccflags; + +%1$s$(OBJ_EXT) : %1$s.xs + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c + $(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) +EOF + } + } + $frag; +} + + +sub _xsbuild_replace_macro { + my ($self, undef, $xstype, $ext, $varname) = @_; + my $value = $self->_xsbuild_value($xstype, $ext, $varname); + return unless defined $value; + $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname); +} + + +sub _xsbuild_value { + my ($self, $xstype, $ext, $varname) = @_; + $ext = unixify($ext); + return $self->SUPER::_xsbuild_value($xstype, $ext, $varname); +} + +sub _vms_replace_qualifier { + my ($self, $flags, $newflag, $macro) = @_; + my $qual_type; + my $type_suffix; + my $quote_subquals = 0; + my @subquals_new = split /\s+/, $newflag; + + if ($macro eq 'DEFINE') { + $qual_type = 'Def'; + $type_suffix = 'ine'; + map { $_ =~ s/^-D// } @subquals_new; + $quote_subquals = 1; + } + elsif ($macro eq 'INC') { + $qual_type = 'Inc'; + $type_suffix = 'lude'; + map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new; + } + + my @subquals = (); + while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) { + my $term = $1; + $term =~ s/\"//g; + $term =~ s:^\((.+)\)$:$1:; + push @subquals, split /,/, $term; + } + for my $new (@subquals_new) { + my ($sq_new, $sqval_new) = split /=/, $new; + my $replaced_old = 0; + for my $old (@subquals) { + my ($sq, $sqval) = split /=/, $old; + if ($sq_new eq $sq) { + $old = $sq_new; + $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new); + $replaced_old = 1; + last; + } + } + push @subquals, $new unless $replaced_old; + } + + if (@subquals) { + $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig; + # add quotes if requested but not for unexpanded macros + map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals; + $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')'; + } + + return $flags; +} + + +sub xs_dlsyms_ext { + '.opt'; +} + + +sub dlsyms { + my ($self, %attribs) = @_; + return '' unless $self->needs_linking; + $self->xs_dlsyms_iterator; +} + +sub xs_make_dlsyms { + my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; + my @m; + my $instloc; + if ($self->{XSMULTI}) { + my ($v, $d, $f) = File::Spec->splitpath($target); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f); + push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'dynamic'}; + push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'static'}; + push @m, "\n", sprintf <<'EOF', $instloc, $target; +%s : %s + $(CP) $(MMS$SOURCE) $(MMS$TARGET) +EOF + } + else { + push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'dynamic'}; + push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'static'}; + push @m, "\n", sprintf <<'EOF', $target; +$(INST_ARCHAUTODIR)$(BASEEXT).opt : %s + $(CP) $(MMS$SOURCE) $(MMS$TARGET) +EOF + } + push @m, + "\n$target : $dep\n\t", + q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name, + q!', 'DLBASE' => '!,$dlbase, + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars); + push @m, $extra if defined $extra; + push @m, qq!);"\n\t!; + # Can't use dlbase as it's been through mod2fname. + my $olb_base = basename($target, '.opt'); + if ($self->{XSMULTI}) { + # We've been passed everything but the kitchen sink -- and the location of the + # static library we're using to build the dynamic library -- so concoct that + # location from what we do have. + my $olb_dir = $self->catdir(dirname($instloc), $olb_base); + push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!; + push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base); + push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"; + } + else { + push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!; + if ($self->{OBJECT} =~ /\bBASEEXT\b/ or + $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { + push @m, ($Config{d_vms_case_sensitive_symbols} + ? uc($self->{BASEEXT}) :'$(BASEEXT)'); + } + else { # We don't have a "main" object file, so pull 'em all in + # Upcase module names if linker is being case-sensitive + my($upcase) = $Config{d_vms_case_sensitive_symbols}; + my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT}); + for (@omods) { + s/\.[^.]*$//; # Trim off file type + s[\$\(\w+_EXT\)][]; # even as a macro + s/.*[:>\/\]]//; # Trim off dir spec + $_ = uc if $upcase; + }; + my(@lines); + my $tmp = shift @omods; + foreach my $elt (@omods) { + $tmp .= ",$elt"; + if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } + } + push @lines, $tmp; + push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')'; + } + push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"; + } + if (length $self->{LDLOADLIBS}) { + my($line) = ''; + foreach my $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; + } + join '', @m; +} + + + +sub xs_obj_opt { + my ($self, $output_file) = @_; + "/OBJECT=$output_file"; +} + + +sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; +# This section creates the dynamically loadable objects from relevant +# objects and possibly $(MYEXTLIB). +OTHERLDFLAGS = %s +INST_DYNAMIC_DEP = %s +EOF +} + +sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my $shr = $Config{'dbgprefix'} . 'PerlShr'; + $exportlist =~ s/.def$/.opt/; # it's a linker options file + # 1 2 3 4 5 + _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}"; +%1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) + If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s + Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option +EOF +} + + +sub xs_make_static_lib { + my ($self, $object, $to, $todir) = @_; + + my @objects; + if ($self->{XSMULTI}) { + # The extension name should be the main object file name minus file type. + my $lib = $object; + $lib =~ s/\$\(OBJ_EXT\)\z//; + my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT'); + $object = $override if defined $override; + @objects = map { $self->fixpath($_,0) } split /(?{MYEXTLIB}; + + push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); + + # if there was a library to copy, then we can't use MMS$SOURCE_LIST, + # 'cause it's a library and you can't stick them in other libraries. + # In that case, we use $OBJECT instead and hope for the best + if ($self->{MYEXTLIB}) { + for my $obj (@objects) { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n"); + } + } + else { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); + } + + push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; + foreach my $lib (split ' ', $self->{EXTRALIBS}) { + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } + join('',@m); +} + + + +sub static_lib_pure_cmd { + my ($self, $from) = @_; + + sprintf <<'MAKE_FRAG', $from; + If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) + Library/Object/Replace $(MMS$TARGET) %s +MAKE_FRAG +} + + +sub xs_static_lib_is_xs { + return 1; +} + + +sub extra_clean_files { + return qw( + *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso + .MM_Tmp cxx_repository + ); +} + + + +sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + +sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) +MAKE_FRAG +} + +sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +shdist : distdir + $(PREOP) + $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share + $(RM_RF) $(DISTVNAME) + $(POSTOP) +MAKE_FRAG +} + + +# --- Test and Installation Sections --- + + +sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q[ +install :: all pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: all pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: all pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +install_vendor :: all pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +doc__install : doc_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + +# This hack brought to you by DCL's 255-character command line limit +pure_perl_install :: +]; + push @m, +q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp +] unless $self->{NO_PACKLIST}; + + push @m, +q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLPRIVLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLARCHLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[" + +# Likewise +pure_site_install :: +]; + push @m, +q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp +] unless $self->{NO_PACKLIST}; + + push @m, +q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLSITELIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLSITEARCH)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLSITEBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLSITEMAN1DIR)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLSITEMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[" + +pure_vendor_install :: +]; + push @m, +q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp +] unless $self->{NO_PACKLIST}; + + push @m, +q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLVENDORLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLVENDORARCH)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLVENDORBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLVENDORMAN1DIR)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLVENDORMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + +]; + + push @m, q[ +# Ditto +doc_perl_install :: + $(NOECHO) $(NOOP) + +# And again +doc_site_install :: + $(NOECHO) $(NOOP) + +doc_vendor_install :: + $(NOECHO) $(NOOP) + +] if $self->{NO_PERLLOCAL}; + + push @m, q[ +# Ditto +doc_perl_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +# And again +doc_site_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +doc_vendor_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + +] unless $self->{NO_PERLLOCAL}; + + push @m, q[ +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ + +uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ +]; + + join('',@m); +} + + +sub perldepend { + my($self) = @_; + my(@m); + + if ($self->{OBJECT}) { + # Need to add an object file dependency on the perl headers. + # this is very important for XS modules in perl.git development. + + push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC) + } + + if ($self->{PERL_SRC}) { + my(@macros); + my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)'; + push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP'; + push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc'; + push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc'; + push(@macros,'SOCKET=1') if $Config{'d_has_sockets'}; + push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!; + $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros; + push(@m,q[ +# Check for unpropagated config.sh changes. Should never happen. +# We do NOT just update config.h because that is not sufficient. +# An out of date config.h is not fatal but complains loudly! +$(PERL_INC)config.h : $(PERL_SRC)config.sh + $(NOOP) + +$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh + $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" + olddef = F$Environment("Default") + Set Default $(PERL_SRC) + $(MMS)],$mmsquals,); + if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); + $target =~ s/\Q$prefix/[/; + push(@m," $target"); + } + else { push(@m,' $(MMS$TARGET)'); } + push(@m,q[ + Set Default 'olddef' +]); + } + + push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + if %{$self->{XS}}; + + join('',@m); +} + + + +our %olbs; # needs to be localized + +sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + my(@m); + push @m, " +# --- MakeMaker makeaperl section --- +MAP_TARGET = $target +"; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) + $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR=}, $dir, q{ \ + FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 }; + + push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{ + +$(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) +}; + push @m, "\n"; + + return join '', @m; + } + + + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); + + # The front matter of the linkcommand... + $linkcmd = join ' ', $Config{'ld'}, + grep($_, @Config{qw(large split ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + + # Which *.olb files could we make use of... + local(%olbs); # XXX can this be lexical? + $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; + require File::Find; + File::Find::find(sub { + return unless m/\Q$self->{LIB_EXT}\E$/; + return if m/^libperl/; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + $olbs{$ENV{DEFAULT}} = $_; + }, grep( -d $_, @{$searchdirs || []})); + + # We trust that what has been handed in as argument will be buildable + $static = [] unless $static; + @olbs{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + # Sort the object libraries in inverse order of + # filespec length to try to insure that dependent extensions + # will appear before their parents, so the linker will + # search the parent library to resolve references. + # (e.g. Intuit::DWIM will precede Intuit, so unresolved + # references from [.intuit.dwim]dwim.obj can be found + # in [.intuit]intuit.olb). + for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) { + next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; + my($dir) = $self->fixpath($_,1); + my($extralibs) = $dir . "extralibs.ld"; + my($extopt) = $dir . $olbs{$_}; + $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need + if (-f $extralibs ) { + my %seenthis; + open my $list, "<", $extralibs or warn $!,next; + while (<$list>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } + } + # Get full name of extension for ExtUtils::Miniperl + if (-f $extopt) { + open my $opt, '<', $extopt or die $!; + while (<$opt>) { + next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; + my $pkg = $1; + $pkg =~ s#__*#::#g; + push @staticpkgs,$pkg; + } + } + } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; + + $target = "Perl$Config{'exe_ext'}" unless $target; + my $shrtarget; + ($shrtarget,$targdir) = fileparse($target); + $shrtarget =~ s/^([^.]*)/$1Shr/; + $shrtarget = $targdir . $shrtarget; + $target = "Perlshr.$Config{'dlext'}" unless $target; + $tmpdir = "[]" unless $tmpdir; + $tmpdir = $self->fixpath($tmpdir,1); + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; + if ($libperl) { + unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { + print "Warning: $libperl not found\n"; + undef $libperl; + } + } + unless ($libperl) { + if (defined $self->{PERL_SRC}) { + $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); + } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { + } else { + print "Warning: $libperl not found + If you're going to build a static perl binary, make sure perl is installed + otherwise ignore this warning\n"; + } + } + $libperldir = $self->fixpath((fileparse($libperl))[1],1); + + push @m, ' +# Fill in the target you want to produce if it\'s not perl +MAP_TARGET = ',$self->fixpath($target,0),' +MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," +MAP_LINKCMD = $linkcmd +MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," +MAP_EXTRA = $extralist +MAP_LIBPERL = ",$self->fixpath($libperl,0),' +'; + + + push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmpdir}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + + push @m,' +$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' +$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",' + $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option + $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say" + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" + $(NOECHO) $(ECHO) "To remove the intermediate files, say + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean" +'; + push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]; + } + + push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir; + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) %sWritemain.tmp +MAKE_FRAG + + push @m, q[ +# Still more from the 255-char line length limit +doc_inst_perl : + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp + $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp + $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp +]; + + push @m, " +inst_perl : pure_inst_perl doc_inst_perl + \$(NOECHO) \$(NOOP) + +pure_inst_perl : \$(MAP_TARGET) + $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," + $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," + +clean :: map_clean + \$(NOECHO) \$(NOOP) + +map_clean : + \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE) + \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET) +"; + + join '', @m; +} + + +# --- Output postprocessing section --- + + +sub maketext_filter { + my($self, $text) = @_; + + $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg; + return $text; +} + + +sub prefixify { + my($self, $var, $sprefix, $rprefix, $default) = @_; + + # Translate $(PERLPREFIX) to a real path. + $rprefix = $self->eliminate_macros($rprefix); + $rprefix = vmspath($rprefix) if $rprefix; + $sprefix = vmspath($sprefix) if $sprefix; + + $default = vmsify($default) + unless $default =~ /\[.*\]/; + + (my $var_no_install = $var) =~ s/^install//; + my $path = $self->{uc $var} || + $ExtUtils::MM_Unix::Config_Override{lc $var} || + $Config{lc $var} || $Config{lc $var_no_install}; + + if( !$path ) { + warn " no Config found for $var.\n" if $Verbose >= 2; + $path = $self->_prefixify_default($rprefix, $default); + } + elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) { + # do nothing if there's no prefix or if its relative + } + elsif( $sprefix eq $rprefix ) { + warn " no new prefix.\n" if $Verbose >= 2; + } + else { + + warn " prefixify $var => $path\n" if $Verbose >= 2; + warn " from $sprefix to $rprefix\n" if $Verbose >= 2; + + my($path_vol, $path_dirs) = $self->splitpath( $path ); + if( $path_vol eq $Config{vms_prefix}.':' ) { + warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2; + + $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; + $path = $self->_catprefix($rprefix, $path_dirs); + } + else { + $path = $self->_prefixify_default($rprefix, $default); + } + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; +} + + +sub _prefixify_default { + my($self, $rprefix, $default) = @_; + + warn " cannot prefix, using default.\n" if $Verbose >= 2; + + if( !$default ) { + warn "No default!\n" if $Verbose >= 1; + return; + } + if( !$rprefix ) { + warn "No replacement prefix!\n" if $Verbose >= 1; + return ''; + } + + return $self->_catprefix($rprefix, $default); +} + +sub _catprefix { + my($self, $rprefix, $default) = @_; + + my($rvol, $rdirs) = $self->splitpath($rprefix); + if( $rvol ) { + return $self->catpath($rvol, + $self->catdir($rdirs, $default), + '' + ) + } + else { + return $self->catdir($rdirs, $default); + } +} + + + +sub cd { + my($self, $dir, @cmds) = @_; + + $dir = vmspath($dir); + + my $cmd = join "\n\t", map "$_", @cmds; + + # No leading tab makes it look right when embedded + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; +startdir = F$Environment("Default") + Set Default %s + %s + Set Default 'startdir' +MAKE_FRAG + + # No trailing newline makes this easier to embed + chomp $make_frag; + + return $make_frag; +} + + + +sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + my @cmds = split /\n/, $cmd; + $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; + $cmd = $self->escape_newlines($cmd); + + # Switches must be quoted else they will be lowercased. + $switches = join ' ', map { qq{"$_"} } @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}; +} + + + +sub echo { + my($self, $text, $file, $opts) = @_; + + # Compatibility with old options + if( !ref $opts ) { + my $append = $opts; + $opts = { append => $append || 0 }; + } + my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write'; + + $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; + + my $ql_opts = { allow_variables => $opts->{allow_variables} }; + + my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); + push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) } + split /\n/, $text; + push @cmds, '$(NOECHO) Close MMECHOFILE'; + return @cmds; +} + + + +sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # I believe this is all we should need. + $text =~ s{"}{""}g; + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return qq{"$text"}; +} + + +sub escape_dollarsigns { + my($self, $text) = @_; + + # Quote dollar signs which are not starting a variable + $text =~ s{\$ (?!\() }{"\$"}gx; + + return $text; +} + + + +sub escape_all_dollarsigns { + my($self, $text) = @_; + + # Quote dollar signs + $text =~ s{\$}{"\$\"}gx; + + return $text; +} + + +sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{-\n}g; + + return $text; +} + + +sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 256; +} + + +sub init_linker { + my $self = shift; + $self->{EXPORT_LIST} ||= '$(BASEEXT).opt'; + + my $shr = $Config{dbgprefix} . 'PERLSHR'; + if ($self->{PERL_SRC}) { + $self->{PERL_ARCHIVE} ||= + $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}"); + } + else { + $self->{PERL_ARCHIVE} ||= + $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"; + } + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; +} + + + +sub catdir { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $dir = $self->SUPER::catdir(@args); + + # Fix up the directory and force it to VMS format. + $dir = $self->fixpath($dir, 1); + + return $dir; +} + +sub catfile { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $file = $self->SUPER::catfile(@args); + + $file = vmsify($file); + + return $file +} + + + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + + my($npath) = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { + if (defined $self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { + $macro = $self->{$macro}; + # Don't unixify if there is unescaped whitespace + $macro = unixify($macro) unless ($macro =~ /(?\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + + return $fixedpath; +} + + + +sub os_flavor { + return('VMS'); +} + + + +sub is_make_type { + my($self, $type) = @_; + return 0; +} + + + +sub make_type { "$Config{make}-style"; } + + + +1; + +# Avoid version control files. +\bRCS\b +\bCVS\b +\bSCCS\b +,v$ +\B\.svn\b +\B\.git\b +\B\.gitignore\b +\b_darcs\b +\B\.cvsignore$ + +# Avoid VMS specific MakeMaker generated files +\bDescrip.MMS$ +\bDESCRIP.MMS$ +\bdescrip.mms$ + +# Avoid Makemaker generated and utility files. +\bMANIFEST\.bak +\bMakefile$ +\bblib/ +\bMakeMaker-\d +\bpm_to_blib\.ts$ +\bpm_to_blib$ +\bblibdirs\.ts$ # 6.18 through 6.25 generated this +\b_eumm/ # 7.05_05 and above + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build/ +\bBuild.bat$ +\bBuild.COM$ +\bBUILD.COM$ +\bbuild.com$ + +# and Module::Build::Tiny generated files +\b_build_params$ + +# Avoid temp and backup files. +~$ +\.old$ +\#$ +\b\.# +\.bak$ +\.tmp$ +\.# +\.rej$ +\..*\.sw.?$ + +# Avoid OS-specific files/dirs +# Mac OSX metadata +\B\.DS_Store +# Mac OSX SMB mount metadata files +\B\._ + +# Avoid Devel::Cover and Devel::CoverX::Covered files. +\bcover_db\b +\bcovered\b + +# Avoid prove files +\B\.prove$ + +# Avoid MYMETA files +^MYMETA\. +package ExtUtils::MM_Unix; + +require 5.006; + +use strict; + +use Carp; +use ExtUtils::MakeMaker::Config; +use File::Basename qw(basename dirname); + +our %Config_Override; + +use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); + +# If we make $VERSION an our variable parse_version() breaks +use vars qw($VERSION); +$VERSION = '7.34'; +$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] + +require ExtUtils::MM_Any; +our @ISA = qw(ExtUtils::MM_Any); + +my %Is; +BEGIN { + $Is{OS2} = $^O eq 'os2'; + $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare'; + $Is{Dos} = $^O eq 'dos'; + $Is{VMS} = $^O eq 'VMS'; + $Is{OSF} = $^O eq 'dec_osf'; + $Is{IRIX} = $^O eq 'irix'; + $Is{NetBSD} = $^O eq 'netbsd'; + $Is{Interix} = $^O eq 'interix'; + $Is{SunOS4} = $^O eq 'sunos'; + $Is{Solaris} = $^O eq 'solaris'; + $Is{SunOS} = $Is{SunOS4} || $Is{Solaris}; + $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or + grep( $^O eq $_, qw(bsdos interix dragonfly) ) + ); + $Is{Android} = $^O =~ /android/; +} + +BEGIN { + if( $Is{VMS} ) { + # For things like vmsify() + require VMS::Filespec; + VMS::Filespec->import; + } +} + + + +# So we don't have to keep calling the methods over and over again, +# we have these globals to cache the values. Faster and shrtr. +my $Curdir = __PACKAGE__->curdir; +my $Updir = __PACKAGE__->updir; + + + +sub os_flavor { + return('Unix'); +} + + + +sub c_o { +# --- Translation Sections --- + + my($self) = shift; + return '' unless $self->needs_linking(); + my(@m); + + my $command = '$(CCCMD)'; + my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)'; + + if (my $cpp = $Config{cpprun}) { + my $cpp_cmd = $self->const_cccmd; + $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; + push @m, qq{ +.c.i: + $cpp_cmd $flags \$*.c > \$*.i +}; + } + + my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : ''; + push @m, sprintf <<'EOF', $command, $flags, $m_o; + +.c.s : + %s -S %s $*.c %s +EOF + + my @exts = qw(c cpp cxx cc); + push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific + $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; + for my $ext (@exts) { + push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n"; + } + return join "", @m; +} + + + +sub xs_obj_opt { + my ($self, $output_file) = @_; + "-o $output_file"; +} + + + +#' + +sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my($prog, $uc, $perltype, %cflags); + $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; + $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; + + @cflags{qw(cc ccflags optimize shellflags)} + = @Config{qw(cc ccflags optimize shellflags)}; + + # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89) + # flags to the %Config, and the modules in the core should be built + # with the warning flags, but NOT the -std=c89 flags (the latter + # would break using any system header files that are strict C99). + my @ccextraflags = qw(ccwarnflags); + if ($ENV{PERL_CORE}) { + for my $x (@ccextraflags) { + if (exists $Config{$x}) { + $cflags{$x} = $Config{$x}; + } + } + } + + my($optdebug) = ""; + + $cflags{shellflags} ||= ''; + + my(%map) = ( + D => '-DDEBUGGING', + E => '-DEMBED', + DE => '-DDEBUGGING -DEMBED', + M => '-DEMBED -DMULTIPLICITY', + DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', + ); + + if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ + $uc = uc($1); + } else { + $uc = ""; # avoid warning + } + $perltype = $map{$uc} ? $map{$uc} : ""; + + if ($uc =~ /^D/) { + $optdebug = "-g"; + } + + + my($name); + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + if ($prog = $Config{$name}) { + # Expand hints for this extension via the shell + print "Processing $name hint:\n" if $Verbose; + my(@o)=`cc=\"$cflags{cc}\" + ccflags=\"$cflags{ccflags}\" + optimize=\"$cflags{optimize}\" + perltype=\"$cflags{perltype}\" + optdebug=\"$cflags{optdebug}\" + eval '$prog' + echo cc=\$cc + echo ccflags=\$ccflags + echo optimize=\$optimize + echo perltype=\$perltype + echo optdebug=\$optdebug + `; + foreach my $line (@o){ + chomp $line; + if ($line =~ /(.*?)=\s*(.*)\s*$/){ + $cflags{$1} = $2; + print " $1 = $2\n" if $Verbose; + } else { + print "Unrecognised result from hint: '$line'\n"; + } + } + } + + if ($optdebug) { + $cflags{optimize} = $optdebug; + } + + for (qw(ccflags optimize perltype)) { + $cflags{$_} ||= ''; + $cflags{$_} =~ s/^\s+//; + $cflags{$_} =~ s/\s+/ /g; + $cflags{$_} =~ s/\s+$//; + $self->{uc $_} ||= $cflags{$_}; + } + + if ($self->{POLLUTE}) { + $self->{CCFLAGS} .= ' -DPERL_POLLUTE '; + } + + for my $x (@ccextraflags) { + next unless exists $cflags{$x}; + $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x}; + } + + my $pollute = ''; + if ($Config{usemymalloc} and not $Config{bincompat5005} + and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/ + and $self->{PERL_MALLOC_OK}) { + $pollute = '$(PERL_MALLOC_DEF)'; + } + + return $self->{CFLAGS} = qq{ +CCFLAGS = $self->{CCFLAGS} +OPTIMIZE = $self->{OPTIMIZE} +PERLTYPE = $self->{PERLTYPE} +MPOLLUTE = $pollute +}; + +} + + + +sub const_cccmd { + my($self,$libperl)=@_; + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + return $self->{CONST_CCCMD} = + q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\ + $(CCFLAGS) $(OPTIMIZE) \\ + $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ + $(XS_DEFINE_VERSION)}; +} + + +sub const_config { +# --- Constants Sections --- + + my($self) = shift; + my @m = $self->specify_shell(); # Usually returns empty string + push @m, <<"END"; + +# These definitions are from config.sh (via $INC{'Config.pm'}). +# They may have been overridden via Makefile.PL or on the command line. +END + + my(%once_only); + foreach my $key (@{$self->{CONFIG}}){ + # SITE*EXP macros are defined in &constants; avoid duplicates here + next if $once_only{$key}; + push @m, uc($key) , ' = ' , $self->{uc $key}, "\n"; + $once_only{$key} = 1; + } + join('', @m); +} + + +sub const_loadlibs { + my($self) = shift; + return "" unless $self->needs_linking; + my @m; + push @m, qq{ +# $self->{NAME} might depend on some other libraries: +# See ExtUtils::Liblist for details +# +}; + for my $tmp (qw/ + EXTRALIBS LDLOADLIBS BSLOADLIBS + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + # don't set LD_RUN_PATH if empty + for my $tmp (qw/ + LD_RUN_PATH + /) { + next unless $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + return join "", @m; +} + + +sub constants { + my($self) = @_; + my @m = (); + + $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use + + for my $macro (qw( + + AR_STATIC_ARGS DIRFILESEP DFSEP + NAME NAME_SYM + VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION + XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB + INST_MAN1DIR INST_MAN3DIR + MAN1EXT MAN3EXT + INSTALLDIRS INSTALL_BASE DESTDIR PREFIX + PERLPREFIX SITEPREFIX VENDORPREFIX + ), + (map { ("INSTALL".$_, + "DESTINSTALL".$_) + } $self->installvars), + qw( + PERL_LIB + PERL_ARCHLIB PERL_ARCHLIBDEP + LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE + PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP + PERL FULLPERL ABSPERL + PERLRUN FULLPERLRUN ABSPERLRUN + PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST + PERL_CORE + PERM_DIR PERM_RW PERM_RWX + + ) ) + { + next unless defined $self->{$macro}; + + # pathnames can have sharp signs in them; escape them so + # make doesn't think it is a comment-start character. + $self->{$macro} =~ s/#/\\#/g; + $self->{$macro} = $self->quote_dep($self->{$macro}) + if $ExtUtils::MakeMaker::macro_dep{$macro}; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, qq{ +MAKEMAKER = $self->{MAKEMAKER} +MM_VERSION = $self->{MM_VERSION} +MM_REVISION = $self->{MM_REVISION} +}; + + push @m, q{ +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +}; + + for my $macro (qw/ + MAKE + FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE BOOTDEP + / ) + { + next unless defined $self->{$macro}; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, " +# Handy lists of source code files: +XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})." +C_FILES = ".$self->wraplist(sort @{$self->{C}})." +O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})." +H_FILES = ".$self->wraplist(sort @{$self->{H}})." +MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})." +MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})." +"; + + + push @m, q{ +# Where is the Config information that we are using/depend on +CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h +} if -e $self->catfile( $self->{PERL_INC}, 'config.h' ); + + + push @m, qq{ +# Where to build things +INST_LIBDIR = $self->{INST_LIBDIR} +INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR} + +INST_AUTODIR = $self->{INST_AUTODIR} +INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} + +INST_STATIC = $self->{INST_STATIC} +INST_DYNAMIC = $self->{INST_DYNAMIC} +INST_BOOT = $self->{INST_BOOT} +}; + + push @m, qq{ +# Extra linker info +EXPORT_LIST = $self->{EXPORT_LIST} +PERL_ARCHIVE = $self->{PERL_ARCHIVE} +PERL_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP} +PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER} +}; + + push @m, " + +TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n"; + + join('',@m); +} + + + +sub depend { + my($self,%attribs) = @_; + my(@m,$key,$val); + for my $key (sort keys %attribs){ + my $val = $attribs{$key}; + next unless defined $key and defined $val; + push @m, "$key : $val\n"; + } + join "", @m; +} + + + +sub init_DEST { + my $self = shift; + + # Initialize DESTDIR + $self->{DESTDIR} ||= ''; + + # Make DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')'; + } +} + + + +sub init_dist { + my $self = shift; + + $self->{TAR} ||= 'tar'; + $self->{TARFLAGS} ||= 'cvf'; + $self->{ZIP} ||= 'zip'; + $self->{ZIPFLAGS} ||= '-r'; + $self->{COMPRESS} ||= 'gzip --best'; + $self->{SUFFIX} ||= '.gz'; + $self->{SHAR} ||= 'shar'; + $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST + $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir + $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)'; + + $self->{CI} ||= 'ci -u'; + $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q'; + $self->{DIST_CP} ||= 'best'; + $self->{DIST_DEFAULT} ||= 'tardist'; + + ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME}; + $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION}; +} + + +sub dist { + my($self, %attribs) = @_; + + my $make = ''; + if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) { + $attribs{SUFFIX} = '.' . $attribs{SUFFIX}; + } + foreach my $key (qw( + TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR + PREOP POSTOP TO_UNIX + CI RCS_LABEL DIST_CP DIST_DEFAULT + DISTNAME DISTVNAME + )) + { + my $value = $attribs{$key} || $self->{$key}; + $make .= "$key = $value\n"; + } + + return $make; +} + + +sub dist_basics { + my($self) = shift; + + return <<'MAKE_FRAG'; +distclean :: realclean distcheck + $(NOECHO) $(NOOP) + +distcheck : + $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck + +skipcheck : + $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck + +manifest : + $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest + +veryclean : realclean + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old + +MAKE_FRAG + +} + + +sub dist_ci { + my($self) = shift; + return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]); +@all = sort keys %{ maniread() }; +print(qq{Executing $(CI) @all\n}); +system(qq{$(CI) @all}) == 0 or die $!; +print(qq{Executing $(RCS_LABEL) ...\n}); +system(qq{$(RCS_LABEL) @all}) == 0 or die $!; +EOF +} + + +sub dist_core { + my($self) = shift; + + my $make_frag = ''; + foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile + shdist)) + { + my $method = $target.'_target'; + $make_frag .= "\n"; + $make_frag .= $self->$method(); + } + + return $make_frag; +} + + + +sub dist_target { + my($self) = shift; + + my $date_check = $self->oneliner(<<'CODE', ['-l']); +print 'Warning: Makefile possibly out of date with $(VERSION_FROM)' + if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)'; +CODE + + return sprintf <<'MAKE_FRAG', $date_check; +dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) + $(NOECHO) %s +MAKE_FRAG +} + + +sub tardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) +MAKE_FRAG +} + + +sub zipdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +zipdist : $(DISTVNAME).zip + $(NOECHO) $(NOOP) +MAKE_FRAG +} + + +sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)' + $(POSTOP) +MAKE_FRAG +} + + +sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip' + $(POSTOP) +MAKE_FRAG +} + + +sub uutardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu' +MAKE_FRAG +} + + + +sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar' + $(POSTOP) +MAKE_FRAG +} + + + +sub dlsyms { + return ''; +} + + + +sub dynamic_bs { + my($self, %attribs) = @_; + return "\nBOOTSTRAP =\n" unless $self->has_link_code(); + my @exts; + if ($self->{XSMULTI}) { + @exts = $self->_xs_list_basenames; + } else { + @exts = '$(BASEEXT)'; + } + return join "\n", + "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n", + map { $self->_xs_make_bs($_) } @exts; +} + +sub _xs_make_bs { + my ($self, $basename) = @_; + my ($v, $d, $f) = File::Spec->splitpath($basename); + my @d = File::Spec->splitdir($d); + shift @d if $self->{XSMULTI} and $d[0] eq 'lib'; + my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)'; + my $instfile = $self->catfile($instdir, "$f.bs"); + my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target + # 1 2 3 + return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists; +# As Mkbootstrap might not write a file (if none is required) +# we use touch to prevent make continually trying to remake it. +# The DynaLoader only reads a non-empty file. +%1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP) + $(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))" + $(NOECHO) $(PERLRUN) \ + "-MExtUtils::Mkbootstrap" \ + -e "Mkbootstrap('%1$s','$(BSLOADLIBS)');" + $(NOECHO) $(TOUCH) "%1$s.bs" + $(CHMOD) $(PERM_RW) "%1$s.bs" + +%2$s : %1$s.bs %3$s + $(NOECHO) $(RM_RF) %2$s + - $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW) +MAKE_FRAG +} + + +sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + return '' unless $self->has_link_code; + my @m = $self->xs_dynamic_lib_macros(\%attribs); + my @libs; + my $dlsyms_ext = eval { $self->xs_dlsyms_ext }; + if ($self->{XSMULTI}) { + my @exts = $self->_xs_list_basenames; + for my $ext (@exts) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + + # Dynamic library names may need special handling. + eval { require DynaLoader }; + if (defined &DynaLoader::mod2fname) { + $f = &DynaLoader::mod2fname([@d, $f]); + } + + my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)"); + my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT'); + $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile; + my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM'); + $ldfrom = $objfile unless defined $ldfrom; + my $exportlist = "$ext.def"; + my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist); + push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef; + push @libs, \@libchunk; + } + } else { + my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)); + push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef; + @libs = (\@libchunk); + } + push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs; + + return join("\n",@m); +} + + +sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + my $armaybe = $self->_xs_armaybe($attribs); + my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too? + my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : ''; + sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix; +# This section creates the dynamically loadable objects from relevant +# objects and possibly $(MYEXTLIB). +ARMAYBE = %s +OTHERLDFLAGS = %s +INST_DYNAMIC_DEP = %s +INST_DYNAMIC_FIX = %s +EOF +} + +sub _xs_armaybe { + my ($self, $attribs) = @_; + my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":"; + $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':'); + $armaybe; +} + + +sub xs_make_dynamic_lib { + my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_; + $exportlist = '' if $exportlist ne '$(EXPORT_LIST)'; + my $armaybe = $self->_xs_armaybe($attribs); + my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || ''); + my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms); + if ($armaybe ne ':'){ + $ldfrom = 'tmp$(LIB_EXT)'; + push(@m," \$(ARMAYBE) cr $ldfrom $object\n"); + push(@m," \$(RANLIB) $ldfrom\n"); + } + $ldfrom = "-all $ldfrom -none" if $Is{OSF}; + + # The IRIX linker doesn't use LD_RUN_PATH + my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ? + qq{-rpath "$self->{LD_RUN_PATH}"} : ''; + + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m," \$(RM_F) \$\@\n"); + + my $libs = '$(LDLOADLIBS)'; + if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') { + # Use nothing on static perl platforms, and to the flags needed + # to link against the shared libperl library on shared perl + # platforms. We peek at lddlflags to see if we need -Wl,-R + # or -R to add paths to the run-time library search path. + if ($Config{'lddlflags'} =~ /-Wl,-R/) { + $libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl'; + } elsif ($Config{'lddlflags'} =~ /-R/) { + $libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl'; + } elsif ( $Is{Android} ) { + # The Android linker will not recognize symbols from + # libperl unless the module explicitly depends on it. + $libs .= ' "-L$(PERL_INC)" -lperl'; + } + } + + my $ld_run_path_shell = ""; + if ($self->{LD_RUN_PATH} ne "") { + $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" '; + } + + push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist; + %s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \ + $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \ + $(INST_DYNAMIC_FIX) + $(CHMOD) $(PERM_RWX) $@ +MAKE + join '', @m; +} + + +sub exescan { + my($self,$path) = @_; + $path; +} + + +sub extliblist { + my($self,$libs) = @_; + require ExtUtils::Liblist; + $self->ext($libs, $Verbose); +} + + +sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + + if ($trace >= 2){ + print "Looking for perl $ver by these names: +@$names +in these dirs: +@$dirs +"; + } + + my $stderr_duped = 0; + local *STDERR_COPY; + + unless ($Is{BSD}) { + # >& and lexical filehandles together give 5.6.2 indigestion + if( open(STDERR_COPY, '>&STDERR') ) { ## no critic + $stderr_duped = 1; + } + else { + warn <file_name_is_absolute($name)) { # /foo/bar + $abs = $name; + } elsif ($self->canonpath($name) eq + $self->canonpath(basename($name))) { # foo + $use_dir = 1; + } else { # foo/bar + $abs = $self->catfile($Curdir, $name); + } + foreach my $dir ($use_dir ? @$dirs : 1){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + + $abs = $self->catfile($dir, $name) + if $use_dir; + + print "Checking $abs\n" if ($trace >= 2); + next unless $self->maybe_command($abs); + print "Executing $abs\n" if ($trace >= 2); + + my $val; + my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"}; + + # To avoid using the unportable 2>&1 to suppress STDERR, + # we close it before running the command. + # However, thanks to a thread library bug in many BSDs + # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 ) + # we cannot use the fancier more portable way in here + # but instead need to use the traditional 2>&1 construct. + if ($Is{BSD}) { + $val = `$version_check 2>&1`; + } else { + close STDERR if $stderr_duped; + $val = `$version_check`; + + # 5.6.2's 3-arg open doesn't work with >& + open STDERR, ">&STDERR_COPY" ## no critic + if $stderr_duped; + } + + if ($val =~ /^VER_OK/m) { + print "Using PERL=$abs\n" if $trace; + return $abs; + } elsif ($trace >= 2) { + print "Result: '$val' ".($? >> 8)."\n"; + } + } + } + print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty +} + + + +sub fixin { # stolen from the pink Camel book, more or less + my ( $self, @files ) = @_; + + for my $file (@files) { + my $file_new = "$file.new"; + my $file_bak = "$file.bak"; + + open( my $fixin, '<', $file ) or croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp( my $line = <$fixin> ); + next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file. + + my $shb = $self->_fixin_replace_shebang( $file, $line ); + next unless defined $shb; + + open( my $fixout, ">", "$file_new" ) or do { + warn "Can't create new $file: $!\n"; + next; + }; + + # Print out the new #! line (or equivalent). + local $\; + local $/; + print $fixout $shb, <$fixin>; + close $fixin; + close $fixout; + + chmod 0666, $file_bak; + unlink $file_bak; + unless ( _rename( $file, $file_bak ) ) { + warn "Can't rename $file to $file_bak: $!"; + next; + } + unless ( _rename( $file_new, $file ) ) { + warn "Can't rename $file_new to $file: $!"; + unless ( _rename( $file_bak, $file ) ) { + warn "Can't rename $file_bak back to $file either: $!"; + warn "Leaving $file renamed as $file_bak\n"; + } + next; + } + unlink $file_bak; + } + continue { + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; + } +} + + +sub _rename { + my($old, $new) = @_; + + foreach my $file ($old, $new) { + if( $Is{VMS} and basename($file) !~ /\./ ) { + # rename() in 5.8.0 on VMS will not rename a file if it + # does not contain a dot yet it returns success. + $file = "$file."; + } + } + + return rename($old, $new); +} + +sub _fixin_replace_shebang { + my ( $self, $file, $line ) = @_; + + # Now figure out the interpreter name. + my ( $cmd, $arg ) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + my $interpreter; + if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) { + if ( $Config{startperl} =~ m,^\#!.*/perl, ) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } + else { + $interpreter = $Config{perlpath}; + } + } + else { + my (@absdirs) + = reverse grep { $self->file_name_is_absolute($_) } $self->path; + $interpreter = ''; + + foreach my $dir (@absdirs) { + my $maybefile = $self->catfile($dir,$cmd); + if ( $self->maybe_command($maybefile) ) { + warn "Ignoring $interpreter in $file\n" + if $Verbose && $interpreter; + $interpreter = $maybefile; + } + } + } + + # Figure out how to invoke interpreter on this machine. + + my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; + my ($shb) = ""; + if ($interpreter) { + print "Changing sharpbang in $file to $interpreter" + if $Verbose; + # this is probably value-free on DOSISH platforms + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + } + else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + return; + } + return $shb +} + + +sub force { + my($self) = shift; + '# Phony target to force checking subdirectories. +FORCE : + $(NOECHO) $(NOOP) +'; +} + + +# '; + +sub guess_name { + my($self) = @_; + use Cwd 'cwd'; + my $name = basename(cwd()); + $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we + # strip minus or underline + # followed by a float or some such + print "Warning: Guessing NAME [$name] from current directory name.\n"; + $name; +} + + +sub has_link_code { + my($self) = shift; + return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; + if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ + $self->{HAS_LINK_CODE} = 1; + return 1; + } + return $self->{HAS_LINK_CODE} = 0; +} + + + +sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) + my($self) = @_; + my(%dir, %xs, %c, %o, %h, %pl_files, %pm); + + my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t); + + # ignore the distdir + $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1 + : $ignore{$self->{DISTVNAME}} = 1; + + my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i + : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/; + + @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS}; + + if ( defined $self->{XS} and !defined $self->{C} ) { + my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}}; + my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}}; + %c = map { $_ => 1 } @c_files; + %o = map { $_ => 1 } @o_files; + } + + foreach my $name ($self->lsdir($Curdir)){ + next if $name =~ /\#/; + next if $name =~ $distprefix && -d $name; + $name = lc($name) if $Is{VMS}; + next if $name eq $Curdir or $name eq $Updir or $ignore{$name}; + next unless $self->libscan($name); + if (-d $name){ + next if -l $name; # We do not support symlinks at all + next if $self->{NORECURS}; + $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); + } elsif ($name =~ /\.xs\z/){ + my($c); ($c = $name) =~ s/\.xs\z/.c/; + $xs{$name} = $c; + $c{$c} = 1; + } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc + $c{$name} = 1 + unless $name =~ m/perlmain\.c/; # See MAP_TARGET + } elsif ($name =~ /\.h\z/i){ + $h{$name} = 1; + } elsif ($name =~ /\.PL\z/) { + ($pl_files{$name} = $name) =~ s/\.PL\z// ; + } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) { + # case-insensitive filesystem, one dot per name, so foo.h.PL + # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos + local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; + } + else { + $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); + } + } elsif ($name =~ /\.(p[ml]|pod)\z/){ + $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); + } + } + + $self->{PL_FILES} ||= \%pl_files; + $self->{DIR} ||= [sort keys %dir]; + $self->{XS} ||= \%xs; + $self->{C} ||= [sort keys %c]; + $self->{H} ||= [sort keys %h]; + $self->{PM} ||= \%pm; + + my @o_files = @{$self->{C}}; + %o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files); + $self->{O_FILES} = [sort keys %o]; +} + + + +sub init_MANPODS { + my $self = shift; + + # Set up names of manual pages to generate from pods + foreach my $man (qw(MAN1 MAN3)) { + if ( $self->{"${man}PODS"} + or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/ + ) { + $self->{"${man}PODS"} ||= {}; + } + else { + my $init_method = "init_${man}PODS"; + $self->$init_method(); + } + } +} + + +sub _has_pod { + my($self, $file) = @_; + + my($ispod)=0; + if (open( my $fh, '<', $file )) { + while (<$fh>) { + if (/^=(?:head\d+|item|pod)\b/) { + $ispod=1; + last; + } + } + close $fh; + } else { + # If it doesn't exist yet, we assume, it has pods in it + $ispod = 1; + } + + return $ispod; +} + + + +sub init_MAN1PODS { + my($self) = @_; + + if ( exists $self->{EXE_FILES} ) { + foreach my $name (@{$self->{EXE_FILES}}) { + next unless $self->_has_pod($name); + + $self->{MAN1PODS}->{$name} = + $self->catfile("\$(INST_MAN1DIR)", + basename($name).".\$(MAN1EXT)"); + } + } +} + + + +sub init_MAN3PODS { + my $self = shift; + + my %manifypods = (); # we collect the keys first, i.e. the files + # we have to convert to pod + + foreach my $name (keys %{$self->{PM}}) { + if ($name =~ /\.pod\z/ ) { + $manifypods{$name} = $self->{PM}{$name}; + } elsif ($name =~ /\.p[ml]\z/ ) { + if( $self->_has_pod($name) ) { + $manifypods{$name} = $self->{PM}{$name}; + } + } + } + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + + # Remove "Configure.pm" and similar, if it's not the only pod listed + # To force inclusion, just name it "Configure.pod", or override + # MAN3PODS + foreach my $name (keys %manifypods) { + if ( + ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or + ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod + ) { + delete $manifypods{$name}; + next; + } + my($manpagename) = $name; + $manpagename =~ s/\.p(od|m|l)\z//; + # everything below lib is ok + unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) { + $manpagename = $self->catfile( + split(/::/,$self->{PARENT_NAME}),$manpagename + ); + } + $manpagename = $self->replace_manpage_separator($manpagename); + $self->{MAN3PODS}->{$name} = + $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); + } +} + + + +sub init_PM { + my $self = shift; + + # Some larger extensions often wish to install a number of *.pm/pl + # files into the library in various locations. + + # The attribute PMLIBDIRS holds an array reference which lists + # subdirectories which we should search for library files to + # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We + # recursively search through the named directories (skipping any + # which don't exist or contain Makefile.PL files). + + # For each *.pm or *.pl file found $self->libscan() is called with + # the default installation path in $_[1]. The return value of + # libscan defines the actual installation location. The default + # libscan function simply returns the path. The file is skipped + # if libscan returns false. + + # The default installation location passed to libscan in $_[1] is: + # + # ./*.pm => $(INST_LIBDIR)/*.pm + # ./xyz/... => $(INST_LIBDIR)/xyz/... + # ./lib/... => $(INST_LIB)/... + # + # In this way the 'lib' directory is seen as the root of the actual + # perl library whereas the others are relative to INST_LIBDIR + # (which includes PARENT_NAME). This is a subtle distinction but one + # that's important for nested modules. + + unless( $self->{PMLIBDIRS} ) { + if( $Is{VMS} ) { + # Avoid logical name vs directory collisions + $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"]; + } + else { + $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}]; + } + } + + #only existing directories that aren't in $dir are allowed + + # Avoid $_ wherever possible: + # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; + my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; + @{$self->{PMLIBDIRS}} = (); + my %dir = map { ($_ => $_) } @{$self->{DIR}}; + foreach my $pmlibdir (@pmlibdirs) { + -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir; + } + + unless( $self->{PMLIBPARENTDIRS} ) { + @{$self->{PMLIBPARENTDIRS}} = ('lib'); + } + + return if $self->{PM} and $self->{ARGS}{PM}; + + if (@{$self->{PMLIBDIRS}}){ + print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n" + if ($Verbose >= 2); + require File::Find; + File::Find::find(sub { + if (-d $_){ + unless ($self->libscan($_)){ + $File::Find::prune = 1; + } + return; + } + return if /\#/; + return if /~$/; # emacs temp files + return if /,v$/; # RCS files + return if m{\.swp$}; # vim swap files + + my $path = $File::Find::name; + my $prefix = $self->{INST_LIBDIR}; + my $striplibpath; + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + $prefix = $self->{INST_LIB} + if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W} + {$1}i; + + my($inst) = $self->catfile($prefix,$striplibpath); + local($_) = $inst; # for backwards compatibility + $inst = $self->libscan($inst); + print "libscan($path) => '$inst'\n" if ($Verbose >= 2); + return unless $inst; + if ($self->{XSMULTI} and $inst =~ /\.xs\z/) { + my($base); ($base = $path) =~ s/\.xs\z//; + $self->{XS}{$path} = "$base.c"; + push @{$self->{C}}, "$base.c"; + push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}"; + } else { + $self->{PM}{$path} = $inst; + } + }, @{$self->{PMLIBDIRS}}); + } +} + + + +sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = '/'; +} + + + +sub init_main { + my($self) = @_; + + # --- Initialize Module Name and Paths + + # NAME = Foo::Bar::Oracle + # FULLEXT = Foo/Bar/Oracle + # BASEEXT = Oracle + # PARENT_NAME = Foo::Bar +### Only UNIX: +### ($self->{FULLEXT} = +### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket + $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME}); + + + # Copied from DynaLoader: + + my(@modparts) = split(/::/,$self->{NAME}); + my($modfname) = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + # We require DynaLoader to make sure that mod2fname is loaded + eval { require DynaLoader }; + if (defined &DynaLoader::mod2fname) { + $modfname = &DynaLoader::mod2fname(\@modparts); + } + + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ; + $self->{PARENT_NAME} ||= ''; + + if (defined &DynaLoader::mod2fname) { + # As of 5.001m, dl_os2 appends '_' + $self->{DLBASE} = $modfname; + } else { + $self->{DLBASE} = '$(BASEEXT)'; + } + + + # --- Initialize PERL_LIB, PERL_SRC + + # *Real* information: where did we get these two from? ... + my $inc_config_dir = dirname($INC{'Config.pm'}); + my $inc_carp_dir = dirname($INC{'Carp.pm'}); + + unless ($self->{PERL_SRC}){ + foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting + my $dir = $self->catdir(($Updir) x $dir_count); + + if (-f $self->catfile($dir,"config_h.SH") && + -f $self->catfile($dir,"perl.h") && + -f $self->catfile($dir,"lib","strict.pm") + ) { + $self->{PERL_SRC}=$dir ; + last; + } + } + } + + warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if + $self->{PERL_CORE} and !$self->{PERL_SRC}; + + if ($self->{PERL_SRC}){ + $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); + + $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; + $self->{PERL_INC} = ($Is{Win32}) ? + $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; + + # catch a situation that has occurred a few times in the past: + unless ( + -s $self->catfile($self->{PERL_SRC},'cflags') + or + $Is{VMS} + && + -s $self->catfile($self->{PERL_SRC},'vmsish.h') + or + $Is{Win32} + ){ + warn qq{ +You cannot build extensions below the perl source tree after executing +a 'make clean' in the perl source tree. + +To rebuild extensions distributed with the perl source you should +simply Configure (to include those extensions) and then build perl as +normal. After installing perl the source tree can be deleted. It is +not needed for building extensions by running 'perl Makefile.PL' +usually without extra arguments. + +It is recommended that you unpack and build additional extensions away +from the perl source tree. +}; + } + } else { + # we should also consider $ENV{PERL5LIB} here + my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC}; + $self->{PERL_LIB} ||= $Config{privlibexp}; + $self->{PERL_ARCHLIB} ||= $Config{archlibexp}; + $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now + my $perl_h; + + if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) + and not $old){ + # Maybe somebody tries to build an extension with an + # uninstalled Perl outside of Perl build tree + my $lib; + for my $dir (@INC) { + $lib = $dir, last if -e $self->catfile($dir, "Config.pm"); + } + if ($lib) { + # Win32 puts its header files in /perl/src/lib/CORE. + # Unix leaves them in /perl/src. + my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" ) + : dirname $lib; + if (-e $self->catfile($inc, "perl.h")) { + $self->{PERL_LIB} = $lib; + $self->{PERL_ARCHLIB} = $lib; + $self->{PERL_INC} = $inc; + $self->{UNINSTALLED_PERL} = 1; + print <{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB}); + $self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB}); + } + $self->{PERL_INCDEP} = $self->{PERL_INC}; + $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB}; + + # We get SITELIBEXP and SITEARCHEXP directly via + # Get_from_Config. When we are running standard modules, these + # won't matter, we will set INSTALLDIRS to "perl". Otherwise we + # set it to "site". I prefer that INSTALLDIRS be set from outside + # MakeMaker. + $self->{INSTALLDIRS} ||= "site"; + + $self->{MAN1EXT} ||= $Config{man1ext}; + $self->{MAN3EXT} ||= $Config{man3ext}; + + # Get some stuff out of %Config if we haven't yet done so + print "CONFIG must be an array ref\n" + if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY'); + $self->{CONFIG} = [] unless (ref $self->{CONFIG}); + push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config); + push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags}; + my(%once_only); + foreach my $m (@{$self->{CONFIG}}){ + next if $once_only{$m}; + print "CONFIG key '$m' does not exist in Config.pm\n" + unless exists $Config{$m}; + $self->{uc $m} ||= $Config{$m}; + $once_only{$m} = 1; + } + +# This is too dangerous: +# if ($^O eq "next") { +# $self->{AR} = "libtool"; +# $self->{AR_STATIC_ARGS} = "-o"; +# } +# But I leave it as a placeholder + + $self->{AR_STATIC_ARGS} ||= "cr"; + + # These should never be needed + $self->{OBJ_EXT} ||= '.o'; + $self->{LIB_EXT} ||= '.a'; + + $self->{MAP_TARGET} ||= "perl"; + + $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}"; + + # make a simple check if we find strict + warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory + (strict.pm not found)" + unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") || + $self->{NAME} eq "ExtUtils::MakeMaker"; +} + + +sub init_tools { + my $self = shift; + + $self->{ECHO} ||= 'echo'; + $self->{ECHO_N} ||= 'echo -n'; + $self->{RM_F} ||= "rm -f"; + $self->{RM_RF} ||= "rm -rf"; + $self->{TOUCH} ||= "touch"; + $self->{TEST_F} ||= "test -f"; + $self->{TEST_S} ||= "test -s"; + $self->{CP} ||= "cp"; + $self->{MV} ||= "mv"; + $self->{CHMOD} ||= "chmod"; + $self->{FALSE} ||= 'false'; + $self->{TRUE} ||= 'true'; + + $self->{LD} ||= 'ld'; + + return $self->SUPER::init_tools(@_); + + # After SUPER::init_tools so $Config{shell} has a + # chance to get set. + $self->{SHELL} ||= '/bin/sh'; + + return; +} + + + +sub init_linker { + my($self) = shift; + $self->{PERL_ARCHIVE} ||= ''; + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; +} + + + +sub init_lib2arch { + my($self) = shift; + + # The user who requests an installation directory explicitly + # should not have to tell us an architecture installation directory + # as well. We look if a directory exists that is named after the + # architecture. If not we take it as a sign that it should be the + # same as the requested installation directory. Otherwise we take + # the found one. + for my $libpair ({l=>"privlib", a=>"archlib"}, + {l=>"sitelib", a=>"sitearch"}, + {l=>"vendorlib", a=>"vendorarch"}, + ) + { + my $lib = "install$libpair->{l}"; + my $Lib = uc $lib; + my $Arch = uc "install$libpair->{a}"; + if( $self->{$Lib} && ! $self->{$Arch} ){ + my($ilib) = $Config{$lib}; + + $self->prefixify($Arch,$ilib,$self->{$Lib}); + + unless (-d $self->{$Arch}) { + print "Directory $self->{$Arch} not found\n" + if $Verbose; + $self->{$Arch} = $self->{$Lib}; + } + print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose; + } + } +} + + + +sub init_PERL { + my($self) = shift; + + my @defpath = (); + foreach my $component ($self->{PERL_SRC}, $self->path(), + $Config{binexp}) + { + push @defpath, $component if defined $component; + } + + # Build up a set of file names (not command names). + my $thisperl = $self->canonpath($^X); + $thisperl .= $Config{exe_ext} unless + # VMS might have a file version # at the end + $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i + : $thisperl =~ m/$Config{exe_ext}$/i; + + # We need a relative path to perl when in the core. + $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE}; + + my @perls = ($thisperl); + push @perls, map { "$_$Config{exe_ext}" } + ("perl$Config{version}", 'perl5', 'perl'); + + # miniperl has priority over all but the canonical perl when in the + # core. Otherwise its a last resort. + my $miniperl = "miniperl$Config{exe_ext}"; + if( $self->{PERL_CORE} ) { + splice @perls, 1, 0, $miniperl; + } + else { + push @perls, $miniperl; + } + + $self->{PERL} ||= + $self->find_perl(5.0, \@perls, \@defpath, $Verbose ); + + my $perl = $self->{PERL}; + $perl =~ s/^"//; + my $has_mcr = $perl =~ s/^MCR\s*//; + my $perlflags = ''; + my $stripped_perl; + while ($perl) { + ($stripped_perl = $perl) =~ s/"$//; + last if -x $stripped_perl; + last unless $perl =~ s/(\s+\S+)$//; + $perlflags = $1.$perlflags; + } + $self->{PERL} = $stripped_perl; + $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS}; + + # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe. + my $perl_name = 'perl'; + $perl_name = 'ndbgperl' if $Is{VMS} && + defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define'; + + # XXX This logic is flawed. If "miniperl" is anywhere in the path + # it will get confused. It should be fixed to work only on the filename. + # Define 'FULLPERL' to be a non-miniperl (used in test: target) + unless ($self->{FULLPERL}) { + ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i; + $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags; + } + # Can't have an image name with quotes, and findperl will have + # already escaped spaces. + $self->{FULLPERL} =~ tr/"//d if $Is{VMS}; + + # Little hack to get around VMS's find_perl putting "MCR" in front + # sometimes. + $self->{ABSPERL} = $self->{PERL}; + $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//; + if( $self->file_name_is_absolute($self->{ABSPERL}) ) { + $self->{ABSPERL} = '$(PERL)'; + } + else { + $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL}); + + # Quote the perl command if it contains whitespace + $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL}) + if $self->{ABSPERL} =~ /\s/; + + $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr; + } + $self->{PERL} = qq{"$self->{PERL}"}.$perlflags; + + # Can't have an image name with quotes, and findperl will have + # already escaped spaces. + $self->{PERL} =~ tr/"//d if $Is{VMS}; + + # Are we building the core? + $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE}; + $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE}; + + # Make sure perl can find itself before it's installed. + my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE} + ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ? + q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"} + : undef; + my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB} + ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"' + : 'RUN)'.$perlflags.' "-I$(INST_LIB)"'; + # How do we run perl? + foreach my $perl (qw(PERL FULLPERL ABSPERL)) { + my $run = $perl.'RUN'; + + $self->{$run} = qq{\$($perl)}; + $self->{$run} .= $lib_paths if $lib_paths; + + $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths; + } + + return 1; +} + + + +sub init_platform { + my($self) = shift; + + $self->{MM_Unix_VERSION} = $VERSION; + $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '. + '-Dfree=Perl_mfree -Drealloc=Perl_realloc '. + '-Dcalloc=Perl_calloc'; + +} + +sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; +} + + + +sub init_PERM { + my($self) = shift; + + $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR}; + $self->{PERM_RW} = 644 unless defined $self->{PERM_RW}; + $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX}; + + return 1; +} + + + +sub init_xs { + my $self = shift; + + if ($self->has_link_code()) { + $self->{INST_STATIC} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)'); + $self->{INST_DYNAMIC} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)'); + $self->{INST_BOOT} = + $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs'); + if ($self->{XSMULTI}) { + my @exts = $self->_xs_list_basenames; + my (@statics, @dynamics, @boots); + for my $ext (@exts) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if defined $d[0] and $d[0] eq 'lib'; + my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + my $instfile = $self->catfile($instdir, $f); + push @statics, "$instfile\$(LIB_EXT)"; + + # Dynamic library names may need special handling. + my $dynfile = $instfile; + eval { require DynaLoader }; + if (defined &DynaLoader::mod2fname) { + $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f])); + } + + push @dynamics, "$dynfile.\$(DLEXT)"; + push @boots, "$instfile.bs"; + } + $self->{INST_STATIC} = join ' ', @statics; + $self->{INST_DYNAMIC} = join ' ', @dynamics; + $self->{INST_BOOT} = join ' ', @boots; + } + } else { + $self->{INST_STATIC} = ''; + $self->{INST_DYNAMIC} = ''; + $self->{INST_BOOT} = ''; + } +} + + +sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q{ +install :: pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +install_vendor :: pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +doc__install : doc_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +pure_perl_install :: all + $(NOECHO) $(MOD_INSTALL) \ +}; + + push @m, +q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ +} unless $self->{NO_PACKLIST}; + + push @m, +q{ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \ + "$(INST_BIN)" "$(DESTINSTALLBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)" + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + "}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{" + + +pure_site_install :: all + $(NOECHO) $(MOD_INSTALL) \ +}; + push @m, +q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \ +} unless $self->{NO_PACKLIST}; + + push @m, +q{ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \ + "$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)" + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + "}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{" + +pure_vendor_install :: all + $(NOECHO) $(MOD_INSTALL) \ +}; + push @m, +q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \ +} unless $self->{NO_PACKLIST}; + + push @m, +q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \ + "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)" + +}; + + push @m, q{ +doc_perl_install :: all + $(NOECHO) $(NOOP) + +doc_site_install :: all + $(NOECHO) $(NOOP) + +doc_vendor_install :: all + $(NOECHO) $(NOOP) + +} if $self->{NO_PERLLOCAL}; + + push @m, q{ +doc_perl_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLPRIVLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + +doc_site_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLSITELIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + +doc_vendor_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLVENDORLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + +} unless $self->{NO_PERLLOCAL}; + + push @m, q{ +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" + +uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" +}; + + join("",@m); +} + + +sub installbin { + my($self) = shift; + + return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; + my @exefiles = sort @{$self->{EXE_FILES}}; + return "" unless @exefiles; + + @exefiles = map vmsify($_), @exefiles if $Is{VMS}; + + my %fromto; + for my $from (@exefiles) { + my($path)= $self->catfile('$(INST_SCRIPT)', basename($from)); + + local($_) = $path; # for backwards compatibility + my $to = $self->libscan($path); + print "libscan($from) => '$to'\n" if ($Verbose >=2); + + $to = vmsify($to) if $Is{VMS}; + $fromto{$from} = $to; + } + my @to = sort values %fromto; + + my @m; + push(@m, qq{ +EXE_FILES = @exefiles + +pure_all :: @to + \$(NOECHO) \$(NOOP) + +realclean :: +}); + + # realclean can get rather large. + push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to); + push @m, "\n"; + + # A target for each exe file. + my @froms = sort keys %fromto; + for my $from (@froms) { + # 1 2 + push @m, _sprintf562 <<'MAKE', $from, $fromto{$from}; +%2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists + $(NOECHO) $(RM_F) %2$s + $(CP) %1$s %2$s + $(FIXIN) %2$s + -$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s + +MAKE + + } + + join "", @m; +} + + +# LINKTYPE => static or dynamic or '' +sub linkext { + my($self, %attribs) = @_; + my $linktype = $attribs{LINKTYPE}; + $linktype = $self->{LINKTYPE} unless defined $linktype; + if (defined $linktype and $linktype eq '') { + warn "Warning: LINKTYPE set to '', no longer necessary\n"; + } + $linktype = '$(LINKTYPE)' unless defined $linktype; + " +linkext :: $linktype + \$(NOECHO) \$(NOOP) +"; +} + + +sub lsdir { + # $self + my(undef, $dir, $regex) = @_; + opendir(my $dh, defined($dir) ? $dir : ".") + or return; + my @ls = readdir $dh; + closedir $dh; + @ls = grep(/$regex/, @ls) if defined $regex; + @ls; +} + + +sub macro { + my($self,%attribs) = @_; + my @m; + foreach my $key (sort keys %attribs) { + my $val = $attribs{$key}; + push @m, "$key = $val\n"; + } + join "", @m; +} + + +sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + s/^(.*)/"-I$1"/ for @{$perlinc || []}; + my(@m); + push @m, " +# --- MakeMaker makeaperl section --- +MAP_TARGET = $target +FULLPERL = $self->{FULLPERL} +MAP_PERLINC = @{$perlinc || []} +"; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ +$(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ + +$(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib + $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR="}, $dir, q{" \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=}; + + foreach (@ARGV){ + my $arg = $_; # avoid lvalue aliasing + if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) { + $arg = $1 . $self->quote_literal($2); + } + push @m, " \\\n\t\t$arg"; + } + push @m, "\n"; + + return join '', @m; + } + + my $cccmd = $self->const_cccmd($libperl); + $cccmd =~ s/^CCCMD\s*=\s*//; + $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /; + $cccmd .= " $Config{cccdlflags}" + if ($Config{useshrplib} eq 'true'); + $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; + + # The front matter of the linkcommand... + my $linkcmd = join ' ', "\$(CC)", + grep($_, @Config{qw(ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; + + # Which *.a files could we make use of... + my $staticlib21 = $self->_find_static_libs($searchdirs); + # We trust that what has been handed in as argument, will be buildable + $static = [] unless $static; + @$staticlib21{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + for (sort keys %$staticlib21) { + next unless /\Q$self->{LIB_EXT}\E\z/; + $_ = dirname($_) . "/extralibs.ld"; + push @$extra, $_; + } + + s/^(.*)/"-I$1"/ for @{$perlinc || []}; + + $target ||= "perl"; + $tmp ||= "."; + +# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we +# regenerate the Makefiles, MAP_STATIC and the dependencies for +# extralibs.all are computed correctly + my @map_static = reverse sort keys %$staticlib21; + push @m, " +MAP_LINKCMD = $linkcmd +MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), " +MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), " + +MAP_PRELIBS = $Config{perllibs} $Config{cryptlib} +"; + + my $lperl; + if (defined $libperl) { + ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/; + } + unless ($libperl && -f $lperl) { # Ilya's code... + my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; + $libperl ||= "libperl$self->{LIB_EXT}"; + $libperl = "$dir/$libperl"; + $lperl ||= "libperl$self->{LIB_EXT}"; + $lperl = "$dir/$lperl"; + + if (! -f $libperl and ! -f $lperl) { + # We did not find a static libperl. Maybe there is a shared one? + if ($Is{SunOS}) { + $lperl = $libperl = "$dir/$Config{libperl}"; + # SUNOS ld does not take the full path to a shared library + $libperl = '' if $Is{SunOS4}; + } + } + + print <{PERL_SRC}); +Warning: $libperl not found +If you're going to build a static perl binary, make sure perl is installed +otherwise ignore this warning +EOF + } + + # SUNOS ld does not take the full path to a shared library + my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl'; + my $libperl_dep = $self->quote_dep($libperl); + + push @m, " +MAP_LIBPERL = $libperl +MAP_LIBPERLDEP = $libperl_dep +LLIBPERL = $llibperl +"; + + push @m, ' +$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).' + $(NOECHO) $(RM_F) $@ + $(NOECHO) $(TOUCH) $@ +'; + + foreach my $catfile (@$extra){ + push @m, "\tcat $catfile >> \$\@\n"; + } + + my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)'; + # 1 2 3 4 + push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename; +$(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all + $(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS) + $(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call" + $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)" + $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean" + +%1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c +EOF + push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n"; + + my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : ''; + push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader; + +%1$s/perlmain.c: %2$s + $(NOECHO) $(ECHO) Writing $@ + $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \ + -e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t + $(MV) $@t $@ + +EOF + push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain" +} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); + + + push @m, q{ +doc_inst_perl : + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Perl binary" "$(MAP_TARGET)" \ + MAP_STATIC "$(MAP_STATIC)" \ + MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ + MAP_LIBPERL "$(MAP_LIBPERL)" \ + >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + +}; + + push @m, q{ +inst_perl : pure_inst_perl doc_inst_perl + +pure_inst_perl : $(MAP_TARGET) + }.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{" + +clean :: map_clean + +map_clean : + }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all +}; + + join '', @m; +} + +# utility method +sub _find_static_libs { + my ($self, $searchdirs) = @_; + # don't use File::Spec here because on Win32 F::F still uses "/" + my $installed_version = join('/', + 'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" + ); + my %staticlib21; + require File::Find; + File::Find::find(sub { + if ($File::Find::name =~ m{/auto/share\z}) { + # in a subdir of auto/share, prune because e.g. + # Alien::pkgconfig uses File::ShareDir to put .a files + # there. do not want + $File::Find::prune = 1; + return; + } + + return unless m/\Q$self->{LIB_EXT}\E$/; + + return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation + + # Skip perl's libraries. + return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/; + + # Skip purified versions of libraries + # (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + # don't include the installed version of this extension. I + # leave this line here, although it is not necessary anymore: + # I patched minimod.PL instead, so that Miniperl.pm won't + # include duplicates + + # Once the patch to minimod.PL is in the distribution, I can + # drop it + return if $File::Find::name =~ m:\Q$installed_version\E\z:; + return if !$self->xs_static_lib_is_xs($_); + use Cwd 'cwd'; + $staticlib21{cwd() . "/" . $_}++; + }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) ); + return \%staticlib21; +} + + +sub xs_static_lib_is_xs { + my ($self, $libfile) = @_; + my $devnull = File::Spec->devnull; + return `nm $libfile 2>$devnull` =~ /\bboot_/; +} + + +sub makefile { + my($self) = shift; + my $m; + # We do not know what target was originally specified so we + # must force a manual rerun to be sure. But as it should only + # happen very rarely it is not a significant problem. + $m = ' +$(OBJECT) : $(FIRST_MAKEFILE) + +' if $self->{OBJECT}; + + my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?'; + my $mpl_args = join " ", map qq["$_"], @ARGV; + my $cross = ''; + if (defined $::Cross::platform) { + # Inherited from win32/buildext.pl + $cross = "-MCross=$::Cross::platform "; + } + $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $mpl_args; +# We take a very conservative approach here, but it's worth it. +# We move Makefile to Makefile.old here to avoid gnu make looping. +$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) + $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s" + $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." + -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) + -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) + - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) + $(PERLRUN) %sMakefile.PL %s + $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" + $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" + $(FALSE) + +MAKE_FRAG + + return $m; +} + + + +sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d $file; + return; +} + + + +sub needs_linking { + my($self) = shift; + + my $caller = (caller(0))[3]; + confess("needs_linking called too early") if + $caller =~ /^ExtUtils::MakeMaker::/; + return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING}; + if ($self->has_link_code or $self->{MAKEAPERL}){ + $self->{NEEDS_LINKING} = 1; + return 1; + } + foreach my $child (keys %{$self->{CHILDREN}}) { + if ($self->{CHILDREN}->{$child}->needs_linking) { + $self->{NEEDS_LINKING} = 1; + return 1; + } + } + return $self->{NEEDS_LINKING} = 0; +} + + + +sub parse_abstract { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + binmode $fh; + my $inpod = 0; + my $pod_encoding; + my $package = $self->{DISTNAME}; + $package =~ s/-/::/g; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if !$inpod; + s#\r*\n\z##; # handle CRLF input + + if ( /^=encoding\s*(.*)$/i ) { + $pod_encoding = $1; + } + + if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) { + $result = $2; + next; + } + next unless $result; + + if ( $result && ( /^\s*$/ || /^\=/ ) ) { + last; + } + $result = join ' ', $result, $_; + } + close $fh; + + if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) { + # Have to wrap in an eval{} for when running under PERL_CORE + # Encode isn't available during build phase and parsing + # ABSTRACT isn't important there + eval { + require Encode; + $result = Encode::decode($pod_encoding, $result); + } + } + + return $result; +} + + +sub parse_version { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + local $_; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if $inpod || /^\s*#/; + chop; + next if /^\s*(if|unless|elsif)/; + if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) { + local $^W = 0; + $result = $1; + } + elsif ( m{(?=!])\=[^=]}x ) { + $result = $self->get_version($parsefile, $1, $2); + } + else { + next; + } + last if defined $result; + } + close $fh; + + if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { version->new( $result ) }; + $result = $normal if defined $normal; + } + $result = "undef" unless defined $result; + return $result; +} + +sub get_version { + my ($self, $parsefile, $sigil, $name) = @_; + my $line = $_; # from the while() loop in parse_version + { + package ExtUtils::MakeMaker::_version; + undef *version; # in case of unexpected version() sub + eval { + require version; + version::->import; + }; + no strict; + local *{$name}; + local $^W = 0; + $line = $1 if $line =~ m{^(.+)}s; + eval($line); ## no critic + return ${$name}; + } +} + + +sub pasthru { + my($self) = shift; + my(@m); + + my(@pasthru); + my($sep) = $Is{VMS} ? ',' : ''; + $sep .= "\\\n\t"; + + foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE + PREFIX INSTALL_BASE) + ) + { + next unless defined $self->{$key}; + push @pasthru, "$key=\"\$($key)\""; + } + + foreach my $key (qw(DEFINE INC)) { + # default to the make var + my $val = qq{\$($key)}; + # expand within perl if given since need to use quote_literal + # since INC might include space-protecting ""! + chomp($val = $self->{$key}) if defined $self->{$key}; + $val .= " \$(PASTHRU_$key)"; + my $quoted = $self->quote_literal($val); + push @pasthru, qq{PASTHRU_$key=$quoted}; + } + + push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; + join "", @m; +} + + +sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return; +} + + +sub perldepend { + my($self) = shift; + my(@m); + + my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm'); + + push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC}; +# Check for unpropogated config.sh changes. Should never happen. +# We do NOT just update config.h because that is not sufficient. +# An out of date config.h is not fatal but complains loudly! +$(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh + -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE) + +$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh + $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" + %s +MAKE_FRAG + + return join "", @m unless $self->needs_linking; + + if ($self->{OBJECT}) { + # Need to add an object file dependency on the perl headers. + # this is very important for XS modules in perl.git development. + push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h + } + + push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; + + return join "\n", @m; +} + + + +sub pm_to_blib { + my $self = shift; + my($autodir) = $self->catdir('$(INST_LIB)','auto'); + my $r = q{ +pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM) +}; + + # VMS will swallow '' and PM_FILTER is often empty. So use q[] + my $pm_to_blib = $self->oneliner(<split_command($pm_to_blib, + map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}}); + + $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds; + $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n}; + + return $r; +} + +# transform dot-separated version string into comma-separated quadruple +# examples: '1.2.3.4.5' => '1,2,3,4' +# '1.2.3' => '1,2,3,0' +sub _ppd_version { + my ($self, $string) = @_; + return join ',', ((split /\./, $string), (0) x 4)[0..3]; +} + + +sub ppd { + my($self) = @_; + + my $abstract = $self->{ABSTRACT} || ''; + $abstract =~ s/\n/\\n/sg; + $abstract =~ s//>/g; + + my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']}); + $author =~ s//>/g; + + my $ppd_file = "$self->{DISTNAME}.ppd"; + + my @ppd_chunks = qq(\n); + + push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author; + %s + %s +PPD_HTML + + push @ppd_chunks, " \n"; + if ( $self->{MIN_PERL_VERSION} ) { + my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION}); + push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version; + +PPD_PERLVERS + + } + + # Don't add "perl" to requires. perl dependencies are + # handles by ARCHITECTURE. + my %prereqs = %{$self->{PREREQ_PM}}; + delete $prereqs{perl}; + + # Build up REQUIRE + foreach my $prereq (sort keys %prereqs) { + my $name = $prereq; + $name .= '::' unless $name =~ /::/; + my $version = $prereqs{$prereq}; + + my %attrs = ( NAME => $name ); + $attrs{VERSION} = $version if $version; + my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs; + push @ppd_chunks, qq( \n); + } + + my $archname = $Config{archname}; + if ($] >= 5.008) { + # archname did not change from 5.6 to 5.8, but those versions may + # not be not binary compatible so now we append the part of the + # version that changes when binary compatibility may change + $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}"; + } + push @ppd_chunks, sprintf <<'PPD_OUT', $archname; + +PPD_OUT + + if ($self->{PPM_INSTALL_SCRIPT}) { + if ($self->{PPM_INSTALL_EXEC}) { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT}; + } + else { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_INSTALL_SCRIPT}; + } + } + + if ($self->{PPM_UNINSTALL_SCRIPT}) { + if ($self->{PPM_UNINSTALL_EXEC}) { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT}; + } + else { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_UNINSTALL_SCRIPT}; + } + } + + my ($bin_location) = $self->{BINARY_LOCATION} || ''; + $bin_location =~ s/\\/\\\\/g; + + push @ppd_chunks, sprintf <<'PPD_XML', $bin_location; + + + +PPD_XML + + my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file); + + return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds; +# Creates a PPD (Perl Package Description) for a binary distribution. +ppd : + %s +PPD_OUT + +} + + +sub prefixify { + my($self,$var,$sprefix,$rprefix,$default) = @_; + + my $path = $self->{uc $var} || + $Config_Override{lc $var} || $Config{lc $var} || ''; + + $rprefix .= '/' if $sprefix =~ m|/$|; + + warn " prefixify $var => $path\n" if $Verbose >= 2; + warn " from $sprefix to $rprefix\n" if $Verbose >= 2; + + if( $self->{ARGS}{PREFIX} && + $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) + { + + warn " cannot prefix, using default.\n" if $Verbose >= 2; + warn " no default!\n" if !$default && $Verbose >= 2; + + $path = $self->catdir($rprefix, $default) if $default; + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; +} + + + +sub processPL { + my $self = shift; + my $pl_files = $self->{PL_FILES}; + + return "" unless $pl_files; + + my $m = ''; + foreach my $plfile (sort keys %$pl_files) { + my $list = ref($pl_files->{$plfile}) + ? $pl_files->{$plfile} + : [$pl_files->{$plfile}]; + + foreach my $target (@$list) { + if( $Is{VMS} ) { + $plfile = vmsify($self->eliminate_macros($plfile)); + $target = vmsify($self->eliminate_macros($target)); + } + + # Normally a .PL file runs AFTER pm_to_blib so it can have + # blib in its @INC and load the just built modules. BUT if + # the generated module is something in $(TO_INST_PM) which + # pm_to_blib depends on then it can't depend on pm_to_blib + # else we have a dependency loop. + my $pm_dep; + my $perlrun; + if( defined $self->{PM}{$target} ) { + $pm_dep = ''; + $perlrun = 'PERLRUN'; + } + else { + $pm_dep = 'pm_to_blib'; + $perlrun = 'PERLRUNINST'; + } + + $m .= <quote_literal($_), @cmds; + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; +} + + + +sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # Quote single quotes + $text =~ s{'}{'\\''}g; + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return "'$text'"; +} + + + +sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{\\\n}g; + + return $text; +} + + + +sub max_exec_len { + my $self = shift; + + if (!defined $self->{_MAX_EXEC_LEN}) { + if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) { + $self->{_MAX_EXEC_LEN} = $arg_max; + } + else { # POSIX minimum exec size + $self->{_MAX_EXEC_LEN} = 4096; + } + } + + return $self->{_MAX_EXEC_LEN}; +} + + + +sub static { +# --- Static Loading Sections --- + + my($self) = shift; + ' +## $(INST_PM) has been moved to the all: target. +## It remains here for awhile to allow for old usage: "make static" +static :: $(FIRST_MAKEFILE) $(INST_STATIC) + $(NOECHO) $(NOOP) +'; +} + +sub static_lib { + my($self) = @_; + return '' unless $self->has_link_code; + my(@m); + my @libs; + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)"); + my $objfile = "$ext\$(OBJ_EXT)"; + push @libs, [ $objfile, $instfile, $instdir ]; + } + } else { + @libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]); + } + push @m, map { $self->xs_make_static_lib(@$_); } @libs; + join "\n", @m; +} + + +sub xs_make_static_lib { + my ($self, $from, $to, $todir) = @_; + my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir; + push @m, "\t\$(RM_F) \"\$\@\"\n"; + push @m, $self->static_lib_fixtures; + push @m, $self->static_lib_pure_cmd($from); + push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; + push @m, $self->static_lib_closures($todir); + join '', @m; +} + + +sub static_lib_closures { + my ($self, $todir) = @_; + my @m = sprintf <<'MAKE_FRAG', $todir; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld +MAKE_FRAG + # Old mechanism - still available: + push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs +MAKE_FRAG + @m; +} + + +sub static_lib_fixtures { + my ($self) = @_; + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + return unless $self->{MYEXTLIB}; + "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n"; +} + + +sub static_lib_pure_cmd { + my ($self, $from) = @_; + my $ar; + if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) { + # Prefer the absolute pathed ar if available so that PATH + # doesn't confuse us. Perl itself is built with the full_ar. + $ar = 'FULL_AR'; + } else { + $ar = 'AR'; + } + sprintf <<'MAKE_FRAG', $ar, $from; + $(%s) $(AR_STATIC_ARGS) "$@" %s + $(RANLIB) "$@" +MAKE_FRAG +} + + +sub staticmake { + my($self, %attribs) = @_; + my(@static); + + my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB}); + + # And as it's not yet built, we add the current extension + # but only if it has some C code (or XS code, which implies C code) + if (@{$self->{C}}) { + @static = $self->catfile($self->{INST_ARCHLIB}, + "auto", + $self->{FULLEXT}, + "$self->{BASEEXT}$self->{LIB_EXT}" + ); + } + + # Either we determine now, which libraries we will produce in the + # subdirectories or we do it at runtime of the make. + + # We could ask all subdir objects, but I cannot imagine, why it + # would be necessary. + + # Instead we determine all libraries for the new perl at + # runtime. + my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB}); + + $self->makeaperl(MAKE => $self->{MAKEFILE}, + DIRS => \@searchdirs, + STAT => \@static, + INCL => \@perlinc, + TARGET => $self->{MAP_TARGET}, + TMP => "", + LIBPERL => $self->{LIBPERL_A} + ); +} + + +sub subdir_x { + my($self, $subdir) = @_; + + my $subdir_cmd = $self->cd($subdir, + '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)' + ); + return sprintf <<'EOT', $subdir_cmd; + +subdirs :: + $(NOECHO) %s +EOT + +} + + +sub subdirs { +# --- Sub-directory Sections --- + my($self) = shift; + my(@m); + # This method provides a mechanism to automatically deal with + # subdirectories containing further Makefile.PL scripts. + # It calls the subdir_x() method for each subdirectory. + foreach my $dir (@{$self->{DIR}}){ + push @m, $self->subdir_x($dir); +#### print "Including $dir subdirectory\n"; + } + if (@m){ + unshift @m, <<'EOF'; + +# The default clean, realclean and test targets in this Makefile +# have automatically been given entries for each subdir. + +EOF + } else { + push(@m, "\n# none") + } + join('',@m); +} + + +sub test { + my($self, %attribs) = @_; + my $tests = $attribs{TESTS} || ''; + if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) { + $tests = $self->find_tests_recursive; + } + elsif (!$tests && -d 't') { + $tests = $self->find_tests; + } + # have to do this because nmake is broken + $tests =~ s!/!\\!g if $self->is_make_type('nmake'); + # note: 'test.pl' name is also hardcoded in init_dirscan() + my @m; + my $default_testtype = $Config{usedl} ? 'dynamic' : 'static'; + push @m, <{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped + push @m, "subdirs-test_$linktype :: $directdeps\n"; + foreach my $dir (@{ $self->{DIR} }) { + my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)"); + push @m, "\t\$(NOECHO) $test\n"; + } + push @m, "\n"; + if ($tests or -f "test.pl") { + for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) { + my ($db, $switch) = @$testspec; + my ($command, $deps); + # if testdb, build all but don't test all + $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype"; + if ($linktype eq 'static' and $self->needs_linking) { + my $target = File::Spec->rel2abs('$(MAP_TARGET)'); + $command = qq{"$target" \$(MAP_PERLINC)}; + $deps .= ' $(MAP_TARGET)'; + } else { + $command = '$(FULLPERLRUN)' . $switch; + } + push @m, "test${db}_$linktype :: $deps\n"; + if ($db eq 'db') { + push @m, $self->test_via_script($command, '$(TEST_FILE)') + } else { + push @m, $self->test_via_script($command, '$(TEST_FILE)') + if -f "test.pl"; + push @m, $self->test_via_harness($command, '$(TEST_FILES)') + if $tests; + } + push @m, "\n"; + } + } else { + push @m, _sprintf562 <<'EOF', $linktype; +testdb_%1$s test_%1$s :: subdirs-test_%1$s + $(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.' + +EOF + } + } + + join "", @m; +} + + +sub test_via_harness { + my($self, $perl, $tests) = @_; + return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests); +} + + +sub test_via_script { + my($self, $perl, $script) = @_; + return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script); +} + + + +sub tool_xsubpp { + my($self) = shift; + return "" unless $self->needs_linking; + + my $xsdir; + my @xsubpp_dirs = @INC; + + # Make sure we pick up the new xsubpp if we're building perl. + unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE}; + + my $foundxsubpp = 0; + foreach my $dir (@xsubpp_dirs) { + $xsdir = $self->catdir($dir, 'ExtUtils'); + if( -r $self->catfile($xsdir, "xsubpp") ) { + $foundxsubpp = 1; + last; + } + } + die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp; + + my $tmdir = $self->catdir($self->{PERL_LIB},"ExtUtils"); + my(@tmdeps) = $self->catfile($tmdir,'typemap'); + if( $self->{TYPEMAPS} ){ + foreach my $typemap (@{$self->{TYPEMAPS}}){ + if( ! -f $typemap ) { + warn "Typemap $typemap not found.\n"; + } + else { + $typemap = vmsify($typemap) if $Is{VMS}; + push(@tmdeps, $typemap); + } + } + } + push(@tmdeps, "typemap") if -f "typemap"; + # absolutised because with deep-located typemaps, eg "lib/XS/typemap", + # if xsubpp is called from top level with + # $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs" + # it says: + # Can't find lib/XS/type map in (fulldir)/lib/XS + # because ExtUtils::ParseXS::process_file chdir's to .xs file's + # location. This is the only way to get all specified typemaps used, + # wherever located. + my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps; + $_ = $self->quote_dep($_) for @tmdeps; + if( exists $self->{XSOPT} ){ + unshift( @tmargs, $self->{XSOPT} ); + } + + if ($Is{VMS} && + $Config{'ldflags'} && + $Config{'ldflags'} =~ m!/Debug!i && + (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/) + ) + { + unshift(@tmargs,'-nolinenumbers'); + } + + + $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG}; + my $xsdirdep = $self->quote_dep($xsdir); + # -dep for use when dependency not command + + return qq{ +XSUBPPDIR = $xsdir +XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp" +XSUBPPRUN = \$(PERLRUN) \$(XSUBPP) +XSPROTOARG = $self->{XSPROTOARG} +XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp +XSUBPPARGS = @tmargs +XSUBPP_EXTRA_ARGS = +}; +} + + + +sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; +all :: pure_all manifypods + $(NOECHO) $(NOOP) +MAKE_EXT +} + + +sub top_targets { +# --- Target Sections --- + + my($self) = shift; + my(@m); + + push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'}; + + push @m, sprintf <<'EOF'; +pure_all :: config pm_to_blib subdirs linkext + $(NOECHO) $(NOOP) + + $(NOECHO) $(NOOP) + +subdirs :: $(MYEXTLIB) + $(NOECHO) $(NOOP) + +config :: $(FIRST_MAKEFILE) blibdirs + $(NOECHO) $(NOOP) +EOF + + push @m, ' +$(O_FILES) : $(H_FILES) +' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; + + push @m, q{ +help : + perldoc ExtUtils::MakeMaker +}; + + join('',@m); +} + + +sub writedoc { +# --- perllocal.pod section --- + my($self,$what,$name,@attribs)=@_; + my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time); + print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n"; + print join "\n\n=item *\n\n", map("C<$_>",@attribs); + print "\n\n=back\n\n"; +} + + +sub xs_c { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.c: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c +'; +} + + +sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' +.xs.cpp: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.cpp +'; +} + + +sub xs_o { + my ($self) = @_; + return '' unless $self->needs_linking(); + my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; + my $frag = ''; + # dmake makes noise about ambiguous rule + $frag .= sprintf <<'EOF', $m_o unless $self->is_make_type('dmake'); +.xs$(OBJ_EXT) : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c + $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c %s +EOF + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my $pmfile = "$ext.pm"; + croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile; + my $version = $self->parse_version($pmfile); + my $cccmd = $self->{CONST_CCCMD}; + $cccmd =~ s/^\s*CCCMD\s*=\s*//; + $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/; + $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/; + $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC'); + my $define = '$(DEFINE)'; + $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE'); + # 1 2 3 4 + $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define; + +%1$s$(OBJ_EXT): %1$s.xs + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c + %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s $*.c %3$s +EOF + } + } + $frag; +} + +# param gets modified +sub _xsbuild_replace_macro { + my ($self, undef, $xstype, $ext, $varname) = @_; + my $value = $self->_xsbuild_value($xstype, $ext, $varname); + return unless defined $value; + $_[1] =~ s/\$\($varname\)/$value/; +} + +sub _xsbuild_value { + my ($self, $xstype, $ext, $varname) = @_; + return $self->{XSBUILD}{$xstype}{$ext}{$varname} + if $self->{XSBUILD}{$xstype}{$ext}{$varname}; + return $self->{XSBUILD}{$xstype}{all}{$varname} + if $self->{XSBUILD}{$xstype}{all}{$varname}; + (); +} + +1; + + +__END__ +package ExtUtils::MM; + +use strict; +use ExtUtils::MakeMaker::Config; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +require ExtUtils::Liblist; +require ExtUtils::MakeMaker; +our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker); + + +{ + # Convenient alias. + package MM; + our @ISA = qw(ExtUtils::MM); + sub DESTROY {} +} + +sub _is_win95 { + # miniperl might not have the Win32 functions available and we need + # to run in miniperl. + my $have_win32 = eval { require Win32 }; + return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95() + : ! defined $ENV{SYSTEMROOT}; +} + +my %Is = (); +$Is{VMS} = $^O eq 'VMS'; +$Is{OS2} = $^O eq 'os2'; +$Is{MacOS} = $^O eq 'MacOS'; +if( $^O eq 'MSWin32' ) { + _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1; +} +$Is{UWIN} = $^O =~ /^uwin(-nt)?$/; +$Is{Cygwin} = $^O eq 'cygwin'; +$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional +$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku'); +$Is{DOS} = $^O eq 'dos'; +if( $Is{NW5} ) { + $^O = 'NetWare'; + delete $Is{Win32}; +} +$Is{VOS} = $^O eq 'vos'; +$Is{QNX} = $^O eq 'qnx'; +$Is{AIX} = $^O eq 'aix'; +$Is{Darwin} = $^O eq 'darwin'; + +$Is{Unix} = !grep { $_ } values %Is; + +map { delete $Is{$_} unless $Is{$_} } keys %Is; +_assert( keys %Is == 1 ); +my($OS) = keys %Is; + + +my $class = "ExtUtils::MM_$OS"; +eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic +die $@ if $@; +unshift @ISA, $class; + + +sub _assert { + my $sanity = shift; + die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity; + return; +} +#--------------------------------------------------------------------------# +# This is a modified copy of version.pm 0.9909, bundled exclusively for +# use by ExtUtils::Makemaker and its dependencies to bootstrap when +# version.pm is not available. It should not be used by ordinary modules. +# +# When loaded, it will try to load version.pm. If that fails, it will load +# ExtUtils::MakeMaker::version::vpp and alias various *version functions +# to functions in that module. It will also override UNIVERSAL::VERSION. +#--------------------------------------------------------------------------# + +package ExtUtils::MakeMaker::version; + +use 5.006001; +use strict; + +use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); + +$VERSION = '7.34'; +$VERSION = eval $VERSION; +$CLASS = 'version'; + +{ + local $SIG{'__DIE__'}; + eval "use version"; + if ( $@ ) { # don't have any version.pm installed + eval "use ExtUtils::MakeMaker::version::vpp"; + die "$@" if ( $@ ); + local $^W; + delete $INC{'version.pm'}; + $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'}; + push @version::ISA, "ExtUtils::MakeMaker::version::vpp"; + $version::VERSION = $VERSION; + *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv; + *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare; + *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; + *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; + *version::new = \&ExtUtils::MakeMaker::version::vpp::new; + if ($] >= 5.009000) { + no strict 'refs'; + *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; + *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; + *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp; + *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse; + } + require ExtUtils::MakeMaker::version::regex; + *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; + *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; + *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; + *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; + } + elsif ( ! version->can('is_qv') ) { + *version::is_qv = sub { exists $_[0]->{qv} }; + } +} + +1; +package ExtUtils::MakeMaker::Config; + +use strict; + +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use Config (); + +# Give us an overridable config. +our %Config = %Config::Config; + +sub import { + my $caller = caller; + + no strict 'refs'; ## no critic + *{$caller.'::Config'} = \%Config; +} + +1; + + +package ExtUtils::MakeMaker::Locale; + +use strict; +our $VERSION = "7.34"; +$VERSION = eval $VERSION; + +use base 'Exporter'; +our @EXPORT_OK = qw( + decode_argv env + $ENCODING_LOCALE $ENCODING_LOCALE_FS + $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT +); + +use Encode (); +use Encode::Alias (); + +our $ENCODING_LOCALE; +our $ENCODING_LOCALE_FS; +our $ENCODING_CONSOLE_IN; +our $ENCODING_CONSOLE_OUT; + +sub DEBUG () { 0 } + +sub _init { + if ($^O eq "MSWin32") { + unless ($ENCODING_LOCALE) { + # Try to obtain what the Windows ANSI code page is + eval { + unless (defined &GetConsoleCP) { + require Win32; + # manually "import" it since Win32->import refuses + *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; + } + unless (defined &GetConsoleCP) { + require Win32::API; + Win32::API->Import('kernel32', 'int GetConsoleCP()'); + } + if (defined &GetConsoleCP) { + my $cp = GetConsoleCP(); + $ENCODING_LOCALE = "cp$cp" if $cp; + } + }; + } + + unless ($ENCODING_CONSOLE_IN) { + # only test one since set together + unless (defined &GetInputCP) { + eval { + require Win32; + eval { Win32::GetConsoleCP() }; + # manually "import" it since Win32->import refuses + *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; + *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP; + }; + unless (defined &GetInputCP) { + eval { + # try Win32::Console module for codepage to use + require Win32::Console; + *GetInputCP = sub { &Win32::Console::InputCP } + if defined &Win32::Console::InputCP; + *GetOutputCP = sub { &Win32::Console::OutputCP } + if defined &Win32::Console::OutputCP; + }; + } + unless (defined &GetInputCP) { + # final fallback + *GetInputCP = *GetOutputCP = sub { + # another fallback that could work is: + # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP + ((qx(chcp) || '') =~ /^Active code page: (\d+)/) + ? $1 : (); + }; + } + } + my $cp = GetInputCP(); + $ENCODING_CONSOLE_IN = "cp$cp" if $cp; + $cp = GetOutputCP(); + $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; + } + } + + unless ($ENCODING_LOCALE) { + eval { + require I18N::Langinfo; + $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); + + # Workaround of Encode < v2.25. The "646" encoding alias was + # introduced in Encode-2.25, but we don't want to require that version + # quite yet. Should avoid the CPAN testers failure reported from + # openbsd-4.7/perl-5.10.0 combo. + $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; + + # https://rt.cpan.org/Ticket/Display.html?id=66373 + $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; + }; + $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; + } + + if ($^O eq "darwin") { + $ENCODING_LOCALE_FS ||= "UTF-8"; + } + + # final fallback + $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; + $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; + $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; + $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; + + unless (Encode::find_encoding($ENCODING_LOCALE)) { + my $foundit; + if (lc($ENCODING_LOCALE) eq "gb18030") { + eval { + require Encode::HanExtra; + }; + if ($@) { + die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; + } + $foundit++ if Encode::find_encoding($ENCODING_LOCALE); + } + die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" + unless $foundit; + + } + + # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; +} + +_init(); +Encode::Alias::define_alias(sub { + no strict 'refs'; + no warnings 'once'; + return ${"ENCODING_" . uc(shift)}; +}, "locale"); + +sub _flush_aliases { + no strict 'refs'; + for my $a (sort keys %Encode::Alias::Alias) { + if (defined ${"ENCODING_" . uc($a)}) { + delete $Encode::Alias::Alias{$a}; + warn "Flushed alias cache for $a" if DEBUG; + } + } +} + +sub reinit { + $ENCODING_LOCALE = shift; + $ENCODING_LOCALE_FS = shift; + $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; + $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; + _init(); + _flush_aliases(); +} + +sub decode_argv { + die if defined wantarray; + for (@ARGV) { + $_ = Encode::decode(locale => $_, @_); + } +} + +sub env { + my $k = Encode::encode(locale => shift); + my $old = $ENV{$k}; + if (@_) { + my $v = shift; + if (defined $v) { + $ENV{$k} = Encode::encode(locale => $v); + } + else { + delete $ENV{$k}; + } + } + return Encode::decode(locale => $old) if defined wantarray; +} + +1; + +__END__ + +package ExtUtils::Constant::Utils; + +use strict; +use vars qw($VERSION @EXPORT_OK @ISA); +use Carp; + +@ISA = 'Exporter'; +@EXPORT_OK = qw(C_stringify perl_stringify); +$VERSION = '0.04'; + +use constant is_perl55 => ($] < 5.005_50); +use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); +use constant is_sane_perl => $] > 5.007; + + +# Hopefully make a happy C identifier. +sub C_stringify { + local $_ = shift; + return unless defined $_; + # grr 5.6.1 + confess "Wide character in '$_' intended as a C identifier" + if tr/\0-\377// != length; + # grr 5.6.1 more so because its regexps will break on data that happens to + # be utf8, which includes my 8 bit test cases. + $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if is_perl56; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + unless (is_perl55) { + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; + } + + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + + +# Hopefully make a happy perl identifier. +sub perl_stringify { + local $_ = shift; + return unless defined $_; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + unless (is_perl55) { + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + if (is_sane_perl) { + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/$cheat/sprintf "\\x{%X}", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; + } + } else { + # Grr 5.6.1. And I don't think I can use utf8; to force the regexp + # because 5.005_03 will fail. + # This is grim, but I also can't split on // + my $copy; + foreach my $index (0 .. length ($_) - 1) { + my $char = substr ($_, $index, 1); + $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; + } + $_ = $copy; + } + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + # Turns out "\x{}" notation only arrived with 5.6 + s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + +1; +__END__ + +package ExtUtils::Constant::ProxySubs; + +use strict; +use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv + %type_to_C_value %type_is_a_problem %type_num_args + %type_temporary); +use Carp; +require ExtUtils::Constant::XS; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_TypeSet); + +$VERSION = '0.09'; +@ISA = 'ExtUtils::Constant::XS'; + +%type_to_struct = + ( + IV => '{const char *name; I32 namelen; IV value;}', + NV => '{const char *name; I32 namelen; NV value;}', + UV => '{const char *name; I32 namelen; UV value;}', + PV => '{const char *name; I32 namelen; const char *value;}', + PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}', + YES => '{const char *name; I32 namelen;}', + NO => '{const char *name; I32 namelen;}', + UNDEF => '{const char *name; I32 namelen;}', + '' => '{const char *name; I32 namelen;} ', + ); + +%type_from_struct = + ( + IV => sub { $_[0] . '->value' }, + NV => sub { $_[0] . '->value' }, + UV => sub { $_[0] . '->value' }, + PV => sub { $_[0] . '->value' }, + PVN => sub { $_[0] . '->value', $_[0] . '->len' }, + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +%type_to_sv = + ( + IV => sub { "newSViv($_[0])" }, + NV => sub { "newSVnv($_[0])" }, + UV => sub { "newSVuv($_[0])" }, + PV => sub { "newSVpv($_[0], 0)" }, + PVN => sub { "newSVpvn($_[0], $_[1])" }, + YES => sub { '&PL_sv_yes' }, + NO => sub { '&PL_sv_no' }, + UNDEF => sub { '&PL_sv_undef' }, + '' => sub { '&PL_sv_yes' }, + SV => sub {"SvREFCNT_inc($_[0])"}, + ); + +%type_to_C_value = + ( + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +sub type_to_C_value { + my ($self, $type) = @_; + return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; +} + +# TODO - figure out if there is a clean way for the type_to_sv code to +# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add +# SvREFCNT_inc +%type_is_a_problem = + ( + # The documentation says *mortal SV*, but we now need a non-mortal copy. + SV => 1, + ); + +%type_temporary = + ( + SV => ['SV *'], + PV => ['const char *'], + PVN => ['const char *', 'STRLEN'], + ); +$type_temporary{$_} = [$_] foreach qw(IV UV NV); + +while (my ($type, $value) = each %XS_TypeSet) { + $type_num_args{$type} + = defined $value ? ref $value ? scalar @$value : 1 : 0; +} +$type_num_args{''} = 0; + +sub partition_names { + my ($self, $default_type, @items) = @_; + my (%found, @notfound, @trouble); + + while (my $item = shift @items) { + my $default = delete $item->{default}; + if ($default) { + # If we find a default value, convert it into a regular item and + # append it to the queue of items to process + my $default_item = {%$item}; + $default_item->{invert_macro} = 1; + $default_item->{pre} = delete $item->{def_pre}; + $default_item->{post} = delete $item->{def_post}; + $default_item->{type} = shift @$default; + $default_item->{value} = $default; + push @items, $default_item; + } else { + # It can be "not found" unless it's the default (invert the macro) + # or the "macro" is an empty string (ie no macro) + push @notfound, $item unless $item->{invert_macro} + or !$self->macro_to_ifdef($self->macro_from_item($item)); + } + + if ($item->{pre} or $item->{post} or $item->{not_constant} + or $type_is_a_problem{$item->{type}}) { + push @trouble, $item; + } else { + push @{$found{$item->{type}}}, $item; + } + } + # use Data::Dumper; print Dumper \%found; + (\%found, \@notfound, \@trouble); +} + +sub boottime_iterator { + my ($self, $type, $iterator, $hash, $subname, $push) = @_; + my $extractor = $type_from_struct{$type}; + die "Can't find extractor code for type $type" + unless defined $extractor; + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + my $athx = $self->C_constant_prefix_param(); + + if ($push) { + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + while ($iterator->name) { + he = $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + av_push(push, newSVhek(HeKEY_hek(he))); + ++$iterator; + } +EOBOOT + } else { + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + while ($iterator->name) { + $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + ++$iterator; + } +EOBOOT + } +} + +sub name_len_value_macro { + my ($self, $item) = @_; + my $name = $item->{name}; + my $value = $item->{value}; + $value = $item->{name} unless defined $value; + + my $namelen = length $name; + if ($name =~ tr/\0-\377// != $namelen) { + # the hash API signals UTF-8 by passing the length negated. + utf8::encode($name); + $namelen = -length $name; + } + $name = C_stringify($name); + + my $macro = $self->macro_from_item($item); + ($name, $namelen, $value, $macro); +} + +sub WriteConstants { + my $self = shift; + my $ARGS = {@_}; + + my ($c_fh, $xs_fh, $c_subname, $default_type, $package) + = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)}; + + my $xs_subname + = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant'; + + my $options = $ARGS->{PROXYSUBS}; + $options = {} unless ref $options; + my $push = $options->{push}; + my $explosives = $options->{croak_on_read}; + my $croak_on_error = $options->{croak_on_error}; + my $autoload = $options->{autoload}; + { + my $exclusive = 0; + ++$exclusive if $explosives; + ++$exclusive if $croak_on_error; + ++$exclusive if $autoload; + + # Until someone patches this (with test cases): + carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together") + if $exclusive > 1; + } + # Strictly it requires Perl_caller_cx + carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later") + if $croak_on_error && $^V < v5.13.5; + # Strictly this is actually 5.8.9, but it's not well tested there + my $can_do_pcs = $] >= 5.009; + # Until someone patches this (with test cases) + carp ("PROXYSUBS option 'push' requires v5.10 or later") + if $push && !$can_do_pcs; + # Until someone patches this (with test cases) + carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together") + if $explosives && $push; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + # All the types we see + my $what = {}; + # A hash to lookup items with. + my $items = {}; + + my @items = $self->normalise_items ({disable_utf8_duplication => 1}, + $default_type, $what, $items, + @{$ARGS->{NAMES}}); + + # Partition the values by type. Also include any defaults in here + # Everything that doesn't have a default needs alternative code for + # "I'm missing" + # And everything that has pre or post code ends up in a private block + my ($found, $notfound, $trouble) + = $self->partition_names($default_type, @items); + + my $pthx = $self->C_constant_prefix_param_defintion(); + my $athx = $self->C_constant_prefix_param(); + my $symbol_table = C_stringify($package) . '::'; + $push = C_stringify($package . '::' . $push) if $push; + my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; + + print $c_fh $self->header(); + if ($autoload || $croak_on_error) { + print $c_fh <<'EOC'; + +/* This allows slightly more efficient code on !USE_ITHREADS: */ +#ifdef USE_ITHREADS +# define COP_FILE(c) CopFILE(c) +# define COP_FILE_F "s" +#else +# define COP_FILE(c) CopFILESV(c) +# define COP_FILE_F SVf +#endif +EOC + } + + my $return_type = $push ? 'HE *' : 'void'; + + print $c_fh <<"EOADD"; + +static $return_type +${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { +EOADD + if (!$can_do_pcs) { + print $c_fh <<'EO_NOPCS'; + if (namelen == namelen) { +EO_NOPCS + } else { + print $c_fh <<"EO_PCS"; + HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL, + 0); + SV *sv; + + if (!he) { + croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", + name); + } + sv = HeVAL(he); + if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) { + /* Someone has been here before us - have to make a real sub. */ +EO_PCS + } + # This piece of code is common to both + print $c_fh <<"EOADD"; + newCONSTSUB(hash, ${cast_CONSTSUB}name, value); +EOADD + if ($can_do_pcs) { + print $c_fh <<'EO_PCS'; + } else { + SvUPGRADE(sv, SVt_RV); + SvRV_set(sv, value); + SvROK_on(sv); + SvREADONLY_on(value); + } +EO_PCS + } else { + print $c_fh <<'EO_NOPCS'; + } +EO_NOPCS + } + print $c_fh " return he;\n" if $push; + print $c_fh <<'EOADD'; +} + +EOADD + + print $c_fh $explosives ? <<"EXPLODE" : "\n"; + +static int +Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_UNUSED_ARG(mg); + croak("Your vendor has not defined $package_sprintf_safe macro %"SVf + " used", sv); + NORETURN_FUNCTION_END; +} + +static MGVTBL not_defined_vtbl = { + Im_sorry_Dave, /* get - I'm afraid I can't do that */ + Im_sorry_Dave, /* set */ + 0, /* len */ + 0, /* clear */ + 0, /* free */ + 0, /* copy */ + 0, /* dup */ +}; + +EXPLODE + +{ + my $key = $symbol_table; + # Just seems tidier (and slightly more space efficient) not to have keys + # such as Fcntl:: + $key =~ s/::$//; + my $key_len = length $key; + + print $c_fh <<"MISSING"; + +#ifndef SYMBIAN + +/* Store a hash of all symbols missing from the package. To avoid trampling on + the package namespace (uninvited) put each package's hash in our namespace. + To avoid creating lots of typeblogs and symbol tables for sub-packages, put + each package's hash into one hash in our namespace. */ + +static HV * +get_missing_hash(pTHX) { + HV *const parent + = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); + /* We could make a hash of hashes directly, but this would confuse anything + at Perl space that looks at us, and as we're visible in Perl space, + best to play nice. */ + SV *const *const ref + = hv_fetch(parent, "$key", $key_len, TRUE); + HV *new_hv; + + if (!ref) + return NULL; + + if (SvROK(*ref)) + return (HV*) SvRV(*ref); + + new_hv = newHV(); + SvUPGRADE(*ref, SVt_RV); + SvRV_set(*ref, (SV *)new_hv); + SvROK_on(*ref); + return new_hv; +} + +#endif + +MISSING + +} + + print $xs_fh <<"EOBOOT"; +BOOT: + { +#if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT) + dTHX; +#endif + HV *symbol_table = get_hv("$symbol_table", GV_ADD); +EOBOOT + if ($push) { + print $xs_fh <<"EOC"; + AV *push = get_av(\"$push\", GV_ADD); + HE *he; +EOC + } + + my %iterator; + + $found->{''} + = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; + + foreach my $type (sort keys %$found) { + my $struct = $type_to_struct{$type}; + my $type_to_value = $self->type_to_C_value($type); + my $number_of_args = $type_num_args{$type}; + die "Can't find structure definition for type $type" + unless defined $struct; + + my $lc_type = $type ? lc($type) : 'notfound'; + my $struct_type = $lc_type . '_s'; + my $array_name = 'values_for_' . $lc_type; + $iterator{$type} = 'value_for_' . $lc_type; + # Give the notfound struct file scope. The others are scoped within the + # BOOT block + my $struct_fh = $type ? $xs_fh : $c_fh; + + print $c_fh "struct $struct_type $struct;\n"; + + print $struct_fh <<"EOBOOT"; + + static const struct $struct_type $array_name\[] = + { +EOBOOT + + + foreach my $item (@{$found->{$type}}) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + + my $ifdef = $self->macro_to_ifdef($macro); + if (!$ifdef && $item->{invert_macro}) { + carp("Attempting to supply a default for '$name' which has no conditional macro"); + next; + } + if ($item->{invert_macro}) { + print $struct_fh $self->macro_to_ifndef($macro); + print $struct_fh + " /* This is the default value: */\n" if $type; + } else { + print $struct_fh $ifdef; + } + print $struct_fh " { ", join (', ', "\"$name\"", $namelen, + &$type_to_value($value)), + " },\n", + $self->macro_to_endif($macro); + } + + # Terminate the list with a NULL + print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; + + print $xs_fh <<"EOBOOT" if $type; + const struct $struct_type *$iterator{$type} = $array_name; +EOBOOT + } + + delete $found->{''}; + + my $add_symbol_subname = $c_subname . '_add_symbol'; + foreach my $type (sort keys %$found) { + print $xs_fh $self->boottime_iterator($type, $iterator{$type}, + 'symbol_table', + $add_symbol_subname, $push); + } + + print $xs_fh <<"EOBOOT"; + if (C_ARRAY_LENGTH(values_for_notfound) > 1) { +#ifndef SYMBIAN + HV *const ${c_subname}_missing = get_missing_hash(aTHX); +#endif + const struct notfound_s *value_for_notfound = values_for_notfound; + do { +EOBOOT + + print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; + SV *tripwire = newSV(0); + + sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); + SvPV_set(tripwire, (char *)value_for_notfound->name); + if(value_for_notfound->namelen >= 0) { + SvCUR_set(tripwire, value_for_notfound->namelen); + } else { + SvCUR_set(tripwire, -value_for_notfound->namelen); + SvUTF8_on(tripwire); + } + SvPOKp_on(tripwire); + SvREADONLY_on(tripwire); + assert(SvLEN(tripwire) == 0); + + $add_symbol_subname($athx symbol_table, value_for_notfound->name, + value_for_notfound->namelen, tripwire); +EXPLODE + + /* Need to add prototypes, else parsing will vary by platform. */ + HE *he = (HE*) hv_common_key_len(symbol_table, + value_for_notfound->name, + value_for_notfound->namelen, + HV_FETCH_LVALUE, NULL, 0); + SV *sv; +#ifndef SYMBIAN + HEK *hek; +#endif + if (!he) { + croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", + value_for_notfound->name); + } + sv = HeVAL(he); + if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) { + /* Nothing was here before, so mark a prototype of "" */ + sv_setpvn(sv, "", 0); + } else if (SvPOK(sv) && SvCUR(sv) == 0) { + /* There is already a prototype of "" - do nothing */ + } else { + /* Someone has been here before us - have to make a real + typeglob. */ + /* It turns out to be incredibly hard to deal with all the + corner cases of sub foo (); and reporting errors correctly, + so lets cheat a bit. Start with a constant subroutine */ + CV *cv = newCONSTSUB(symbol_table, + ${cast_CONSTSUB}value_for_notfound->name, + &PL_sv_yes); + /* and then turn it into a non constant declaration only. */ + SvREFCNT_dec(CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + CvXSUB(cv) = NULL; + CvXSUBANY(cv).any_ptr = NULL; + } +#ifndef SYMBIAN + hek = HeKEY_hek(he); + if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek), + HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE, + &PL_sv_yes, HEK_HASH(hek))) + croak("Couldn't add key '%s' to missing_hash", + value_for_notfound->name); +#endif +DONT + + print $xs_fh " av_push(push, newSVhek(hek));\n" + if $push; + + print $xs_fh <<"EOBOOT"; + } while ((++value_for_notfound)->name); + } +EOBOOT + + foreach my $item (@$trouble) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + my $ifdef = $self->macro_to_ifdef($macro); + my $type = $item->{type}; + my $type_to_value = $self->type_to_C_value($type); + + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + print $xs_fh " {\n"; + # We need to use a temporary value because some really troublesome + # items use C pre processor directives in their values, and in turn + # these don't fit nicely in the macro-ised generator functions + my $counter = 0; + printf $xs_fh " %s temp%d;\n", $_, $counter++ + foreach @{$type_temporary{$type}}; + + print $xs_fh " $item->{pre}\n" if $item->{pre}; + + # And because the code in pre might be both declarations and + # statements, we can't declare and assign to the temporaries in one. + $counter = 0; + printf $xs_fh " temp%d = %s;\n", $counter++, $_ + foreach &$type_to_value($value); + + my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; + printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); + ${c_subname}_add_symbol($athx symbol_table, "%s", + $namelen, %s); +EOBOOT + print $xs_fh " $item->{post}\n" if $item->{post}; + print $xs_fh " }\n"; + + print $xs_fh $self->macro_to_endif($macro); + } + + if ($] >= 5.009) { + print $xs_fh <blk_oldcop : PL_curcop; +EOC + +void +AUTOLOAD() + PROTOTYPE: DISABLE + PREINIT: + SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); + const COP *cop = PL_curcop; +EOA + print $xs_fh <<"EOC"; + PPCODE: +#ifndef SYMBIAN + /* It's not obvious how to calculate this at C pre-processor time. + However, any compiler optimiser worth its salt should be able to + remove the dead code, and hopefully the now-obviously-unused static + function too. */ + HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) + ? get_missing_hash(aTHX) : NULL; + if ((C_ARRAY_LENGTH(values_for_notfound) > 1) + ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used at %" COP_FILE_F " line %" UVuf "\\n", + sv, COP_FILE(cop), (UV)CopLINE(cop)); + } else +#endif + { + sv = newSVpvf("%" SVf + " is not a valid $package_sprintf_safe macro at %" + COP_FILE_F " line %" UVuf "\\n", + sv, COP_FILE(cop), (UV)CopLINE(cop)); + } + croak_sv(sv_2mortal(sv)); +EOC + } else { + print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; + +void +$xs_subname(sv) + INPUT: + SV * sv; + PPCODE: + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + PUSHs(sv_2mortal(sv)); +EXPLODE + +void +$xs_subname(sv) + INPUT: + SV * sv; + PPCODE: +#ifndef SYMBIAN + /* It's not obvious how to calculate this at C pre-processor time. + However, any compiler optimiser worth its salt should be able to + remove the dead code, and hopefully the now-obviously-unused static + function too. */ + HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) + ? get_missing_hash(aTHX) : NULL; + if ((C_ARRAY_LENGTH(values_for_notfound) > 1) + ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + } else +#endif + { + sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro", + sv); + } + PUSHs(sv_2mortal(sv)); +DONT + } +} + +1; +package ExtUtils::Constant::Base; + +use strict; +use vars qw($VERSION); +use Carp; +use Text::Wrap; +use ExtUtils::Constant::Utils qw(C_stringify perl_stringify); +$VERSION = '0.06'; + +use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); + + + +sub valid_type { + # Default to assuming that you don't need different types of return data. + 1; +} +sub default_type { + ''; +} + + +sub header { + '' +} + +# This might actually be a return statement. Note that you are responsible +# for any space you might need before your value, as it lets to perform +# "tricks" such as "return KEY_" and have strings appended. +sub assignment_clause_for_type; +# In which case this might be an empty string +sub return_statement_for_type {undef}; +sub return_statement_for_notdef; +sub return_statement_for_notfound; + +# "#if 1" is true to a C pre-processor +sub macro_from_name { + 1; +} + +sub macro_from_item { + 1; +} + +sub macro_to_ifdef { + my ($self, $macro) = @_; + if (ref $macro) { + return $macro->[0]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return $macro ? "#ifdef $macro\n" : "#if 0\n"; + } + return ""; +} + +sub macro_to_ifndef { + my ($self, $macro) = @_; + if (ref $macro) { + # Can't invert these stylishly, so "bodge it" + return "$macro->[0]#else\n"; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return $macro ? "#ifndef $macro\n" : "#if 1\n"; + } + croak "Can't generate an ifndef for unconditional code"; +} + +sub macro_to_endif { + my ($self, $macro) = @_; + + if (ref $macro) { + return $macro->[1]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return "#endif\n"; + } + return ""; +} + +sub name_param { + 'name'; +} + +# This is possibly buggy, in that it's not mandatory (below, in the main +# C_constant parameters, but is expected to exist here, if it's needed) +# Buggy because if you're definitely pure 8 bit only, and will never be +# presented with your constants in utf8, the default form of C_constant can't +# be told not to do the utf8 version. + +sub is_utf8_param { + 'utf8'; +} + +sub memEQ { + "!memcmp"; +} + + +sub memEQ_clause { +# if (memEQ(name, "thingy", 6)) { + # Which could actually be a character comparison or even "" + my ($self, $args) = @_; + my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $front_chop; + if (ref $checked_at) { + # regexp won't work on 5.6.1 without use utf8; in turn that won't work + # on 5.005_03. + substr ($name, 0, length $$checked_at,) = ''; + $front_chop = C_stringify ($$checked_at); + undef $checked_at; + } + my $len = length $name; + + if ($len < 2) { + return $indent . "{\n" + if (defined $checked_at and $checked_at == 0) or $len == 0; + # We didn't switch, drop through to the code for the 2 character string + $checked_at = 1; + } + + my $name_param = $self->name_param; + + if ($len < 3 and defined $checked_at) { + my $check; + if ($checked_at == 1) { + $check = 0; + } elsif ($checked_at == 0) { + $check = 1; + } + if (defined $check) { + my $char = C_stringify (substr $name, $check, 1); + # Placate 5.005 with a break in the string. I can't see a good way of + # getting it to not take [ as introducing an array lookup, even with + # ${name_param}[$check] + return $indent . "if ($name_param" . "[$check] == '$char') {\n"; + } + } + if (($len == 2 and !defined $checked_at) + or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 1, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n"; + } + if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 2, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n"; + } + + my $pointer = '^'; + my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; + if ($have_checked_last) { + # Checked at the last character, so no need to memEQ it. + $pointer = C_stringify (chop $name); + $len--; + } + + $name = C_stringify ($name); + my $memEQ = $self->memEQ(); + my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n"; + # Put a little ^ under the letter we checked at + # Screws up for non printable and non-7 bit stuff, but that's too hard to + # get right. + if (defined $checked_at) { + $body .= $indent . "/* " . (' ' x length $memEQ) + . (' ' x length $name_param) + . (' ' x $checked_at) . $pointer + . (' ' x ($len - $checked_at + length $len)) . " */\n"; + } elsif (defined $front_chop) { + $body .= $indent . "/* $front_chop" + . (' ' x ($len + 1 + length $len)) . " */\n"; + } + return $body; +} + + +sub dump_names { + my ($self, $args, @items) = @_; + my ($default_type, $what, $indent, $declare_types) + = @{$args}{qw(default_type what indent declare_types)}; + $indent = ' ' x ($indent || 0); + + my $result; + my (@simple, @complex, %used_types); + foreach (@items) { + my $type; + if (ref $_) { + $type = $_->{type} || $default_type; + if ($_->{utf8}) { + # For simplicity always skip the bytes case, and reconstitute this entry + # from its utf8 twin. + next if $_->{utf8} eq 'no'; + # Copy the hashref, as we don't want to mess with the caller's hashref. + $_ = {%$_}; + unless (is_perl56) { + utf8::decode ($_->{name}); + } else { + $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; + } + delete $_->{utf8}; + } + } else { + $_ = {name=>$_}; + $type = $default_type; + } + $used_types{$type}++; + if ($type eq $default_type + # grr 5.6.1 + and length $_->{name} + and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) + and !defined ($_->{macro}) and !defined ($_->{value}) + and !defined ($_->{default}) and !defined ($_->{pre}) + and !defined ($_->{post}) and !defined ($_->{def_pre}) + and !defined ($_->{def_post}) and !defined ($_->{weight})) { + # It's the default type, and the name consists only of A-Za-z0-9_ + push @simple, $_->{name}; + } else { + push @complex, $_; + } + } + + if (!defined $declare_types) { + # Do they pass in any types we weren't already using? + foreach (keys %$what) { + next if $used_types{$_}; + $declare_types++; # Found one in $what that wasn't used. + last; # And one is enough to terminate this loop + } + } + if ($declare_types) { + $result = $indent . 'my $types = {map {($_, 1)} qw(' + . join (" ", sort keys %$what) . ")};\n"; + } + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + $result .= wrap ($indent . "my \@names = (qw(", + $indent . " ", join (" ", sort @simple) . ")"); + if (@complex) { + foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { + my $name = perl_stringify $item->{name}; + my $line = ",\n$indent {name=>\"$name\""; + $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; + foreach my $thing (qw (macro value default pre post def_pre def_post)) { + my $value = $item->{$thing}; + if (defined $value) { + if (ref $value) { + $line .= ", $thing=>[\"" + . join ('", "', map {perl_stringify $_} @$value) . '"]'; + } else { + $line .= ", $thing=>\"" . perl_stringify($value) . "\""; + } + } + } + $line .= "}"; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + $line =~ s!\*\/!\*" . "/!gs; + # gcc -Wall doesn't like finding /* inside a comment + $line =~ s!\/\*!/" . "\*!gs; + $result .= $line; + } + } + $result .= ");\n"; + + $result; +} + +# Hmm. value undef to do NOTDEF? value () to do NOTFOUND? + +sub assign { + my $self = shift; + my $args = shift; + my ($indent, $type, $pre, $post, $item) + = @{$args}{qw(indent type pre post item)}; + $post ||= ''; + my $clause; + my $close; + if ($pre) { + chomp $pre; + $close = "$indent}\n"; + $clause = $indent . "{\n"; + $indent .= " "; + $clause .= "$indent$pre"; + $clause .= ";" unless $pre =~ /;$/; + $clause .= "\n"; + } + confess "undef \$type" unless defined $type; + confess "Can't generate code for type $type" + unless $self->valid_type($type); + + $clause .= join '', map {"$indent$_\n"} + $self->assignment_clause_for_type({type=>$type,item=>$item}, @_); + chomp $post; + if (length $post) { + $clause .= "$post"; + $clause .= ";" unless $post =~ /;$/; + $clause .= "\n"; + } + my $return = $self->return_statement_for_type($type); + $clause .= "$indent$return\n" if defined $return; + $clause .= $close if $close; + return $clause; +} + + +sub return_clause { + +##ifdef thingy +# *iv_return = thingy; +# return PERL_constant_ISIV; +##else +# return PERL_constant_NOTDEF; +##endif + my ($self, $args, $item) = @_; + my $indent = $args->{indent}; + + my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type) + = @$item{qw (name value default pre post def_pre def_post type)}; + $value = $name unless defined $value; + my $macro = $self->macro_from_item($item); + $indent = ' ' x ($indent || 6); + unless (defined $type) { + # use Data::Dumper; print STDERR Dumper ($item); + confess "undef \$type"; + } + + ##ifdef thingy + my $clause = $self->macro_to_ifdef($macro); + + # *iv_return = thingy; + # return PERL_constant_ISIV; + $clause + .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post, + item=>$item}, ref $value ? @$value : $value); + + if (defined $macro && $macro ne "" && $macro ne "1") { + ##else + $clause .= "#else\n"; + + # return PERL_constant_NOTDEF; + if (!defined $default) { + my $notdef = $self->return_statement_for_notdef(); + $clause .= "$indent$notdef\n" if defined $notdef; + } else { + my @default = ref $default ? @$default : $default; + $type = shift @default; + $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, + post=>$post, item=>$item}, @default); + } + } + ##endif + $clause .= $self->macro_to_endif($macro); + + return $clause; +} + +sub match_clause { + # $offset defined if we have checked an offset. + my ($self, $args, $item) = @_; + my ($offset, $indent) = @{$args}{qw(checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $body = ''; + my ($no, $yes, $either, $name, $inner_indent); + if (ref $item eq 'ARRAY') { + ($yes, $no) = @$item; + $either = $yes || $no; + confess "$item is $either expecting hashref in [0] || [1]" + unless ref $either eq 'HASH'; + $name = $either->{name}; + } else { + confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" + if $item->{utf8}; + $name = $item->{name}; + $inner_indent = $indent; + } + + $body .= $self->memEQ_clause ({name => $name, checked_at => $offset, + indent => length $indent}); + # If we've been presented with an arrayref for $item, then the user string + # contains in the range 128-255, and we need to check whether it was utf8 + # (or not). + # In the worst case we have two named constants, where one's name happens + # encoded in UTF8 happens to be the same byte sequence as the second's + # encoded in (say) ISO-8859-1. + # In this case, $yes and $no both have item hashrefs. + if ($yes) { + $body .= $indent . " if (" . $self->is_utf8_param . ") {\n"; + } elsif ($no) { + $body .= $indent . " if (!" . $self->is_utf8_param . ") {\n"; + } + if ($either) { + $body .= $self->return_clause ({indent=>4 + length $indent}, $either); + if ($yes and $no) { + $body .= $indent . " } else {\n"; + $body .= $self->return_clause ({indent=>4 + length $indent}, $no); + } + $body .= $indent . " }\n"; + } else { + $body .= $self->return_clause ({indent=>2 + length $indent}, $item); + } + $body .= $indent . "}\n"; +} + + + +sub switch_clause { + my ($self, $args, $namelen, $items, @items) = @_; + my ($indent, $comment) = @{$args}{qw(indent comment)}; + $indent = ' ' x ($indent || 2); + + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + + my @names = sort map {$_->{name}} @items; + my $leader = $indent . '/* '; + my $follower = ' ' x length $leader; + my $body = $indent . "/* Names all of length $namelen. */\n"; + if (defined $comment) { + $body = wrap ($leader, $follower, $comment) . "\n"; + $leader = $follower; + } + my @safe_names = @names; + foreach (@safe_names) { + confess sprintf "Name '$_' is length %d, not $namelen", length + unless length == $namelen; + # Argh. 5.6.1 + # next unless tr/A-Za-z0-9_//c; + next if tr/A-Za-z0-9_// == length; + $_ = '"' . perl_stringify ($_) . '"'; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + s!\*\/!\*"."/!gs; + # gcc -Wall doesn't like finding /* inside a comment + s!\/\*!/"."\*!gs; + } + $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; + # Figure out what to switch on. + # (RMS, Spread of jump table, Position, Hashref) + my @best = (1e38, ~0); + # Prefer the last character over the others. (As it lets us shorten the + # memEQ clause at no cost). + foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { + my ($min, $max) = (~0, 0); + my %spread; + if (is_perl56) { + # Need proper Unicode preserving hash keys for bytes in range 128-255 + # here too, for some reason. grr 5.6.1 yet again. + tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; + } + foreach (@names) { + my $char = substr $_, $i, 1; + my $ord = ord $char; + confess "char $ord is out of range" if $ord > 255; + $max = $ord if $ord > $max; + $min = $ord if $ord < $min; + push @{$spread{$char}}, $_; + # warn "$_ $char"; + } + # I'm going to pick the character to split on that minimises the root + # mean square of the number of names in each case. Normally this should + # be the one with the most keys, but it may pick a 7 where the 8 has + # one long linear search. I'm not sure if RMS or just sum of squares is + # actually better. + # $max and $min are for the tie-breaker if the root mean squares match. + # Assuming that the compiler may be building a jump table for the + # switch() then try to minimise the size of that jump table. + # Finally use < not <= so that if it still ties the earliest part of + # the string wins. Because if that passes but the memEQ fails, it may + # only need the start of the string to bin the choice. + # I think. But I'm micro-optimising. :-) + # OK. Trump that. Now favour the last character of the string, before the + # rest. + my $ss; + $ss += @$_ * @$_ foreach values %spread; + my $rms = sqrt ($ss / keys %spread); + if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { + @best = ($rms, $max - $min, $i, \%spread); + } + } + confess "Internal error. Failed to pick a switch point for @names" + unless defined $best[2]; + # use Data::Dumper; print Dumper (@best); + my ($offset, $best) = @best[2,3]; + $body .= $indent . "/* Offset $offset gives the best switch position. */\n"; + + my $do_front_chop = $offset == 0 && $namelen > 2; + if ($do_front_chop) { + $body .= $indent . "switch (*" . $self->name_param() . "++) {\n"; + } else { + $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n"; + } + foreach my $char (sort keys %$best) { + confess sprintf "'$char' is %d bytes long, not 1", length $char + if length ($char) != 1; + confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; + $body .= $indent . "case '" . C_stringify ($char) . "':\n"; + foreach my $thisone (sort { + # Deal with the case of an item actually being an array ref to 1 or 2 + # hashrefs. Don't assign to $a or $b, as they're aliases to the + # original + my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a; + my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b; + # Sort by weight first + ($r->{weight} || 0) <=> ($l->{weight} || 0) + # Sort equal weights by name + or $l->{name} cmp $r->{name}} + # If this looks evil, maybe it is. $items is a + # hashref, and we're doing a hash slice on it + @{$items}{@{$best->{$char}}}) { + # warn "You are here"; + if ($do_front_chop) { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => \$char}, $thisone); + } else { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => $offset}, $thisone); + } + } + $body .= $indent . " break;\n"; + } + $body .= $indent . "}\n"; + return $body; +} + +sub C_constant_return_type { + "static int"; +} + +sub C_constant_prefix_param { + ''; +} + +sub C_constant_prefix_param_defintion { + ''; +} + +sub name_param_definition { + "const char *" . $_[0]->name_param; +} + +sub namelen_param { + 'len'; +} + +sub namelen_param_definition { + 'size_t ' . $_[0]->namelen_param; +} + +sub C_constant_other_params { + ''; +} + +sub C_constant_other_params_defintion { + ''; +} + + +sub params { + ''; +} + + + +sub dogfood { + '' +} + + +sub normalise_items +{ + my $self = shift; + my $args = shift; + my $default_type = shift; + my $what = shift; + my $items = shift; + my @new_items; + foreach my $orig (@_) { + my ($name, $item); + if (ref $orig) { + # Make a copy which is a normalised version of the ref passed in. + $name = $orig->{name}; + my ($type, $macro, $value) = @$orig{qw (type macro value)}; + $type ||= $default_type; + $what->{$type} = 1; + $item = {name=>$name, type=>$type}; + + undef $macro if defined $macro and $macro eq $name; + $item->{macro} = $macro if defined $macro; + undef $value if defined $value and $value eq $name; + $item->{value} = $value if defined $value; + foreach my $key (qw(default pre post def_pre def_post weight + not_constant)) { + my $value = $orig->{$key}; + $item->{$key} = $value if defined $value; + # warn "$key $value"; + } + } else { + $name = $orig; + $item = {name=>$name, type=>$default_type}; + $what->{$default_type} = 1; + } + warn +(ref ($self) || $self) + . "doesn't know how to handle values of type $_ used in macro $name" + unless $self->valid_type ($item->{type}); + # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c + # doesn't work. Upgrade to 5.8 + # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { + if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50 + || $args->{disable_utf8_duplication}) { + # No characters outside 7 bit ASCII. + if (exists $items->{$name}) { + die "Multiple definitions for macro $name"; + } + $items->{$name} = $item; + } else { + # No characters outside 8 bit. This is hardest. + if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { + confess "Unexpected ASCII definition for macro $name"; + } + # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; + # if ($name !~ tr/\0-\377//c) { + if ($name =~ tr/\0-\377// == length $name) { +# if ($] < 5.007) { +# $name = pack "C*", unpack "U*", $name; +# } + $item->{utf8} = 'no'; + $items->{$name}[1] = $item; + push @new_items, $item; + # Copy item, to create the utf8 variant. + $item = {%$item}; + } + # Encode the name as utf8 bytes. + unless (is_perl56) { + utf8::encode($name); + } else { +# warn "Was >$name< " . length ${name}; + $name = pack 'C*', unpack 'C*', $name . pack 'U*'; +# warn "Now '${name}' " . length ${name}; + } + if ($items->{$name}[0]) { + die "Multiple definitions for macro $name"; + } + $item->{utf8} = 'yes'; + $item->{name} = $name; + $items->{$name}[0] = $item; + # We have need for the utf8 flag. + $what->{''} = 1; + } + push @new_items, $item; + } + @new_items; +} + + +# The parameter now BREAKOUT was previously documented as: +# +# I if defined signals that all the Is of the Is are of +# this length, and that the constant name passed in by perl is checked and +# also of this length. It is used during recursion, and should be C +# unless the caller has checked all the lengths during code generation, and +# the generated subroutine is only to be called with a name of this length. +# +# As you can see it now performs this function during recursion by being a +# scalar reference. + +sub C_constant { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type types indent breakout)}; + $package ||= 'Foo'; + $subname ||= 'constant'; + # I'm not using this. But a hashref could be used for full formatting without + # breaking this API + # $indent ||= 0; + + my ($namelen, $items); + if (ref $breakout) { + # We are called recursively. We trust @items to be normalised, $what to + # be a hashref, and pinch %$items from our parent to save recalculation. + ($namelen, $items) = @$breakout; + } else { + $items = {}; + if (is_perl56) { + # Need proper Unicode preserving hash keys. + require ExtUtils::Constant::Aaargh56Hash; + tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; + } + $breakout ||= 3; + $default_type ||= $self->default_type(); + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what || '')}; + # Figure out what types we're dealing with, and assign all unknowns to the + # default type + } + @items = $self->normalise_items ({}, $default_type, $what, $items, @items); + # use Data::Dumper; print Dumper @items; + } + my $params = $self->params ($what); + + # Probably "static int" + my ($body, @subs); + $body = $self->C_constant_return_type($params) . "\n$subname (" + # Eg "pTHX_ " + . $self->C_constant_prefix_param_defintion($params) + # Probably "const char *name" + . $self->name_param_definition($params); + # Something like ", STRLEN len" + $body .= ", " . $self->namelen_param_definition($params) + unless defined $namelen; + $body .= $self->C_constant_other_params_defintion($params); + $body .= ") {\n"; + + if (defined $namelen) { + # We are a child subroutine. Print the simple description + my $comment = 'When generated this function returned values for the list' + . ' of names given here. However, subsequent manual editing may have' + . ' added or removed some.'; + $body .= $self->switch_clause ({indent=>2, comment=>$comment}, + $namelen, $items, @items); + } else { + # We are the top level. + $body .= " /* Initially switch on the length of the name. */\n"; + $body .= $self->dogfood ({package => $package, subname => $subname, + default_type => $default_type, what => $what, + indent => $indent, breakout => $breakout}, + @items); + $body .= ' switch ('.$self->namelen_param().") {\n"; + # Need to group names of the same length + my @by_length; + foreach (@items) { + push @{$by_length[length $_->{name}]}, $_; + } + foreach my $i (0 .. $#by_length) { + next unless $by_length[$i]; # None of this length + $body .= " case $i:\n"; + if (@{$by_length[$i]} == 1) { + my $only_thing = $by_length[$i]->[0]; + if ($only_thing->{utf8}) { + if ($only_thing->{utf8} eq 'yes') { + # With utf8 on flag item is passed in element 0 + $body .= $self->match_clause (undef, [$only_thing]); + } else { + # With utf8 off flag item is passed in element 1 + $body .= $self->match_clause (undef, [undef, $only_thing]); + } + } else { + $body .= $self->match_clause (undef, $only_thing); + } + } elsif (@{$by_length[$i]} < $breakout) { + $body .= $self->switch_clause ({indent=>4}, + $i, $items, @{$by_length[$i]}); + } else { + # Only use the minimal set of parameters actually needed by the types + # of the names of this length. + my $what = {}; + foreach (@{$by_length[$i]}) { + $what->{$_->{type}} = 1; + $what->{''} = 1 if $_->{utf8}; + } + $params = $self->params ($what); + push @subs, $self->C_constant ({package=>$package, + subname=>"${subname}_$i", + default_type => $default_type, + types => $what, indent => $indent, + breakout => [$i, $items]}, + @{$by_length[$i]}); + $body .= " return ${subname}_$i (" + # Eg "aTHX_ " + . $self->C_constant_prefix_param($params) + # Probably "name" + . $self->name_param($params); + $body .= $self->C_constant_other_params($params); + $body .= ");\n"; + } + $body .= " break;\n"; + } + $body .= " }\n"; + } + my $notfound = $self->return_statement_for_notfound(); + $body .= " $notfound\n" if $notfound; + $body .= "}\n"; + return (@subs, $body); +} + +1; +__END__ + +package ExtUtils::Constant::XS; + +use strict; +use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56); +use Carp; +use ExtUtils::Constant::Utils 'perl_stringify'; +require ExtUtils::Constant::Base; + + +@ISA = qw(ExtUtils::Constant::Base Exporter); +@EXPORT_OK = qw(%XS_Constant %XS_TypeSet); + +$VERSION = '0.03'; + +$is_perl56 = ($] < 5.007 && $] > 5.005_50); + + +# '' is used as a flag to indicate non-ascii macro names, and hence the need +# to pass in the utf8 on/off flag. +%XS_Constant = ( + '' => '', + IV => 'PUSHi(iv)', + UV => 'PUSHu((UV)iv)', + NV => 'PUSHn(nv)', + PV => 'PUSHp(pv, strlen(pv))', + PVN => 'PUSHp(pv, iv)', + SV => 'PUSHs(sv)', + YES => 'PUSHs(&PL_sv_yes)', + NO => 'PUSHs(&PL_sv_no)', + UNDEF => '', # implicit undef +); + +%XS_TypeSet = ( + IV => '*iv_return = ', + UV => '*iv_return = (IV)', + NV => '*nv_return = ', + PV => '*pv_return = ', + PVN => ['*pv_return = ', '*iv_return = (IV)'], + SV => '*sv_return = ', + YES => undef, + NO => undef, + UNDEF => undef, +); + +sub header { + my $start = 1; + my @lines; + push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; + push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; + foreach (sort keys %XS_Constant) { + next if $_ eq ''; + push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; + } + push @lines, << 'EOT'; + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif +EOT + + return join '', @lines; +} + +sub valid_type { + my ($self, $type) = @_; + return exists $XS_TypeSet{$type}; +} + +# This might actually be a return statement +sub assignment_clause_for_type { + my $self = shift; + my $args = shift; + my $type = $args->{type}; + my $typeset = $XS_TypeSet{$type}; + if (ref $typeset) { + die "Type $type is aggregate, but only single value given" + if @_ == 1; + return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset; + } elsif (defined $typeset) { + confess "Aggregate value given for type $type" + if @_ > 1; + return "$typeset$_[0];"; + } + return (); +} + +sub return_statement_for_type { + my ($self, $type) = @_; + # In the future may pass in an options hash + $type = $type->{type} if ref $type; + "return PERL_constant_IS$type;"; +} + +sub return_statement_for_notdef { + # my ($self) = @_; + "return PERL_constant_NOTDEF;"; +} + +sub return_statement_for_notfound { + # my ($self) = @_; + "return PERL_constant_NOTFOUND;"; +} + +sub default_type { + 'IV'; +} + +sub macro_from_name { + my ($self, $item) = @_; + my $macro = $item->{name}; + $macro = $item->{value} unless defined $macro; + $macro; +} + +sub macro_from_item { + my ($self, $item) = @_; + my $macro = $item->{macro}; + $macro = $self->macro_from_name($item) unless defined $macro; + $macro; +} + +# Keep to the traditional perl source macro +sub memEQ { + "memEQ"; +} + +sub params { + my ($self, $what) = @_; + foreach (sort keys %$what) { + warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; + } + my $params = {}; + $params->{''} = 1 if $what->{''}; + $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; + $params->{NV} = 1 if $what->{NV}; + $params->{PV} = 1 if $what->{PV} || $what->{PVN}; + $params->{SV} = 1 if $what->{SV}; + return $params; +} + + +sub C_constant_prefix_param { + "aTHX_ "; +} + +sub C_constant_prefix_param_defintion { + "pTHX_ "; +} + +sub namelen_param_definition { + 'STRLEN ' . $_[0] -> namelen_param; +} + +sub C_constant_other_params_defintion { + my ($self, $params) = @_; + my $body = ''; + $body .= ", int utf8" if $params->{''}; + $body .= ", IV *iv_return" if $params->{IV}; + $body .= ", NV *nv_return" if $params->{NV}; + $body .= ", const char **pv_return" if $params->{PV}; + $body .= ", SV **sv_return" if $params->{SV}; + $body; +} + +sub C_constant_other_params { + my ($self, $params) = @_; + my $body = ''; + $body .= ", utf8" if $params->{''}; + $body .= ", iv_return" if $params->{IV}; + $body .= ", nv_return" if $params->{NV}; + $body .= ", pv_return" if $params->{PV}; + $body .= ", sv_return" if $params->{SV}; + $body; +} + +sub dogfood { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type what indent breakout)}; + my $result = <<"EOT"; + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!$^X -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +EOT + $result .= $self->dump_names ({default_type=>$default_type, what=>$what, + indent=>0, declare_types=>1}, + @items); + $result .= <<'EOT'; + +print constant_types(), "\n"; # macro defs +EOT + $package = perl_stringify($package); + $result .= + "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; + # The form of the indent parameter isn't defined. (Yet) + if (defined $indent) { + require Data::Dumper; + $Data::Dumper::Terse=1; + $Data::Dumper::Terse=1; # Not used once. :-) + chomp ($indent = Data::Dumper::Dumper ($indent)); + $result .= $indent; + } else { + $result .= 'undef'; + } + $result .= ", $breakout" . ', @names) ) { + print $_, "\n"; # C constant subs +} +print "\n#### XS Section:\n"; +print XS_constant ("' . $package . '", $types); +__END__ + */ + +'; + + $result; +} + +1; +package ExtUtils::CBuilder::Base; +use strict; +use warnings; +use File::Spec; +use File::Basename; +use Cwd (); +use Config; +use Text::ParseWords; +use IPC::Cmd qw(can_run); +use File::Temp qw(tempfile); + +our $VERSION = '0.280230'; # VERSION + +# More details about C/C++ compilers: +# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp +# http://gcc.gnu.org/ +# http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp +# http://msdn.microsoft.com/en-us/vstudio/default.aspx + +my %cc2cxx = ( + # first line order is important to support wrappers like in pkgsrc + cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers + gcc => [ 'g++' ], # GNU Compiler Collection + xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety + xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety + cl => [ 'cl' ], # Microsoft Visual Studio +); + +sub new { + my $class = shift; + my $self = bless {@_}, $class; + + $self->{properties}{perl} = $class->find_perl_interpreter + or warn "Warning: Can't locate your perl binary"; + + while (my ($k,$v) = each %Config) { + $self->{config}{$k} = $v unless exists $self->{config}{$k}; + } + $self->{config}{cc} = $ENV{CC} if defined $ENV{CC}; + $self->{config}{ccflags} = join(" ", $self->{config}{ccflags}, $ENV{CFLAGS}) + if defined $ENV{CFLAGS}; + $self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX}; + $self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS}; + $self->{config}{ld} = $ENV{LD} if defined $ENV{LD}; + $self->{config}{ldflags} = join(" ", $self->{config}{ldflags}, $ENV{LDFLAGS}) + if defined $ENV{LDFLAGS}; + + unless ( exists $self->{config}{cxx} ) { + + my ($ccbase, $ccpath, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); + + ## If the path is just "cc", fileparse returns $ccpath as "./" + $ccpath = "" if $self->{config}{cc} =~ /^$ccbase$ccsfx$/; + + foreach my $cxx (@{$cc2cxx{$ccbase}}) { + my $cxx1 = File::Spec->catfile( $ccpath, $cxx . $ccsfx); + + if( can_run( $cxx1 ) ) { + $self->{config}{cxx} = $cxx1; + last; + } + my $cxx2 = $cxx . $ccsfx; + + if( can_run( $cxx2 ) ) { + $self->{config}{cxx} = $cxx2; + last; + } + + if( can_run( $cxx ) ) { + $self->{config}{cxx} = $cxx; + last; + } + } + unless ( exists $self->{config}{cxx} ) { + $self->{config}{cxx} = $self->{config}{cc}; + my $cflags = $self->{config}{ccflags}; + $self->{config}{cxxflags} = '-x c++'; + $self->{config}{cxxflags} .= " $cflags" if defined $cflags; + } + } + + return $self; +} + +sub find_perl_interpreter { + my $perl; + File::Spec->file_name_is_absolute($perl = $^X) + or -f ($perl = $Config::Config{perlpath}) + or ($perl = $^X); # XXX how about using IPC::Cmd::can_run here? + return $perl; +} + +sub add_to_cleanup { + my $self = shift; + foreach (@_) { + $self->{files_to_clean}{$_} = 1; + } +} + +sub cleanup { + my $self = shift; + foreach my $file (keys %{$self->{files_to_clean}}) { + unlink $file; + } +} + +sub get_config { + return %{ $_[0]->{config} }; +} + +sub object_file { + my ($self, $filename) = @_; + + # File name, minus the suffix + (my $file_base = $filename) =~ s/\.[^.]+$//; + return "$file_base$self->{config}{obj_ext}"; +} + +sub arg_include_dirs { + my $self = shift; + return map {"-I$_"} @_; +} + +sub arg_nolink { '-c' } + +sub arg_object_file { + my ($self, $file) = @_; + return ('-o', $file); +} + +sub arg_share_object_file { + my ($self, $file) = @_; + return ($self->split_like_shell($self->{config}{lddlflags}), '-o', $file); +} + +sub arg_exec_file { + my ($self, $file) = @_; + return ('-o', $file); +} + +sub arg_defines { + my ($self, %args) = @_; + return map "-D$_=$args{$_}", sort keys %args; +} + +sub compile { + my ($self, %args) = @_; + die "Missing 'source' argument to compile()" unless defined $args{source}; + + my $cf = $self->{config}; # For convenience + + my $object_file = $args{object_file} + ? $args{object_file} + : $self->object_file($args{source}); + + my $include_dirs_ref = + (exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY") + ? [ $args{include_dirs} ] + : $args{include_dirs}; + my @include_dirs = $self->arg_include_dirs( + @{ $include_dirs_ref || [] }, + $self->perl_inc(), + ); + + my @defines = $self->arg_defines( %{$args{defines} || {}} ); + + my @extra_compiler_flags = + $self->split_like_shell($args{extra_compiler_flags}); + my @cccdlflags = $self->split_like_shell($cf->{cccdlflags}); + my @ccflags = $self->split_like_shell($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags}); + my @optimize = $self->split_like_shell($cf->{optimize}); + my @flags = ( + @include_dirs, + @defines, + @cccdlflags, + @extra_compiler_flags, + $self->arg_nolink, + @ccflags, + @optimize, + $self->arg_object_file($object_file), + ); + my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc}); + + $self->do_system(@cc, @flags, $args{source}) + or die "error building $object_file from '$args{source}'"; + + return $object_file; +} + +sub have_compiler { + my ($self, $is_cplusplus) = @_; + my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc"; + my $suffix = $is_cplusplus ? ".cc" : ".c"; + return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag}; + + my $result; + my $attempts = 3; + # tmpdir has issues for some people so fall back to current dir + + # don't clobber existing files (rare, but possible) + my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix ); + binmode $FH; + + if ( $is_cplusplus ) { + print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; + } + else { + print $FH "int boot_compilet() { return 1; }\n"; + } + close $FH; + + my ($obj_file, @lib_files); + eval { + local $^W = 0; + local $self->{quiet} = 1; + $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile); + @lib_files = $self->link(objects => $obj_file, module_name => 'compilet'); + }; + $result = $@ ? 0 : 1; + + foreach (grep defined, $tmpfile, $obj_file, @lib_files) { + 1 while unlink; + } + + return $self->{$have_compiler_flag} = $result; +} + +sub have_cplusplus { + push @_, 1; + goto &have_compiler; +} + +sub lib_file { + my ($self, $dl_file, %args) = @_; + $dl_file =~ s/\.[^.]+$//; + $dl_file =~ tr/"//d; + + if (defined $args{module_name} and length $args{module_name}) { + # Need to create with the same name as DynaLoader will load with. + require DynaLoader; + if (defined &DynaLoader::mod2fname) { + my $lib = DynaLoader::mod2fname([split /::/, $args{module_name}]); + my ($dev, $lib_dir, undef) = File::Spec->splitpath($dl_file); + $dl_file = File::Spec->catpath($dev, $lib_dir, $lib); + } + } + + $dl_file .= ".$self->{config}{dlext}"; + + return $dl_file; +} + + +sub exe_file { + my ($self, $dl_file) = @_; + $dl_file =~ s/\.[^.]+$//; + $dl_file =~ tr/"//d; + return "$dl_file$self->{config}{_exe}"; +} + +sub need_prelink { 0 } + +sub extra_link_args_after_prelink { return } + +sub prelink { + my ($self, %args) = @_; + + my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args); + + require ExtUtils::Mksymlists; + # dl. abbrev for dynamic library + ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } ); + + # Mksymlists will create one of these files + return grep -e, map "$dl_file_out.$_", qw(ext def opt); +} + +sub _prepare_mksymlists_args { + my $args = shift; + ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file}; + + my %mksymlists_args = ( + DL_VARS => $args->{dl_vars} || [], + DL_FUNCS => $args->{dl_funcs} || {}, + FUNCLIST => $args->{dl_func_list} || [], + IMPORTS => $args->{dl_imports} || {}, + NAME => $args->{dl_name}, # Name of the Perl module + DLBASE => $args->{dl_base}, # Basename of DLL file + FILE => $args->{dl_file}, # Dir + Basename of symlist file + VERSION => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'), + ); + return ($args->{dl_file}, \%mksymlists_args); +} + +sub link { + my ($self, %args) = @_; + return $self->_do_link('lib_file', lddl => 1, %args); +} + +sub link_executable { + my ($self, %args) = @_; + return $self->_do_link('exe_file', lddl => 0, %args); +} + +sub _do_link { + my ($self, $type, %args) = @_; + + my $cf = $self->{config}; # For convenience + + my $objects = delete $args{objects}; + $objects = [$objects] unless ref $objects; + my $out = $args{$type} || $self->$type($objects->[0], %args); + + my @temp_files; + @temp_files = + $self->prelink(%args, dl_name => $args{module_name}) + if $args{lddl} && $self->need_prelink; + + my @linker_flags = ( + $self->split_like_shell($args{extra_linker_flags}), + $self->extra_link_args_after_prelink( + %args, dl_name => $args{module_name}, prelink_res => \@temp_files + ) + ); + + my @output = $args{lddl} + ? $self->arg_share_object_file($out) + : $self->arg_exec_file($out); + my @shrp = $self->split_like_shell($cf->{shrpenv}); + my @ld = $self->split_like_shell($cf->{ld}); + + $self->do_system(@shrp, @ld, @output, @$objects, @linker_flags) + or die "error building $out from @$objects"; + + return wantarray ? ($out, @temp_files) : $out; +} + + +sub do_system { + my ($self, @cmd) = @_; + print "@cmd\n" if !$self->{quiet}; + return !system(@cmd); +} + +sub split_like_shell { + my ($self, $string) = @_; + + return () unless defined($string); + return @$string if UNIVERSAL::isa($string, 'ARRAY'); + $string =~ s/^\s+|\s+$//g; + return () unless length($string); + + # Text::ParseWords replaces all 'escaped' characters with themselves, which completely + # breaks paths under windows. As such, we forcibly replace backwards slashes with forward + # slashes on windows. + $string =~ s@\\@/@g if $^O eq 'MSWin32'; + + return Text::ParseWords::shellwords($string); +} + +# if building perl, perl's main source directory +sub perl_src { + # N.B. makemaker actually searches regardless of PERL_CORE, but + # only squawks at not finding it if PERL_CORE is set + + return unless $ENV{PERL_CORE}; + + my $Updir = File::Spec->updir; + my $dir = File::Spec->curdir; + + # Try up to 5 levels upwards + for (0..10) { + if ( + -f File::Spec->catfile($dir,"config_h.SH") + && + -f File::Spec->catfile($dir,"perl.h") + && + -f File::Spec->catfile($dir,"lib","Exporter.pm") + ) { + return Cwd::realpath( $dir ); + } + + $dir = File::Spec->catdir($dir, $Updir); + } + + warn "PERL_CORE is set but I can't find your perl source!\n"; + return ''; # return empty string if $ENV{PERL_CORE} but can't find dir ??? +} + +# directory of perl's include files +sub perl_inc { + my $self = shift; + + $self->perl_src() || File::Spec->catdir($self->{config}{archlibexp},"CORE"); +} + +sub DESTROY { + my $self = shift; + local($., $@, $!, $^E, $?); + $self->cleanup(); +} + +1; + +# vim: ts=2 sw=2 et: +package ExtUtils::CBuilder::Platform::Windows; +use strict; +use warnings; + +use File::Basename; +use File::Spec; + +use ExtUtils::CBuilder::Base; +use IO::File; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); + + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + my $cf = $self->{config}; + + # Inherit from an appropriate compiler driver class + my $driver = "ExtUtils::CBuilder::Platform::Windows::" . $self->_compiler_type; + eval "require $driver" or die "Could not load compiler driver: $@"; + unshift @ISA, $driver; + + return $self; +} + +sub _compiler_type { + my $self = shift; + my $cc = $self->{config}{cc}; + + return ( $cc =~ /cl(\.exe)?$/ ? 'MSVC' + : $cc =~ /bcc32(\.exe)?$/ ? 'BCC' + : 'GCC'); +} + +sub split_like_shell { + # Since Windows will pass the whole command string (not an argument + # array) to the target program and make the program parse it itself, + # we don't actually need to do any processing here. + (my $self, local $_) = @_; + + return @$_ if defined() && UNIVERSAL::isa($_, 'ARRAY'); + return unless defined() && length(); + return ($_); +} + +sub do_system { + # See above + my $self = shift; + my $cmd = join(" ", + grep length, + map {$a=$_;$a=~s/\t/ /g;$a=~s/^\s+|\s+$//;$a} + grep defined, @_); + return $self->SUPER::do_system($cmd); +} + +sub arg_defines { + my ($self, %args) = @_; + s/"/\\"/g foreach values %args; + return map qq{"-D$_=$args{$_}"}, sort keys %args; +} + +sub compile { + my ($self, %args) = @_; + my $cf = $self->{config}; + + die "Missing 'source' argument to compile()" unless defined $args{source}; + + $args{include_dirs} = [ $args{include_dirs} ] + if exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY"; + + my ($basename, $srcdir) = + ( File::Basename::fileparse($args{source}, '\.[^.]+$') )[0,1]; + + $srcdir ||= File::Spec->curdir(); + + my @defines = $self->arg_defines( %{ $args{defines} || {} } ); + + my %spec = ( + srcdir => $srcdir, + builddir => $srcdir, + basename => $basename, + source => $args{source}, + output => $args{object_file} || File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext}, + cc => $cf->{cc}, + cflags => [ + $self->split_like_shell($cf->{ccflags}), + $self->split_like_shell($cf->{cccdlflags}), + $self->split_like_shell($args{extra_compiler_flags}), + ], + optimize => [ $self->split_like_shell($cf->{optimize}) ], + defines => \@defines, + includes => [ @{$args{include_dirs} || []} ], + perlinc => [ + $self->perl_inc(), + $self->split_like_shell($cf->{incpath}), + ], + use_scripts => 1, # XXX provide user option to change this??? + ); + + $self->normalize_filespecs( + \$spec{source}, + \$spec{output}, + $spec{includes}, + $spec{perlinc}, + ); + + my @cmds = $self->format_compiler_cmd(%spec); + while ( my $cmd = shift @cmds ) { + $self->do_system( @$cmd ) + or die "error building $cf->{dlext} file from '$args{source}'"; + } + + (my $out = $spec{output}) =~ tr/'"//d; + return $out; +} + +sub need_prelink { 1 } + +sub link { + my ($self, %args) = @_; + my $cf = $self->{config}; + + my @objects = ( ref $args{objects} eq 'ARRAY' ? @{$args{objects}} : $args{objects} ); + my $to = join '', (File::Spec->splitpath($objects[0]))[0,1]; + $to ||= File::Spec->curdir(); + + (my $file_base = $args{module_name}) =~ s/.*:://; + my $output = $args{lib_file} || + File::Spec->catfile($to, "$file_base.$cf->{dlext}"); + + # if running in perl source tree, look for libs there, not installed + my $lddlflags = $cf->{lddlflags}; + my $perl_src = $self->perl_src(); + $lddlflags =~ s{\Q$cf->{archlibexp}\E[\\/]CORE}{$perl_src/lib/CORE} if $perl_src; + + my %spec = ( + srcdir => $to, + builddir => $to, + startup => [ ], + objects => \@objects, + libs => [ ], + output => $output, + ld => $cf->{ld}, + libperl => $cf->{libperl}, + perllibs => [ $self->split_like_shell($cf->{perllibs}) ], + libpath => [ $self->split_like_shell($cf->{libpth}) ], + lddlflags => [ $self->split_like_shell($lddlflags) ], + other_ldflags => [ $self->split_like_shell($args{extra_linker_flags} || '') ], + use_scripts => 1, # XXX provide user option to change this??? + ); + + unless ( $spec{basename} ) { + ($spec{basename} = $args{module_name}) =~ s/.*:://; + } + + $spec{srcdir} = File::Spec->canonpath( $spec{srcdir} ); + $spec{builddir} = File::Spec->canonpath( $spec{builddir} ); + + $spec{output} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.'.$cf->{dlext} ); + $spec{manifest} ||= $spec{output} . '.manifest'; + $spec{implib} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . $cf->{lib_ext} ); + $spec{explib} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.exp' ); + if ($cf->{cc} eq 'cl') { + $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.pdb' ); + } + elsif ($cf->{cc} eq 'bcc32') { + $spec{dbg_file} ||= File::Spec->catfile( $spec{builddir}, + $spec{basename} . '.tds' ); + } + $spec{def_file} ||= File::Spec->catfile( $spec{srcdir} , + $spec{basename} . '.def' ); + $spec{base_file} ||= File::Spec->catfile( $spec{srcdir} , + $spec{basename} . '.base' ); + + $self->add_to_cleanup( + grep defined, + @{[ @spec{qw(manifest implib explib dbg_file def_file base_file map_file)} ]} + ); + + foreach my $opt ( qw(output manifest implib explib dbg_file def_file map_file base_file) ) { + $self->normalize_filespecs( \$spec{$opt} ); + } + + foreach my $opt ( qw(libpath startup objects) ) { + $self->normalize_filespecs( $spec{$opt} ); + } + + (my $def_base = $spec{def_file}) =~ tr/'"//d; + $def_base =~ s/\.def$//; + $self->prelink( %args, + dl_name => $args{module_name}, + dl_file => $def_base, + dl_base => $spec{basename} ); + + my @cmds = $self->format_linker_cmd(%spec); + while ( my $cmd = shift @cmds ) { + $self->do_system( @$cmd ); + } + + $spec{output} =~ tr/'"//d; + return wantarray + ? grep defined, @spec{qw[output manifest implib explib dbg_file def_file map_file base_file]} + : $spec{output}; +} + +# canonize & quote paths +sub normalize_filespecs { + my ($self, @specs) = @_; + foreach my $spec ( grep defined, @specs ) { + if ( ref $spec eq 'ARRAY') { + $self->normalize_filespecs( map {\$_} grep defined, @$spec ) + } elsif ( ref $spec eq 'SCALAR' ) { + $$spec =~ tr/"//d if $$spec; + next unless $$spec; + $$spec = '"' . File::Spec->canonpath($$spec) . '"'; + } elsif ( ref $spec eq '' ) { + $spec = '"' . File::Spec->canonpath($spec) . '"'; + } else { + die "Don't know how to normalize " . (ref $spec || $spec) . "\n"; + } + } +} + +# directory of perl's include files +sub perl_inc { + my $self = shift; + + my $perl_src = $self->perl_src(); + + if ($perl_src) { + File::Spec->catdir($perl_src, "lib", "CORE"); + } else { + File::Spec->catdir($self->{config}{archlibexp},"CORE"); + } +} + +1; + +__END__ + +package ExtUtils::CBuilder::Platform::VMS; + +use warnings; +use strict; +use ExtUtils::CBuilder::Base; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); + +use File::Spec::Functions qw(catfile catdir); +use Config; + +# We do prelink, but don't want the parent to redo it. + +sub need_prelink { 0 } + +sub arg_defines { + my ($self, %args) = @_; + + s/"/""/g foreach values %args; + + my @config_defines; + + # VMS can only have one define qualifier; add the one from config, if any. + if ($self->{config}{ccflags} =~ s{/ def[^=]+ =+ \(? ([^\/\)]*) } {}ix) { + push @config_defines, $1; + } + + return '' unless keys(%args) || @config_defines; + + return ('/define=(' + . join(',', + @config_defines, + map "\"$_" . ( length($args{$_}) ? "=$args{$_}" : '') . "\"", + sort keys %args) + . ')'); +} + +sub arg_include_dirs { + my ($self, @dirs) = @_; + + # VMS can only have one include list, add the one from config. + if ($self->{config}{ccflags} =~ s{/inc[^=]+(?:=)+(?:\()?([^\/\)]*)} {}i) { + unshift @dirs, $1; + } + return unless @dirs; + + return ('/include=(' . join(',', @dirs) . ')'); +} + +# We override the compile method because we consume the includes and defines +# parts of ccflags in the process of compiling but don't save those parts +# anywhere, so $self->{config}{ccflags} needs to be reset for each compile +# operation. + +sub compile { + my ($self, %args) = @_; + + $self->{config}{ccflags} = $Config{ccflags}; + $self->{config}{ccflags} = $ENV{CFLAGS} if defined $ENV{CFLAGS}; + + return $self->SUPER::compile(%args); +} + +sub _do_link { + my ($self, $type, %args) = @_; + + my $objects = delete $args{objects}; + $objects = [$objects] unless ref $objects; + + if ($args{lddl}) { + + # prelink will call Mksymlists, which creates the extension-specific + # linker options file and populates it with the boot symbol. + + my @temp_files = $self->prelink(%args, dl_name => $args{module_name}); + + # We now add the rest of what we need to the linker options file. We + # should replicate the functionality of C, + # but there is as yet no infrastructure for handling object libraries, + # so for now we depend on object files being listed individually on the + # command line, which should work for simple cases. We do bring in our + # own version of C so that any additional + # libraries (including PERLSHR) can be added to the options file. + + my @optlibs = $self->_liblist_ext( $args{'libs'} ); + + my $optfile = 'sys$disk:[]' . $temp_files[0]; + open my $opt_fh, '>>', $optfile + or die "_do_link: Unable to open $optfile: $!"; + for my $lib (@optlibs) {print $opt_fh "$lib\n" if length $lib } + close $opt_fh; + + $objects->[-1] .= ','; + push @$objects, $optfile . '/OPTIONS,'; + + # This one not needed for DEC C, but leave for completeness. + push @$objects, $self->perl_inc() . 'perlshr_attr.opt/OPTIONS'; + } + + return $self->SUPER::_do_link($type, %args, objects => $objects); +} + +sub arg_nolink { return; } + +sub arg_object_file { + my ($self, $file) = @_; + return "/obj=$file"; +} + +sub arg_exec_file { + my ($self, $file) = @_; + return ("/exe=$file"); +} + +sub arg_share_object_file { + my ($self, $file) = @_; + return ("$self->{config}{lddlflags}=$file"); +} + +# The following is reproduced almost verbatim from ExtUtils::Liblist::Kid::_vms_ext. +# We can't just call that because it's tied up with the MakeMaker object hierarchy. + +sub _liblist_ext { + my($self, $potential_libs,$verbose,$give_libs) = @_; + $verbose ||= 0; + + my(@crtls,$crtlstr); + @crtls = ( ($self->{'config'}{'ldflags'} =~ m-/Debug-i ? $self->{'config'}{'dbgprefix'} : '') + . 'PerlShr/Share' ); + push(@crtls, grep { not /\(/ } split /\s+/, $self->{'config'}{'perllibs'}); + push(@crtls, grep { not /\(/ } split /\s+/, $self->{'config'}{'libc'}); + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to ensure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ($self->perl_src) { + my($lib,$locspec,$type); + foreach $lib (@crtls) { + if (($locspec,$type) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i) { + if (lc $type eq '/share') { $locspec .= $self->{'config'}{'exe_ext'}; } + elsif (lc $type eq '/library') { $locspec .= $self->{'config'}{'lib_ext'}; } + else { $locspec .= $self->{'config'}{'obj_ext'}; } + $locspec = catfile($self->perl_src, $locspec); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join(' ',@crtls) : ''; + + unless ($potential_libs) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ('', '', $crtlstr, '', ($give_libs ? [] : ())); + } + + my(@dirs,@libs,$dir,$lib,%found,@fndlibs,$ldlib); + my $cwd = cwd(); + my($so,$lib_ext,$obj_ext) = @{$self->{'config'}}{'so','lib_ext','obj_ext'}; + # List of common Unix library names and their VMS equivalents + # (VMS equivalent of '' indicates that the library is automatically + # searched by the linker, and should be skipped here.) + my(@flibs, %libs_seen); + my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', + 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', + 'socket' => '', 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR'); + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + foreach $lib (split ' ',$potential_libs) { + push(@dirs,$1), next if $lib =~ /^-L(.*)/; + push(@dirs,$lib), next if $lib =~ /[:>\]]$/; + push(@dirs,$lib), next if -d $lib; + push(@libs,$1), next if $lib =~ /^-l(.*)/; + push(@libs,$lib); + } + push(@dirs,split(' ',$self->{'config'}{'libpth'})); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach $dir (@dirs) { + unless (-d $dir) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if (!File::Spec->file_name_is_absolute($dir)) { + $dir = catdir($cwd,$dir); + } + } + @dirs = grep { length($_) } @dirs; + unshift(@dirs,''); # Check each $lib without additions first + + LIB: foreach $lib (@libs) { + if (exists $libmap{$lib}) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my(@variants,$variant,$cand); + my($ctype) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ($lib !~ /\.[^:>\]]*$/) { + push(@variants,"${lib}shr","${lib}rtl","${lib}lib"); + push(@variants,"lib$lib") if $lib !~ /[:>\]]/; + } + push(@variants,$lib); + warn "Looking for $lib\n" if $verbose; + foreach $variant (@variants) { + my($fullname, $name); + + foreach $dir (@dirs) { + my($type); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + $fullname = VMS::Filespec::rmsexpand($name); + if (defined $fullname and -f $fullname) { + # It's got its own suffix, so we'll have to figure out the type + if ($fullname =~ /(?:$so|exe)$/i) { $type = 'SHR'; } + elsif ($fullname =~ /(?:$lib_ext|olb)$/i) { $type = 'OLB'; } + elsif ($fullname =~ /(?:$obj_ext|obj)$/i) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + } + else { + warn "Note (probably harmless): " + ."Unknown library type for $fullname; assuming shared\n"; + $type = 'SHR'; + } + } + elsif (-f ($fullname = VMS::Filespec::rmsexpand($name,$so)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.exe'))) { + $type = 'SHR'; + $name = $fullname unless $fullname =~ /exe;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$lib_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.olb')))) { + $type = 'OLB'; + $name = $fullname unless $fullname =~ /olb;?\d*$/i; + } + elsif (not length($ctype) and # If we've got a lib already, + # don't bother + ( -f ($fullname = VMS::Filespec::rmsexpand($name,$obj_ext)) or + -f ($fullname = VMS::Filespec::rmsexpand($name,'.obj')))) { + warn "Note (probably harmless): " + ."Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + $name = $fullname unless $fullname =~ /obj;?\d*$/i; + } + if (defined $type) { + $ctype = $type; $cand = $name; + last if $ctype eq 'SHR'; + } + } + if ($ctype) { + push @{$found{$ctype}}, $cand; + warn "\tFound as $cand (really $fullname), type $ctype\n" + if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; + next LIB; + } + } + warn "Note (probably harmless): " + ."No library found for $lib\n"; + } + + push @fndlibs, @{$found{OBJ}} if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{$found{OLB}} if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{$found{SHR}} if exists $found{SHR}; + $lib = join(' ',@fndlibs); + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ($lib, '', $ldlib, '', ($give_libs ? \@flibs : ())) : $lib; +} + +1; +package ExtUtils::CBuilder::Platform::os2; + +use warnings; +use strict; +use ExtUtils::CBuilder::Platform::Unix; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub need_prelink { 1 } + +sub prelink { + # Generate import libraries (XXXX currently near .DEF; should be near DLL!) + my $self = shift; + my %args = @_; + + my @res = $self->SUPER::prelink(%args); + die "Unexpected number of DEF files" unless @res == 1; + die "Can't find DEF file in the output" + unless $res[0] =~ m,^(.*)\.def$,si; + my $libname = "$1$self->{config}{lib_ext}"; # Put .LIB file near .DEF file + $self->do_system('emximp', '-o', $libname, $res[0]) or die "emxexp: res=$?"; + return (@res, $libname); +} + +sub _do_link { + my $self = shift; + my ($how, %args) = @_; + if ($how eq 'lib_file' + and (defined $args{module_name} and length $args{module_name})) { + + # Now know the basename, find directory parts via lib_file, or objects + my $objs = ( (ref $args{objects}) ? $args{objects} : [$args{objects}] ); + my $near_obj = $self->lib_file(@$objs); + my $exp_dir = ($near_obj =~ m,(.*)[/\\],s ? "$1/" : '' ); + + $args{dl_file} = $1 if $near_obj =~ m,(.*)\.,s; # put ExportList near OBJ + + # XXX _do_link does not have place to put libraries? + push @$objs, $self->perl_inc() . "/libperl$self->{config}{lib_ext}"; + $args{objects} = $objs; + } + # Some 'env' do exec(), thus return too early when run from ksh; + # To avoid 'env', remove (useless) shrpenv + local $self->{config}{shrpenv} = ''; + return $self->SUPER::_do_link($how, %args); +} + +sub extra_link_args_after_prelink { + # Add .DEF file to the link line + my ($self, %args) = @_; + + my @DEF = grep /\.def$/i, @{$args{prelink_res}}; + die "More than one .def files created by 'prelink' stage" if @DEF > 1; + # XXXX No "$how" argument here, so how to test for dynamic link? + die "No .def file created by 'prelink' stage" + unless @DEF or not @{$args{prelink_res}}; + + my @after_libs = ($OS2::is_aout ? () + : $self->perl_inc() . "/libperl_override$self->{config}{lib_ext}"); + # , "-L", "-lperl" + (@after_libs, @DEF); +} + +sub link_executable { + # ldflags is not expecting .exe extension given on command line; remove -Zexe + my $self = shift; + local $self->{config}{ldflags} = $self->{config}{ldflags}; + $self->{config}{ldflags} =~ s/(?SUPER::link_executable(@_); +} + + +1; +package ExtUtils::CBuilder::Platform::dec_osf; + +use warnings; +use strict; +use ExtUtils::CBuilder::Platform::Unix; +use File::Spec; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub link_executable { + my $self = shift; + # $Config{ld} is 'ld' but that won't work: use the cc instead. + local $self->{config}{ld} = $self->{config}{cc}; + return $self->SUPER::link_executable(@_); +} + +1; +package ExtUtils::CBuilder::Platform::darwin; + +use warnings; +use strict; +use ExtUtils::CBuilder::Platform::Unix; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub compile { + my $self = shift; + my $cf = $self->{config}; + + # -flat_namespace isn't a compile flag, it's a linker flag. But + # it's mistakenly in Config.pm as both. Make the correction here. + local $cf->{ccflags} = $cf->{ccflags}; + $cf->{ccflags} =~ s/-flat_namespace//; + $self->SUPER::compile(@_); +} + + +1; +package ExtUtils::CBuilder::Platform::cygwin; + +use warnings; +use strict; +use File::Spec; +use ExtUtils::CBuilder::Platform::Unix; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +# TODO: If a specific exe_file name is requested, if the exe created +# doesn't have that name, we might want to rename it. Apparently asking +# for an exe of "foo" might result in "foo.exe". Alternatively, we should +# make sure the return value is correctly "foo.exe". +# C.f http://rt.cpan.org/Public/Bug/Display.html?id=41003 +sub link_executable { + my $self = shift; + return $self->SUPER::link_executable(@_); +} + +sub link { + my ($self, %args) = @_; + + my $lib = $self->{config}{useshrplib} ? 'libperl.dll.a' : 'libperl.a'; + $args{extra_linker_flags} = [ + File::Spec->catfile($self->perl_inc(), $lib), + $self->split_like_shell($args{extra_linker_flags}) + ]; + + return $self->SUPER::link(%args); +} + +1; +package ExtUtils::CBuilder::Platform::android; + +use warnings; +use strict; +use File::Spec; +use ExtUtils::CBuilder::Platform::Unix; +use Config; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +# The Android linker will not recognize symbols from +# libperl unless the module explicitly depends on it. +sub link { + my ($self, %args) = @_; + + if ($self->{config}{useshrplib} eq 'true') { + $args{extra_linker_flags} = [ + $self->split_like_shell($args{extra_linker_flags}), + '-L' . $self->perl_inc(), + '-lperl', + $self->split_like_shell($Config{perllibs}), + ]; + } + + # Several modules on CPAN rather rightfully expect being + # able to pass $so_file to DynaLoader::dl_load_file and + # have it Just Work. However, $so_file will more likely + # than not be a relative path, and unless the module + # author subclasses MakeMaker/Module::Build to modify + # LD_LIBRARY_PATH, which would be insane, Android's linker + # won't find the .so + # So we make this all work by returning an absolute path. + my($so_file, @so_tmps) = $self->SUPER::link(%args); + $so_file = File::Spec->rel2abs($so_file); + return wantarray ? ($so_file, @so_tmps) : $so_file; +} + +1; +package ExtUtils::CBuilder::Platform::aix; + +use warnings; +use strict; +use ExtUtils::CBuilder::Platform::Unix; +use File::Spec; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Platform::Unix); + +sub need_prelink { 1 } + +sub link { + my ($self, %args) = @_; + my $cf = $self->{config}; + + (my $baseext = $args{module_name}) =~ s/.*:://; + my $perl_inc = $self->perl_inc(); + + # Massage some very naughty bits in %Config + local $cf->{lddlflags} = $cf->{lddlflags}; + for ($cf->{lddlflags}) { + s/\Q$(BASEEXT)\E/$baseext/; + s/\Q$(PERL_INC)\E/$perl_inc/; + } + + return $self->SUPER::link(%args); +} + + +1; +package ExtUtils::CBuilder::Platform::Unix; + +use warnings; +use strict; +use ExtUtils::CBuilder::Base; + +our $VERSION = '0.280230'; # VERSION +our @ISA = qw(ExtUtils::CBuilder::Base); + +sub link_executable { + my $self = shift; + + # On some platforms (which ones??) $Config{cc} seems to be a better + # bet for linking executables than $Config{ld}. Cygwin is a notable + # exception. + local $self->{config}{ld} = + $self->{config}{cc} . " " . $self->{config}{ldflags}; + return $self->SUPER::link_executable(@_); +} + +sub link { + my $self = shift; + my $cf = $self->{config}; + + # Some platforms (notably Mac OS X 10.3, but some others too) expect + # the syntax "FOO=BAR /bin/command arg arg" to work in %Config + # (notably $Config{ld}). It usually works in system(SCALAR), but we + # use system(LIST). We fix it up here with 'env'. + + local $cf->{ld} = $cf->{ld}; + if (ref $cf->{ld}) { + unshift @{$cf->{ld}}, 'env' if $cf->{ld}[0] =~ /^\s*\w+=/; + } else { + $cf->{ld} =~ s/^(\s*\w+=)/env $1/; + } + + return $self->SUPER::link(@_); +} + +1; +package ExtUtils::CBuilder::Platform::Windows::MSVC; + +our $VERSION = '0.280230'; # VERSION + +use warnings; +use strict; + +sub arg_exec_file { + my ($self, $file) = @_; + return "/OUT:$file"; +} + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + %spec = $self->write_compiler_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{cc},'-nologo','-c', + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + "-Fo$spec{output}" , + $spec{source} , + ) ]; +} + +sub write_compiler_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.ccs' ); + + $self->add_to_cleanup($script); + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(includes cflags optimize defines perlinc) } ) + ); + + push @{$spec{includes}}, '@"' . $script . '"'; + + return %spec; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + my $cf = $self->{config}; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-libpath:$path"; + } + + my $output = $spec{output}; + my $manifest = $spec{manifest}; + + $spec{def_file} &&= '-def:' . $spec{def_file}; + $spec{output} &&= '-out:' . $spec{output}; + $spec{manifest} &&= '-manifest ' . $spec{manifest}; + $spec{implib} &&= '-implib:' . $spec{implib}; + $spec{map_file} &&= '-map:' . $spec{map_file}; + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + my @cmds; # Stores the series of commands needed to build the module. + + push @cmds, [ grep {defined && length} ( + $spec{ld} , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{other_ldflags}} , + @{$spec{startup}} , + @{$spec{objects}} , + $spec{map_file} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{def_file} , + $spec{implib} , + $spec{output} , + ) ]; + + # Embed the manifest file if it exists + push @cmds, [ + 'if', 'exist', $manifest, 'mt', '-nologo', $spec{manifest}, '-outputresource:' . "$output;2" + ]; + + return @cmds; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(lddlflags libpath other_ldflags + startup objects libperl perllibs + def_file implib map_file) } ) + ); + + push @{$spec{lddlflags}}, '@"' . $script . '"'; + + return %spec; +} + +1; + + +package ExtUtils::CBuilder::Platform::Windows::BCC; + +our $VERSION = '0.280230'; # VERSION + +use strict; +use warnings; + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + %spec = $self->write_compiler_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{cc}, '-c' , + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + "-o$spec{output}" , + $spec{source} , + ) ]; +} + +sub write_compiler_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.ccs' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + # XXX Borland "response files" seem to be unable to accept macro + # definitions containing quoted strings. Escaping strings with + # backslash doesn't work, and any level of quotes are stripped. The + # result is a floating point number in the source file where a + # string is expected. So we leave the macros on the command line. + print $SCRIPT join( "\n", + map { ref $_ ? @{$_} : $_ } + grep defined, + delete( + @spec{ qw(includes cflags optimize perlinc) } ) + ); + + push @{$spec{includes}}, '@"' . $script . '"'; + + return %spec; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-L$path"; + } + + push( @{$spec{startup}}, 'c0d32.obj' ) + unless ( $spec{startup} && @{$spec{startup}} ); + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + return [ grep {defined && length} ( + $spec{ld} , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{other_ldflags}} , + @{$spec{startup}} , + @{$spec{objects}} , ',', + $spec{output} , ',', + $spec{map_file} , ',', + $spec{libperl} , + @{$spec{perllibs}} , ',', + $spec{def_file} + ) ]; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + # To work around Borlands "unique" commandline syntax, + # two scripts are used: + + my $ld_script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + my $ld_libs = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lbs' ); + + $self->add_to_cleanup($ld_script, $ld_libs); + + print "Generating scripts '$ld_script' and '$ld_libs'.\n" if !$self->{quiet}; + + # Script 1: contains options & names of object files. + my $LD_SCRIPT = IO::File->new( ">$ld_script" ) + or die( "Could not create linker script '$ld_script': $!" ); + + print $LD_SCRIPT join( " +\n", + map { @{$_} } + grep defined, + delete( + @spec{ qw(lddlflags libpath other_ldflags startup objects) } ) + ); + + # Script 2: contains name of libs to link against. + my $LD_LIBS = IO::File->new( ">$ld_libs" ) + or die( "Could not create linker script '$ld_libs': $!" ); + + print $LD_LIBS join( " +\n", + (delete $spec{libperl} || ''), + @{delete $spec{perllibs} || []}, + ); + + push @{$spec{lddlflags}}, '@"' . $ld_script . '"'; + push @{$spec{perllibs}}, '@"' . $ld_libs . '"'; + + return %spec; +} + +1; + + +package ExtUtils::CBuilder::Platform::Windows::GCC; + +our $VERSION = '0.280230'; # VERSION + +use warnings; +use strict; + +sub format_compiler_cmd { + my ($self, %spec) = @_; + + foreach my $path ( @{ $spec{includes} || [] }, + @{ $spec{perlinc} || [] } ) { + $path = '-I' . $path; + } + + # split off any -arguments included in cc + my @cc = split / (?=-)/, $spec{cc}; + + return [ grep {defined && length} ( + @cc, '-c' , + @{$spec{includes}} , + @{$spec{cflags}} , + @{$spec{optimize}} , + @{$spec{defines}} , + @{$spec{perlinc}} , + '-o', $spec{output} , + $spec{source} , + ) ]; +} + +sub format_linker_cmd { + my ($self, %spec) = @_; + my $cf = $self->{config}; + + # The Config.pm variable 'libperl' is hardcoded to the full name + # of the perl import library (i.e. 'libperl56.a'). GCC will not + # find it unless the 'lib' prefix & the extension are stripped. + $spec{libperl} =~ s/^(?:lib)?([^.]+).*$/-l$1/; + + unshift( @{$spec{other_ldflags}}, '-nostartfiles' ) + if ( $spec{startup} && @{$spec{startup}} ); + + # From ExtUtils::MM_Win32: + # + ## one thing for GCC/Mingw32: + ## we try to overcome non-relocateable-DLL problems by generating + ## a (hopefully unique) image-base from the dll's name + ## -- BKS, 10-19-1999 + File::Basename::basename( $spec{output} ) =~ /(....)(.{0,4})/; + $spec{image_base} = sprintf( "0x%x0000", unpack('n', $1 ^ $2) ); + + %spec = $self->write_linker_script(%spec) + if $spec{use_scripts}; + + foreach my $path ( @{$spec{libpath}} ) { + $path = "-L$path"; + } + + my @cmds; # Stores the series of commands needed to build the module. + + my $DLLTOOL = $cf->{dlltool} || 'dlltool'; + + push @cmds, [ + $DLLTOOL, '--def' , $spec{def_file}, + '--output-exp' , $spec{explib} + ]; + + # split off any -arguments included in ld + my @ld = split / (?=-)/, $spec{ld}; + + push @cmds, [ grep {defined && length} ( + @ld , + '-o', $spec{output} , + "-Wl,--base-file,$spec{base_file}" , + "-Wl,--image-base,$spec{image_base}" , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{startup}} , + @{$spec{objects}} , + @{$spec{other_ldflags}} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{explib} , + $spec{map_file} ? ('-Map', $spec{map_file}) : '' + ) ]; + + push @cmds, [ + $DLLTOOL, '--def' , $spec{def_file}, + '--output-exp' , $spec{explib}, + '--base-file' , $spec{base_file} + ]; + + push @cmds, [ grep {defined && length} ( + @ld , + '-o', $spec{output} , + "-Wl,--image-base,$spec{image_base}" , + @{$spec{lddlflags}} , + @{$spec{libpath}} , + @{$spec{startup}} , + @{$spec{objects}} , + @{$spec{other_ldflags}} , + $spec{libperl} , + @{$spec{perllibs}} , + $spec{explib} , + $spec{map_file} ? ('-Map', $spec{map_file}) : '' + ) ]; + + return @cmds; +} + +sub write_linker_script { + my ($self, %spec) = @_; + + my $script = File::Spec->catfile( $spec{srcdir}, + $spec{basename} . '.lds' ); + + $self->add_to_cleanup($script); + + print "Generating script '$script'\n" if !$self->{quiet}; + + my $SCRIPT = IO::File->new( ">$script" ) + or die( "Could not create script '$script': $!" ); + + print $SCRIPT ( 'SEARCH_DIR(' . $_ . ")\n" ) + for @{delete $spec{libpath} || []}; + + # gcc takes only one startup file, so the first object in startup is + # specified as the startup file and any others are shifted into the + # beginning of the list of objects. + if ( $spec{startup} && @{$spec{startup}} ) { + print $SCRIPT 'STARTUP(' . shift( @{$spec{startup}} ) . ")\n"; + unshift @{$spec{objects}}, + @{delete $spec{startup} || []}; + } + + print $SCRIPT 'INPUT(' . join( ',', + @{delete $spec{objects} || []} + ) . ")\n"; + + print $SCRIPT 'INPUT(' . join( ' ', + (delete $spec{libperl} || ''), + @{delete $spec{perllibs} || []}, + ) . ")\n"; + + #it is important to keep the order 1.linker_script - 2.other_ldflags + unshift @{$spec{other_ldflags}}, '"' . $script . '"'; + + return %spec; +} + +1; + + +package ExtUtils::Command::MM; + +require 5.006; + +use strict; +use warnings; + +require Exporter; +our @ISA = qw(Exporter); + +our @EXPORT = qw(test_harness pod2man perllocal_install uninstall + warn_if_old_packlist test_s cp_nonempty); +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +my $Is_VMS = $^O eq 'VMS'; + +sub mtime { + no warnings 'redefine'; + local $@; + *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat) + ? sub { (Time::HiRes::stat($_[0]))[9] } + : sub { ( stat($_[0]))[9] } + ; + goto &mtime; +} + + +sub test_harness { + require Test::Harness; + require File::Spec; + + $Test::Harness::verbose = shift; + + # Because Windows doesn't do this for us and listing all the *.t files + # out on the command line can blow over its exec limit. + require ExtUtils::Command; + my @argv = ExtUtils::Command::expand_wildcards(@ARGV); + + local @INC = @INC; + unshift @INC, map { File::Spec->rel2abs($_) } @_; + Test::Harness::runtests(sort { lc $a cmp lc $b } @argv); +} + + + + +sub pod2man { + local @ARGV = @_ ? @_ : @ARGV; + + { + local $@; + if( !eval { require Pod::Man } ) { + warn "Pod::Man is not available: $@". + "Man pages will not be generated during this install.\n"; + return 0; + } + } + require Getopt::Long; + + # We will cheat and just use Getopt::Long. We fool it by putting + # our arguments into @ARGV. Should be safe. + my %options = (); + Getopt::Long::config ('bundling_override'); + Getopt::Long::GetOptions (\%options, + 'section|s=s', 'release|r=s', 'center|c=s', + 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', + 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', + 'name|n=s', 'perm_rw=i', 'utf8|u' + ); + delete $options{utf8} unless $Pod::Man::VERSION >= 2.17; + + # If there's no files, don't bother going further. + return 0 unless @ARGV; + + # Official sets --center, but don't override things explicitly set. + if ($options{official} && !defined $options{center}) { + $options{center} = q[Perl Programmer's Reference Guide]; + } + + # This isn't a valid Pod::Man option and is only accepted for backwards + # compatibility. + delete $options{lax}; + my $count = scalar @ARGV / 2; + my $plural = $count == 1 ? 'document' : 'documents'; + print "Manifying $count pod $plural\n"; + + do {{ # so 'next' works + my ($pod, $man) = splice(@ARGV, 0, 2); + + next if ((-e $man) && + (mtime($man) > mtime($pod)) && + (mtime($man) > mtime("Makefile"))); + + my $parser = Pod::Man->new(%options); + $parser->parse_from_file($pod, $man) + or do { warn("Could not install $man\n"); next }; + + if (exists $options{perm_rw}) { + chmod(oct($options{perm_rw}), $man) + or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; + } + }} while @ARGV; + + return 1; +} + + + +sub warn_if_old_packlist { + my $packlist = $ARGV[0]; + + return unless -f $packlist; + print <<"PACKLIST_WARNING"; +WARNING: I have found an old package in + $packlist. +Please make sure the two installations are not conflicting +PACKLIST_WARNING + +} + + + +sub perllocal_install { + my($type, $name) = splice(@ARGV, 0, 2); + + # VMS feeds args as a piped file on STDIN since it usually can't + # fit all the args on a single command line. + my @mod_info = $Is_VMS ? split /\|/, + : @ARGV; + + my $pod; + my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time); + $pod = sprintf <<'POD', scalar($time), $type, $name, $name; + =head2 %s: C<%s> L<%s|%s> + + =over 4 + +POD + + do { + my($key, $val) = splice(@mod_info, 0, 2); + + $pod .= < + +POD + + } while(@mod_info); + + $pod .= "=back\n\n"; + $pod =~ s/^ //mg; + print $pod; + + return 1; +} + + +sub uninstall { + my($packlist) = shift @ARGV; + + require ExtUtils::Install; + + print <<'WARNING'; + +Uninstall is unsafe and deprecated, the uninstallation was not performed. +We will show what would have been done. + +WARNING + + ExtUtils::Install::uninstall($packlist, 1, 1); + + print <<'WARNING'; + +Uninstall is unsafe and deprecated, the uninstallation was not performed. +Please check the list above carefully, there may be errors. +Remove the appropriate files manually. +Sorry for the inconvenience. + +WARNING + +} + + +sub test_s { + exit(-s $ARGV[0] ? 0 : 1); +} + + +sub cp_nonempty { + my @args = @ARGV; + return 0 unless -s $args[0]; + require ExtUtils::Command; + { + local @ARGV = @args[0,1]; + ExtUtils::Command::cp(@ARGV); + } + { + local @ARGV = @args[2,1]; + ExtUtils::Command::chmod(@ARGV); + } +} + + +1; +package ExtUtils::ParseXS::Constants; +use strict; +use warnings; +use Symbol; + +our $VERSION = '3.39'; + + +# FIXME: THESE ARE NOT CONSTANTS! +our @InitFileCode; + +# Note that to reduce maintenance, $PrototypeRegexp is used +# by ExtUtils::Typemaps, too! +our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]"; +our @XSKeywords = qw( + REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE + OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE + VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE + INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK + EXPORT_XSUB_SYMBOLS +); + +our $XSKeywordsAlternation = join('|', @XSKeywords); + +1; +package ExtUtils::ParseXS::Eval; +use strict; +use warnings; + +our $VERSION = '3.39'; + + +sub eval_output_typemap_code { + my ($_pxs, $_code, $_other) = @_; + + my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) + = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; + + my ($var, $type, $ntype, $subtype, $arg) + = @{$_other}{qw(var type ntype subtype arg)}; + + my $rv = eval $_code; + warn $@ if $@; + return $rv; +} + + +sub eval_input_typemap_code { + my ($_pxs, $_code, $_other) = @_; + + my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) + = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; + + my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) + = @{$_other}{qw(var type num init printed_name arg ntype argoff subtype)}; + + my $rv = eval $_code; + warn $@ if $@; + return $rv; +} + + +1; + +# vim: ts=2 sw=2 et: +package ExtUtils::ParseXS::CountLines; +use strict; + +our $VERSION = '3.39'; + +our $SECTION_END_MARKER; + +sub TIEHANDLE { + my ($class, $cfile, $fh) = @_; + $cfile =~ s/\\/\\\\/g; + $cfile =~ s/"/\\"/g; + $SECTION_END_MARKER = qq{#line --- "$cfile"}; + + return bless { + buffer => '', + fh => $fh, + line_no => 1, + }, $class; +} + +sub PRINT { + my $self = shift; + for (@_) { + $self->{buffer} .= $_; + while ($self->{buffer} =~ s/^([^\n]*\n)//) { + my $line = $1; + ++$self->{line_no}; + $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; + print {$self->{fh}} $line; + } + } +} + +sub PRINTF { + my $self = shift; + my $fmt = shift; + $self->PRINT(sprintf($fmt, @_)); +} + +sub DESTROY { + # Not necessary if we're careful to end with a "\n" + my $self = shift; + print {$self->{fh}} $self->{buffer}; +} + +sub UNTIE { + # This sub does nothing, but is necessary for references to be released. +} + +sub end_marker { + return $SECTION_END_MARKER; +} + +1; +package ExtUtils::ParseXS::Utilities; +use strict; +use warnings; +use Exporter; +use File::Spec; +use ExtUtils::ParseXS::Constants (); + +our $VERSION = '3.39'; + +our (@ISA, @EXPORT_OK); +@ISA = qw(Exporter); +@EXPORT_OK = qw( + standard_typemap_locations + trim_whitespace + C_string + valid_proto_string + process_typemaps + map_type + standard_XS_defs + assign_func_args + analyze_preprocessor_statements + set_cond + Warn + current_line_number + blurt + death + check_conditional_preprocessor_statements + escape_file_for_line_directive + report_typemap_failure +); + + +SCOPE: { + my @tm_template; + + sub standard_typemap_locations { + my $include_ref = shift; + + if (not @tm_template) { + @tm_template = qw(typemap); + + my $updir = File::Spec->updir(); + foreach my $dir ( + File::Spec->catdir(($updir) x 1), + File::Spec->catdir(($updir) x 2), + File::Spec->catdir(($updir) x 3), + File::Spec->catdir(($updir) x 4), + ) { + unshift @tm_template, File::Spec->catfile($dir, 'typemap'); + unshift @tm_template, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); + } + } + + my @tm = @tm_template; + foreach my $dir (@{ $include_ref}) { + my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); + unshift @tm, $file if -e $file; + } + return @tm; + } +} # end SCOPE + + +sub trim_whitespace { + $_[0] =~ s/^\s+|\s+$//go; +} + + +sub C_string { + my($string) = @_; + + $string =~ s[\\][\\\\]g; + $string; +} + + +sub valid_proto_string { + my ($string) = @_; + + if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) { + return $string; + } + + return 0; +} + + +sub process_typemaps { + my ($tmap, $pwd) = @_; + + my @tm = ref $tmap ? @{$tmap} : ($tmap); + + foreach my $typemap (@tm) { + die "Can't find $typemap in $pwd\n" unless -r $typemap; + } + + push @tm, standard_typemap_locations( \@INC ); + + require ExtUtils::Typemaps; + my $typemap = ExtUtils::Typemaps->new; + foreach my $typemap_loc (@tm) { + next unless -f $typemap_loc; + # skip directories, binary files etc. + warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next + unless -T $typemap_loc; + + $typemap->merge(file => $typemap_loc, replace => 1); + } + + return $typemap; +} + + +sub map_type { + my ($self, $type, $varname) = @_; + + # C++ has :: in types too so skip this + $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; + $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; + if ($varname) { + if ($type =~ / \( \s* \* (?= \s* \) ) /xg) { + (substr $type, pos $type, 0) = " $varname "; + } + else { + $type .= "\t$varname"; + } + } + return $type; +} + + +sub standard_XS_defs { + print <<"EOF"; +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(var) if (0) var = var +#endif + +#ifndef dVAR +# define dVAR dNOOP +#endif + + +/* This stuff is not part of the API! You have been warned. */ +#ifndef PERL_VERSION_DECIMAL +# define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) +#endif +#ifndef PERL_DECIMAL_VERSION +# define PERL_DECIMAL_VERSION \\ + PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) +#endif +#ifndef PERL_VERSION_GE +# define PERL_VERSION_GE(r,v,s) \\ + (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) +#endif +#ifndef PERL_VERSION_LE +# define PERL_VERSION_LE(r,v,s) \\ + (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) +#endif + +/* XS_INTERNAL is the explicit static-linkage variant of the default + * XS macro. + * + * XS_EXTERNAL is the same as XS_INTERNAL except it does not include + * "STATIC", ie. it exports XSUB symbols. You probably don't want that + * for anything but the BOOT XSUB. + * + * See XSUB.h in core! + */ + + +/* TODO: This might be compatible further back than 5.10.0. */ +#if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) +# undef XS_EXTERNAL +# undef XS_INTERNAL +# if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) +# define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) +# define XS_INTERNAL(name) STATIC XSPROTO(name) +# endif +# if defined(__SYMBIAN32__) +# define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) +# define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) +# endif +# ifndef XS_EXTERNAL +# if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) +# define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) +# define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) +# else +# ifdef __cplusplus +# define XS_EXTERNAL(name) extern "C" XSPROTO(name) +# define XS_INTERNAL(name) static XSPROTO(name) +# else +# define XS_EXTERNAL(name) XSPROTO(name) +# define XS_INTERNAL(name) STATIC XSPROTO(name) +# endif +# endif +# endif +#endif + +/* perl >= 5.10.0 && perl <= 5.15.1 */ + + +/* The XS_EXTERNAL macro is used for functions that must not be static + * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL + * macro defined, the best we can do is assume XS is the same. + * Dito for XS_INTERNAL. + */ +#ifndef XS_EXTERNAL +# define XS_EXTERNAL(name) XS(name) +#endif +#ifndef XS_INTERNAL +# define XS_INTERNAL(name) XS(name) +#endif + +/* Now, finally, after all this mess, we want an ExtUtils::ParseXS + * internal macro that we're free to redefine for varying linkage due + * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use + * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! + */ + +#undef XS_EUPXS +#if defined(PERL_EUPXS_ALWAYS_EXPORT) +# define XS_EUPXS(name) XS_EXTERNAL(name) +#else + /* default to internal */ +# define XS_EUPXS(name) XS_INTERNAL(name) +#endif + +EOF + + print <<"EOF"; +#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) + +/* prototype to pass -Wmissing-prototypes */ +STATIC void +S_croak_xs_usage(const CV *const cv, const char *const params); + +STATIC void +S_croak_xs_usage(const CV *const cv, const char *const params) +{ + const GV *const gv = CvGV(cv); + + PERL_ARGS_ASSERT_CROAK_XS_USAGE; + + if (gv) { + const char *const gvname = GvNAME(gv); + const HV *const stash = GvSTASH(gv); + const char *const hvname = stash ? HvNAME(stash) : NULL; + + if (hvname) + Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); + else + Perl_croak_nocontext("Usage: %s(%s)", gvname, params); + } else { + /* Pants. I don't think that it should be possible to get here. */ + Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); + } +} +#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE + +#define croak_xs_usage S_croak_xs_usage + +#endif + +/* NOTE: the prototype of newXSproto() is different in versions of perls, + * so we define a portable version of newXSproto() + */ +#ifdef newXS_flags +#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) +#else +#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) +#endif /* !defined(newXS_flags) */ + +#if PERL_VERSION_LE(5, 21, 5) +# define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file) +#else +# define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) +#endif + +EOF + return 1; +} + + +sub assign_func_args { + my ($self, $argsref, $class) = @_; + my @func_args = @{$argsref}; + shift @func_args if defined($class); + + for my $arg (@func_args) { + $arg =~ s/^/&/ if $self->{in_out}->{$arg}; + } + return join(", ", @func_args); +} + + +sub analyze_preprocessor_statements { + my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_; + + if ($statement eq 'if') { + $XSS_work_idx = @{ $self->{XSStack} }; + push(@{ $self->{XSStack} }, {type => 'if'}); + } + else { + $self->death("Error: '$statement' with no matching 'if'") + if $self->{XSStack}->[-1]{type} ne 'if'; + if ($self->{XSStack}->[-1]{varname}) { + push(@{ $self->{InitFileCode} }, "#endif\n"); + push(@{ $BootCode_ref }, "#endif"); + } + + my(@fns) = keys %{$self->{XSStack}->[-1]{functions}}; + if ($statement ne 'endif') { + # Hide the functions defined in other #if branches, and reset. + @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns; + @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {}); + } + else { + my($tmp) = pop(@{ $self->{XSStack} }); + 0 while (--$XSS_work_idx + && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if'); + # Keep all new defined functions + push(@fns, keys %{$tmp->{other_functions}}); + @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; + } + } + return ($self, $XSS_work_idx, $BootCode_ref); +} + + +sub set_cond { + my ($ellipsis, $min_args, $num_args) = @_; + my $cond; + if ($ellipsis) { + $cond = ($min_args ? qq(items < $min_args) : 0); + } + elsif ($min_args == $num_args) { + $cond = qq(items != $min_args); + } + else { + $cond = qq(items < $min_args || items > $num_args); + } + return $cond; +} + + +sub current_line_number { + my $self = shift; + my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1]; + return $line_number; +} + + +sub Warn { + my $self = shift; + my $warn_line_number = $self->current_line_number(); + print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; +} + + +sub blurt { + my $self = shift; + $self->Warn(@_); + $self->{errors}++ +} + + +sub death { + my $self = shift; + $self->Warn(@_); + exit 1; +} + + +sub check_conditional_preprocessor_statements { + my ($self) = @_; + my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} }); + if (@cpp) { + my $cpplevel; + for my $cpp (@cpp) { + if ($cpp =~ /^\#\s*if/) { + $cpplevel++; + } + elsif (!$cpplevel) { + $self->Warn("Warning: #else/elif/endif without #if in this function"); + print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" + if $self->{XSStack}->[-1]{type} eq 'if'; + return; + } + elsif ($cpp =~ /^\#\s*endif/) { + $cpplevel--; + } + } + $self->Warn("Warning: #if without #endif in this function") if $cpplevel; + } +} + + +sub escape_file_for_line_directive { + my $string = shift; + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + return $string; +} + + +sub report_typemap_failure { + my ($self, $tm, $ctype, $error_method) = @_; + $error_method ||= 'blurt'; + + my @avail_ctypes = $tm->list_mapped_ctypes; + + my $err = "Could not find a typemap for C type '$ctype'.\n" + . "The following C types are mapped by the current typemap:\n'" + . join("', '", @avail_ctypes) . "'\n"; + + $self->$error_method($err); + return(); +} + +1; + +# vim: ts=2 sw=2 et: +package ExtUtils::Typemaps::Type; +use 5.006001; +use strict; +use warnings; +require ExtUtils::Typemaps; + +our $VERSION = '3.38'; + + + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{ctype}) { + die("Need xstype and ctype parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {proto => ''}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{ctype} = $args{ctype} if defined $args{ctype}; + $self->{tidy_ctype} = ExtUtils::Typemaps::tidy_type($self->{ctype}); + $self->{proto} = $args{'prototype'} if defined $args{'prototype'}; + + return $self; +} + + +sub proto { + $_[0]->{proto} = $_[1] if @_ > 1; + return $_[0]->{proto}; +} + + +sub xstype { + return $_[0]->{xstype}; +} + + +sub ctype { + return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype}; +} + + +sub tidy_ctype { + return $_[0]->{tidy_ctype}; +} + + +1; + +package ExtUtils::Typemaps::OutputMap; +use 5.006001; +use strict; +use warnings; +our $VERSION = '3.38'; + + + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{code}) { + die("Need xstype and code parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{code} = $args{code} if defined $args{code}; + $self->{code} =~ s/^(?=\S)/\t/mg; + + return $self; +} + + +sub code { + $_[0]->{code} = $_[1] if @_ > 1; + return $_[0]->{code}; +} + + +sub xstype { + return $_[0]->{xstype}; +} + + +sub cleaned_code { + my $self = shift; + my $code = $self->code; + + # Move C pre-processor instructions to column 1 to be strictly ANSI + # conformant. Some pre-processors are fussy about this. + $code =~ s/^\s+#/#/mg; + $code =~ s/\s*\z/\n/; + + return $code; +} + + +sub targetable { + my $self = shift; + return $self->{targetable} if exists $self->{targetable}; + + our $bal; # ()-balanced + $bal = qr[ + (?: + (?>[^()]+) + | + \( (??{ $bal }) \) + )* + ]x; + my $bal_no_comma = qr[ + (?: + (?>[^(),]+) + | + \( (??{ $bal }) \) + )+ + ]x; + + # matches variations on (SV*) + my $sv_cast = qr[ + (?: + \( \s* SV \s* \* \s* \) \s* + )? + ]x; + + my $size = qr[ # Third arg (to setpvn) + , \s* (??{ $bal }) + ]xo; + + my $code = $self->code; + + # We can still bootstrap compile 're', because in code re.pm is + # available to miniperl, and does not attempt to load the XS code. + use re 'eval'; + + my ($type, $with_size, $arg, $sarg) = + ($code =~ + m[^ + \s+ + sv_set([iunp])v(n)? # Type, is_setpvn + \s* + \( \s* + $sv_cast \$arg \s* , \s* + ( $bal_no_comma ) # Set from + ( $size )? # Possible sizeof set-from + \s* \) \s* ; \s* $ + ]xo + ); + + my $rv = undef; + if ($type) { + $rv = { + type => $type, + with_size => $with_size, + what => $arg, + what_size => $sarg, + }; + } + $self->{targetable} = $rv; + return $rv; +} + + +1; + +package ExtUtils::Typemaps::InputMap; +use 5.006001; +use strict; +use warnings; +our $VERSION = '3.38'; + + + +sub new { + my $prot = shift; + my $class = ref($prot)||$prot; + my %args = @_; + + if (!ref($prot)) { + if (not defined $args{xstype} or not defined $args{code}) { + die("Need xstype and code parameters"); + } + } + + my $self = bless( + (ref($prot) ? {%$prot} : {}) + => $class + ); + + $self->{xstype} = $args{xstype} if defined $args{xstype}; + $self->{code} = $args{code} if defined $args{code}; + $self->{code} =~ s/^(?=\S)/\t/mg; + + return $self; +} + + +sub code { + $_[0]->{code} = $_[1] if @_ > 1; + return $_[0]->{code}; +} + + +sub xstype { + return $_[0]->{xstype}; +} + + +sub cleaned_code { + my $self = shift; + my $code = $self->code; + + $code =~ s/(?:;+\s*|;*\s+)\z//s; + + # Move C pre-processor instructions to column 1 to be strictly ANSI + # conformant. Some pre-processors are fussy about this. + $code =~ s/^\s+#/#/mg; + $code =~ s/\s*\z/\n/; + + return $code; +} + + +1; + +package ExtUtils::Typemaps::Cmd; +use 5.006001; +use strict; +use warnings; +our $VERSION = '3.38'; + +use ExtUtils::Typemaps; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(embeddable_typemap); +our %EXPORT_TAGS = (all => \@EXPORT); + +sub embeddable_typemap { + my @tms = @_; + + # Get typemap objects + my @tm_objs = map [$_, _intuit_typemap_source($_)], @tms; + + # merge or short-circuit + my $final_tm; + if (@tm_objs == 1) { + # just one, merge would be pointless + $final_tm = shift(@tm_objs)->[1]; + } + else { + # multiple, need merge + $final_tm = ExtUtils::Typemaps->new; + foreach my $other_tm (@tm_objs) { + my ($tm_ident, $tm_obj) = @$other_tm; + eval { + $final_tm->merge(typemap => $tm_obj); + 1 + } or do { + my $err = $@ || 'Zombie error'; + die "Failed to merge typ"; + } + } + } + + # stringify for embedding + return $final_tm->as_embedded_typemap(); +} + +sub _load_module { + my $name = shift; + return eval "require $name; 1"; +} + +SCOPE: { + my %sources = ( + module => sub { + my $ident = shift; + my $tm; + if (/::/) { # looks like FQ module name, try that first + foreach my $module ($ident, "ExtUtils::Typemaps::$ident") { + if (_load_module($module)) { + eval { $tm = $module->new } + and return $tm; + } + } + } + else { + foreach my $module ("ExtUtils::Typemaps::$ident", "$ident") { + if (_load_module($module)) { + eval { $tm = $module->new } + and return $tm; + } + } + } + return(); + }, + file => sub { + my $ident = shift; + return unless -e $ident and -r _; + return ExtUtils::Typemaps->new(file => $ident); + }, + ); + # Try to find typemap either from module or file + sub _intuit_typemap_source { + my $identifier = shift; + + my @locate_attempts; + if ($identifier =~ /::/ || $identifier !~ /[^\w_]/) { + @locate_attempts = qw(module file); + } + else { + @locate_attempts = qw(file module); + } + + foreach my $source (@locate_attempts) { + my $tm = $sources{$source}->($identifier); + return $tm if defined $tm; + } + + die "Unable to find typemap for '$identifier': " + . "Tried to load both as file or module and failed.\n"; + } +} # end SCOPE + + +1; + +package ExtUtils::Liblist::Kid; + +# XXX Splitting this out into its own .pm is a temporary solution. + +# This kid package is to be used by MakeMaker. It will not work if +# $self is not a Makemaker. + +use 5.006; + +# Broken out of MakeMaker from version 4.11 + +use strict; +use warnings; +our $VERSION = '7.34'; +$VERSION = eval $VERSION; + +use ExtUtils::MakeMaker::Config; +use Cwd 'cwd'; +use File::Basename; +use File::Spec; + +sub ext { + if ( $^O eq 'VMS' ) { return &_vms_ext; } + elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; } + else { return &_unix_os2_ext; } +} + +sub _unix_os2_ext { + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + if ( $^O =~ /os2|android/ and $Config{perllibs} ) { + + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll/libperl.so again. + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $Config{perllibs}; + } + return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my ( $so ) = $Config{so}; + my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs}; + my $Config_libext = $Config{lib_ext} || ".a"; + my $Config_dlext = $Config{dlext}; + + # compute $extralibs, $bsloadlibs and $ldloadlibs from + # $potential_libs + # this is a rewrite of Andy Dougherty's extliblist in perl + + my ( @searchpath ); # from "-L/path" entries in $potential_libs + my ( @libpath ) = split " ", $Config{'libpth'} || ''; + my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen ); + my ( @libs, %libs_seen ); + my ( $fullname, @fullname ); + my ( $pwd ) = cwd(); # from Cwd.pm + my ( $found ) = 0; + + if ( $^O eq 'darwin' or $^O eq 'next' ) { + # 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on + $potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g; + $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g; + } + + foreach my $thislib ( split ' ', $potential_libs ) { + my ( $custom_name ) = ''; + + # Handle possible linker path arguments. + if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type + my ( $ptype ) = $1; + unless ( -d $thislib ) { + warn "$ptype$thislib ignored, directory does not exist\n" + if $verbose; + next; + } + my ( $rtype ) = $ptype; + if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) { + if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) { + $rtype = '-Wl,-R'; + } + elsif ( $Config{'lddlflags'} =~ /-R/ ) { + $rtype = '-R'; + } + } + unless ( File::Spec->file_name_is_absolute( $thislib ) ) { + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + $thislib = $self->catdir( $pwd, $thislib ); + } + push( @searchpath, $thislib ); + push( @extralibs, "$ptype$thislib" ); + push( @ldloadlibs, "$rtype$thislib" ); + next; + } + + if ( $thislib =~ m!^-Wl,! ) { + push( @extralibs, $thislib ); + push( @ldloadlibs, $thislib ); + next; + } + + # Handle possible library arguments. + if ( $thislib =~ s/^-l(:)?// ) { + # Handle -l:foo.so, which means that the library will + # actually be called foo.so, not libfoo.so. This + # is used in Android by ExtUtils::Depends to allow one XS + # module to link to another. + $custom_name = $1 || ''; + } + else { + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; + next; + } + + my ( $found_lib ) = 0; + foreach my $thispth ( @searchpath, @libpath ) { + + # Try to find the full name of the library. We need this to + # determine whether it's a dynamically-loadable library or not. + # This tends to be subject to various os-specific quirks. + # For gcc-2.6.2 on linux (March 1995), DLD can not load + # .sa libraries, with the exception of libm.sa, so we + # deliberately skip them. + if ((@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) || + (@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) { + # Take care that libfoo.so.10 wins against libfoo.so.9. + # Compare two libraries to find the most recent version + # number. E.g. if you have libfoo.so.9.0.7 and + # libfoo.so.10.1, first convert all digits into two + # decimal places. Then we'll add ".00" to the shorter + # strings so that we're comparing strings of equal length + # Thus we'll compare libfoo.so.09.07.00 with + # libfoo.so.10.01.00. Some libraries might have letters + # in the version. We don't know what they mean, but will + # try to skip them gracefully -- we'll set any letter to + # '0'. Finally, sort in reverse so we can take the + # first element. + + #TODO: iterate through the directory instead of sorting + + $fullname = "$thispth/" . ( + sort { + my ( $ma ) = $a; + my ( $mb ) = $b; + $ma =~ tr/A-Za-z/0/s; + $ma =~ s/\b(\d)\b/0$1/g; + $mb =~ tr/A-Za-z/0/s; + $mb =~ s/\b(\d)\b/0$1/g; + while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; } + while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; } + + # Comparison deliberately backwards + $mb cmp $ma; + } @fullname + )[0]; + } + elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" ) + && ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) ) + { + } + elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" ) + && ( $Config{'archname'} !~ /RM\d\d\d-svr4/ ) + && ( $thislib .= "_s" ) ) + { # we must explicitly use _s version + } + elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) { + } + elsif ( defined( $Config_dlext ) + && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) ) + { + } + elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) { + } + elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) { + } + elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) { + } + elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) { + } + elsif ($^O eq 'dgux' + && -l ( $fullname = "$thispth/lib$thislib$Config_libext" ) + && readlink( $fullname ) =~ /^elink:/s ) + { + + # Some of DG's libraries look like misconnected symbolic + # links, but development tools can follow them. (They + # look like this: + # + # libm.a -> elink:${SDE_PATH:-/usr}/sde/\ + # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a + # + # , the compilation tools expand the environment variables.) + } + elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) { + } + else { + warn "$thislib not found in $thispth\n" if $verbose; + next; + } + warn "'-l$thislib' found at $fullname\n" if $verbose; + push @libs, $fullname unless $libs_seen{$fullname}++; + $found++; + $found_lib++; + + # Now update library lists + + # what do we know about this library... + my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ ); + my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s ); + + # include the path to the lib once in the dynamic linker path + # but only if it is a dynamic lib and not in Perl itself + my ( $fullnamedir ) = dirname( $fullname ); + push @ld_run_path, $fullnamedir + if $is_dyna + && !$in_perl + && !$ld_run_path_seen{$fullnamedir}++; + + # Do not add it into the list if it is already linked in + # with the main perl executable. + # We have to special-case the NeXT, because math and ndbm + # are both in libsys_s + unless ( + $in_perl + || ( $Config{'osname'} eq 'next' + && ( $thislib eq 'm' || $thislib eq 'ndbm' ) ) + ) + { + push( @extralibs, "-l$custom_name$thislib" ); + } + + # We might be able to load this archive file dynamically + if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' ) + || ( $Config{'dlsrc'} =~ /dl_dld/ ) ) + { + + # We push -l$thislib instead of $fullname because + # it avoids hardwiring a fixed path into the .bs file. + # Mkbootstrap will automatically add dl_findfile() to + # the .bs file if it sees a name in the -l format. + # USE THIS, when dl_findfile() is fixed: + # push(@bsloadlibs, "-l$thislib"); + # OLD USE WAS while checking results against old_extliblist + push( @bsloadlibs, "$fullname" ); + } + else { + if ( $is_dyna ) { + + # For SunOS4, do not add in this shared library if + # it is already linked in the main perl executable + push( @ldloadlibs, "-l$custom_name$thislib" ) + unless ( $in_perl and $^O eq 'sunos' ); + } + else { + push( @ldloadlibs, "-l$custom_name$thislib" ); + } + } + last; # found one here so don't bother looking further + } + warn "Warning (mostly harmless): " . "No library found for -l$thislib\n" + unless $found_lib > 0; + } + + unless ( $found ) { + return ( '', '', '', '', ( $give_libs ? \@libs : () ) ); + } + else { + return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) ); + } +} + +sub _win32_ext { + + require Text::ParseWords; + + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + # If user did not supply a list, we punt. + # (caller should probably use the list in $Config{libs}) + return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; + + # TODO: make this use MM_Win32.pm's compiler detection + my %libs_seen; + my @extralibs; + my $cc = $Config{cc} || ''; + my $VC = $cc =~ /\bcl\b/i; + my $GC = $cc =~ /\bgcc\b/i; + + my $libext = _win32_lib_extensions(); + my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs + my @libpath = _win32_default_search_paths( $VC, $GC ); + my $pwd = cwd(); # from Cwd.pm + my $search = 1; + + # compute @extralibs from $potential_libs + my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose ); + for ( @lib_search_list ) { + + my $thislib = $_; + + # see if entry is a flag + if ( /^:\w+$/ ) { + $search = 0 if lc eq ':nosearch'; + $search = 1 if lc eq ':search'; + _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i; + next; + } + + # if searching is disabled, do compiler-specific translations + unless ( $search ) { + s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; + push( @extralibs, $_ ); + next; + } + + # handle possible linker path arguments + if ( s/^-L// and not -d ) { + _debug( "$thislib ignored, directory does not exist\n", $verbose ); + next; + } + elsif ( -d ) { + unless ( File::Spec->file_name_is_absolute( $_ ) ) { + warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; + $_ = $self->catdir( $pwd, $_ ); + } + push( @searchpath, $_ ); + next; + } + + my @paths = ( @searchpath, @libpath ); + my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC ); + + if ( !$fullname ) { + warn "Warning (mostly harmless): No library found for $thislib\n"; + next; + } + + _debug( "'$thislib' found as '$fullname'\n", $verbose ); + push( @extralibs, $fullname ); + $libs_seen{$fullname} = 1 if $path; # why is this a special case? + } + + my @libs = sort keys %libs_seen; + + return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs; + + # make sure paths with spaces are properly quoted + @extralibs = map { qq["$_"] } @extralibs; + @libs = map { qq["$_"] } @libs; + + my $lib = join( ' ', @extralibs ); + + # normalize back to backward slashes (to help braindead tools) + # XXX this may break equally braindead GNU tools that don't understand + # backslashes, either. Seems like one can't win here. Cursed be CP/M. + $lib =~ s,/,\\,g; + + _debug( "Result: $lib\n", $verbose ); + wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib; +} + +sub _win32_make_lib_search_list { + my ( $potential_libs, $verbose ) = @_; + + # If Config.pm defines a set of default libs, we always + # tack them on to the user-supplied list, unless the user + # specified :nodefault + my $libs = $Config{'perllibs'}; + $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i; + _debug( "Potential libraries are '$potential_libs':\n", $verbose ); + + $potential_libs =~ s,\\,/,g; # normalize to forward slashes + + my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs ); + + return @list; +} + +sub _win32_default_search_paths { + my ( $VC, $GC ) = @_; + + my $libpth = $Config{'libpth'} || ''; + $libpth =~ s,\\,/,g; # normalize to forward slashes + + my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth ); + push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path + + push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB}; + push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH}; + + return @libpath; +} + +sub _win32_search_file { + my ( $thislib, $libext, $paths, $verbose, $GC ) = @_; + + my @file_list = _win32_build_file_list( $thislib, $GC, $libext ); + + for my $lib_file ( @file_list ) { + for my $path ( @{$paths} ) { + my $fullname = $lib_file; + $fullname = "$path\\$fullname" if $path; + + return ( $fullname, $path ) if -f $fullname; + + _debug( "'$thislib' not found as '$fullname'\n", $verbose ); + } + } + + return; +} + +sub _win32_build_file_list { + my ( $lib, $GC, $extensions ) = @_; + + my @pre_fixed = _win32_build_prefixed_list( $lib, $GC ); + return map _win32_attach_extensions( $_, $extensions ), @pre_fixed; +} + +sub _win32_build_prefixed_list { + my ( $lib, $GC ) = @_; + + return $lib if $lib !~ s/^-l//; + return $lib if $lib =~ /^lib/ and !$GC; + + ( my $no_prefix = $lib ) =~ s/^lib//i; + $lib = "lib$lib" if $no_prefix eq $lib; + + return ( $lib, $no_prefix ) if $GC; + return ( $no_prefix, $lib ); +} + +sub _win32_attach_extensions { + my ( $lib, $extensions ) = @_; + return map _win32_try_attach_extension( $lib, $_ ), @{$extensions}; +} + +sub _win32_try_attach_extension { + my ( $lib, $extension ) = @_; + + return $lib if $lib =~ /\Q$extension\E$/i; + return "$lib$extension"; +} + +sub _win32_lib_extensions { + my @extensions; + push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'}; + push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions; + push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions; + return \@extensions; +} + +sub _debug { + my ( $message, $verbose ) = @_; + return if !$verbose; + warn $message; + return; +} + +sub _vms_ext { + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + my ( @crtls, $crtlstr ); + @crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' ); + push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} ); + push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} ); + + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to insure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ( $self->{PERL_SRC} ) { + my ( $locspec, $type ); + foreach my $lib ( @crtls ) { + if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) { + if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; } + elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; } + else { $locspec .= $Config{'obj_ext'}; } + $locspec = $self->catfile( $self->{PERL_SRC}, $locspec ); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join( ' ', @crtls ) : ''; + + unless ( $potential_libs ) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) ); + } + + my ( %found, @fndlibs, $ldlib ); + my $cwd = cwd(); + my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' }; + + # List of common Unix library names and their VMS equivalents + # (VMS equivalent of '' indicates that the library is automatically + # searched by the linker, and should be skipped here.) + my ( @flibs, %libs_seen ); + my %libmap = ( + 'm' => '', + 'f77' => '', + 'F77' => '', + 'V77' => '', + 'c' => '', + 'malloc' => '', + 'crypt' => '', + 'resolv' => '', + 'c_s' => '', + 'socket' => '', + 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', + 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR' + ); + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + my ( @dirs, @libs ); + foreach my $lib ( split ' ', $potential_libs ) { + push( @dirs, $1 ), next if $lib =~ /^-L(.*)/; + push( @dirs, $lib ), next if $lib =~ /[:>\]]$/; + push( @dirs, $lib ), next if -d $lib; + push( @libs, $1 ), next if $lib =~ /^-l(.*)/; + push( @libs, $lib ); + } + push( @dirs, split( ' ', $Config{'libpth'} ) ); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach my $dir ( @dirs ) { + unless ( -d $dir ) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if ( File::Spec->file_name_is_absolute( $dir ) ) { + $dir = VMS::Filespec::vmspath( $dir ); + } + else { + $dir = $self->catdir( $cwd, $dir ); + } + } + @dirs = grep { length( $_ ) } @dirs; + unshift( @dirs, '' ); # Check each $lib without additions first + + LIB: foreach my $lib ( @libs ) { + if ( exists $libmap{$lib} ) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my ( @variants, $cand ); + my ( $ctype ) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ( $lib !~ /\.[^:>\]]*$/ ) { + push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" ); + push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/; + } + push( @variants, $lib ); + warn "Looking for $lib\n" if $verbose; + foreach my $variant ( @variants ) { + my ( $fullname, $name ); + + foreach my $dir ( @dirs ) { + my ( $type ); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + $fullname = VMS::Filespec::rmsexpand( $name ); + if ( defined $fullname and -f $fullname ) { + + # It's got its own suffix, so we'll have to figure out the type + if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; } + elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; } + elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) { + warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + } + else { + warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n"; + $type = 'SHR'; + } + } + elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) ) + or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) ) + { + $type = 'SHR'; + $name = $fullname unless $fullname =~ /exe;?\d*$/i; + } + elsif ( + not length( $ctype ) and # If we've got a lib already, + # don't bother + ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) ) + ) + { + $type = 'OLB'; + $name = $fullname unless $fullname =~ /olb;?\d*$/i; + } + elsif ( + not length( $ctype ) and # If we've got a lib already, + # don't bother + ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) ) + ) + { + warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + $name = $fullname unless $fullname =~ /obj;?\d*$/i; + } + if ( defined $type ) { + $ctype = $type; + $cand = $name; + last if $ctype eq 'SHR'; + } + } + if ( $ctype ) { + + push @{ $found{$ctype} }, $cand; + warn "\tFound as $cand (really $fullname), type $ctype\n" + if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; + next LIB; + } + } + warn "Warning (mostly harmless): " . "No library found for $lib\n"; + } + + push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR}; + my $lib = join( ' ', @fndlibs ); + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + $ldlib =~ s/^\s+|\s+$//g; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib; +} + +1; +package Filter::Simple; + +use Text::Balanced ':ALL'; + +our $VERSION = '0.95'; + +use Filter::Util::Call; +use Carp; + +our @EXPORT = qw( FILTER FILTER_ONLY ); + + +sub import { + if (@_>1) { shift; goto &FILTER } + else { *{caller()."::$_"} = \&$_ foreach @EXPORT } +} + +sub fail { + croak "FILTER_ONLY: ", @_; +} + +my $exql = sub { + my @bits = extract_quotelike $_[0], qr//; + return unless $bits[0]; + return \@bits; +}; + +my $ncws = qr/\s+/; +my $comment = qr/(?()-]|\^[A-Z]?)\} + | (?:\$#?|[*\@\%]|\\&)\$*\s* + (?: \{\s*(?:\^(?=[A-Z_]))?(?:\w|::|'\w)*\s*\} + | (?:\^(?=[A-Z_]))?(?:\w|::|'\w)* + | (?=\{) # ${ block } + ) + ) + | \$\s*(?!::)(?:\d+|[][&`'#+*./|,";%=~:?!\@<>()-]|\^[A-Z]?) + }x; + +my %extractor_for = ( + quotelike => [ $ws, $variable, $id, { MATCH => \&extract_quotelike } ], + regex => [ $ws, $pod_or_DATA, $id, $exql ], + string => [ $ws, $pod_or_DATA, $id, $exql ], + code => [ $ws, { DONT_MATCH => $pod_or_DATA }, $variable, + $id, { DONT_MATCH => \&extract_quotelike } ], + code_no_comments + => [ { DONT_MATCH => $comment }, + $ncws, { DONT_MATCH => $pod_or_DATA }, $variable, + $id, { DONT_MATCH => \&extract_quotelike } ], + executable => [ $ws, { DONT_MATCH => $pod_or_DATA } ], + executable_no_comments + => [ { DONT_MATCH => $comment }, + $ncws, { DONT_MATCH => $pod_or_DATA } ], + all => [ { MATCH => qr/(?s:.*)/ } ], +); + +my %selector_for = ( + all => sub { my ($t)=@_; sub{ $_=$$_; $t->(@_); $_} }, + executable=> sub { my ($t)=@_; sub{ref() ? $_=$$_ : $t->(@_); $_} }, + quotelike => sub { my ($t)=@_; sub{ref() && do{$_=$$_; $t->(@_)}; $_} }, + regex => sub { my ($t)=@_; + sub{ref() or return $_; + my ($ql,undef,$pre,$op,$ld,$pat) = @$_; + return $_->[0] unless $op =~ /^(qr|m|s)/ + || !$op && ($ld eq '/' || $ld eq '?'); + $_ = $pat; + $t->(@_); + $ql =~ s/^(\s*\Q$op\E\s*\Q$ld\E)\Q$pat\E/$1$_/; + return "$pre$ql"; + }; + }, + string => sub { my ($t)=@_; + sub{ref() or return $_; + local *args = \@_; + my ($pre,$op,$ld1,$str1,$rd1,$ld2,$str2,$rd2,$flg) = @{$_}[2..10]; + return $_->[0] if $op =~ /^(qr|m)/ + || !$op && ($ld1 eq '/' || $ld1 eq '?'); + if (!$op || $op eq 'tr' || $op eq 'y') { + local *_ = \$str1; + $t->(@args); + } + if ($op =~ /^(tr|y|s)/) { + local *_ = \$str2; + $t->(@args); + } + my $result = "$pre$op$ld1$str1$rd1"; + $result .= $ld2 if $ld1 =~ m/[[({<]/; #])}> + $result .= "$str2$rd2$flg"; + return $result; + }; + }, +); + + +sub gen_std_filter_for { + my ($type, $transform) = @_; + return sub { + my $instr; + local @components; + for (extract_multiple($_,$extractor_for{$type})) { + if (ref()) { push @components, $_; $instr=0 } + elsif ($instr) { $components[-1] .= $_ } + else { push @components, $_; $instr=1 } + } + if ($type =~ /^code/) { + my $count = 0; + local $placeholder = qr/\Q$;\E(.{4})\Q$;\E/s; + my $extractor = qr/\Q$;\E(.{4})\Q$;\E/s; + $_ = join "", + map { ref $_ ? $;.pack('N',$count++).$; : $_ } + @components; + @components = grep { ref $_ } @components; + $transform->(@_); + s/$extractor/${$components[unpack('N',$1)]}/g; + } + else { + my $selector = $selector_for{$type}->($transform); + $_ = join "", map $selector->(@_), @components; + } + } +}; + +sub FILTER (&;$) { + my $caller = caller; + my ($filter, $terminator) = @_; + no warnings 'redefine'; + *{"${caller}::import"} = gen_filter_import($caller,$filter,$terminator); + *{"${caller}::unimport"} = gen_filter_unimport($caller); +} + +sub FILTER_ONLY { + my $caller = caller; + while (@_ > 1) { + my ($what, $how) = splice(@_, 0, 2); + fail "Unknown selector: $what" + unless exists $extractor_for{$what}; + fail "Filter for $what is not a subroutine reference" + unless ref $how eq 'CODE'; + push @transforms, gen_std_filter_for($what,$how); + } + my $terminator = shift; + + my $multitransform = sub { + foreach my $transform ( @transforms ) { + $transform->(@_); + } + }; + no warnings 'redefine'; + *{"${caller}::import"} = + gen_filter_import($caller,$multitransform,$terminator); + *{"${caller}::unimport"} = gen_filter_unimport($caller); +} + +my $ows = qr/(?:[ \t]+|#[^\n]*)*/; + +sub gen_filter_import { + my ($class, $filter, $terminator) = @_; + my %terminator; + my $prev_import = *{$class."::import"}{CODE}; + return sub { + my ($imported_class, @args) = @_; + my $def_terminator = + qr/^(?:\s*no\s+$imported_class\s*;$ows|__(?:END|DATA)__)\r?$/; + if (!defined $terminator) { + $terminator{terminator} = $def_terminator; + } + elsif (!ref $terminator || ref $terminator eq 'Regexp') { + $terminator{terminator} = $terminator; + } + elsif (ref $terminator ne 'HASH') { + croak "Terminator must be specified as scalar or hash ref" + } + elsif (!exists $terminator->{terminator}) { + $terminator{terminator} = $def_terminator; + } + filter_add( + sub { + my ($status, $lastline); + my $count = 0; + my $data = ""; + while ($status = filter_read()) { + return $status if $status < 0; + if ($terminator{terminator} && + m/$terminator{terminator}/) { + $lastline = $_; + $count++; + last; + } + $data .= $_; + $count++; + $_ = ""; + } + return $count if not $count; + $_ = $data; + $filter->($imported_class, @args) unless $status < 0; + if (defined $lastline) { + if (defined $terminator{becomes}) { + $_ .= $terminator{becomes}; + } + elsif ($lastline =~ $def_terminator) { + $_ .= $lastline; + } + } + return $count; + } + ); + if ($prev_import) { + goto &$prev_import; + } + elsif ($class->isa('Exporter')) { + $class->export_to_level(1,@_); + } + } +} + +sub gen_filter_unimport { + my ($class) = @_; + return sub { + filter_del(); + goto &$prev_unimport if $prev_unimport; + } +} + +1; + +__END__ + +# B::Deparse.pm +# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant. +# All rights reserved. +# This module is free software; you can redistribute and/or modify +# it under the same terms as Perl itself. + +# This is based on the module of the same name by Malcolm Beattie, +# but essentially none of his code remains. + +package B::Deparse; +use Carp; +use B qw(class main_root main_start main_cv svref_2object opnumber perlstring + OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST + OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPf_PARENS + OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpKVSLICE + OPpCONST_BARE + OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY + OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpREPEAT_DOLIST + OPpSORT_REVERSE OPpMULTIDEREF_EXISTS OPpMULTIDEREF_DELETE + OPpSPLIT_ASSIGN OPpSPLIT_LEX + OPpPADHV_ISKEYS OPpRV2HV_ISKEYS + OPpCONCAT_NESTED + OPpMULTICONCAT_APPEND OPpMULTICONCAT_STRINGIFY OPpMULTICONCAT_FAKE + OPpTRUEBOOL OPpINDEX_BOOLNEG + SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG + SVs_PADTMP SVpad_TYPED + CVf_METHOD CVf_LVALUE + PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE + PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE + PADNAMEt_OUTER + MDEREF_reload + MDEREF_AV_pop_rv2av_aelem + MDEREF_AV_gvsv_vivify_rv2av_aelem + MDEREF_AV_padsv_vivify_rv2av_aelem + MDEREF_AV_vivify_rv2av_aelem + MDEREF_AV_padav_aelem + MDEREF_AV_gvav_aelem + MDEREF_HV_pop_rv2hv_helem + MDEREF_HV_gvsv_vivify_rv2hv_helem + MDEREF_HV_padsv_vivify_rv2hv_helem + MDEREF_HV_vivify_rv2hv_helem + MDEREF_HV_padhv_helem + MDEREF_HV_gvhv_helem + MDEREF_ACTION_MASK + MDEREF_INDEX_none + MDEREF_INDEX_const + MDEREF_INDEX_padsv + MDEREF_INDEX_gvsv + MDEREF_INDEX_MASK + MDEREF_FLAG_last + MDEREF_MASK + MDEREF_SHIFT + ); + +$VERSION = '1.48'; +use strict; +our $AUTOLOAD; +use warnings (); +require feature; + +use Config; + +BEGIN { + # List version-specific constants here. + # Easiest way to keep this code portable between version looks to + # be to fake up a dummy constant that will never actually be true. + foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER + OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE + PMf_CHARSET PMf_KEEPCOPY PMf_NOCAPTURE CVf_ANONCONST + CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST + PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES + OPpLVREF_TYPE OPpLVREF_SV OPpLVREF_AV OPpLVREF_HV + OPpLVREF_CV OPpLVREF_ELEM SVpad_STATE)) { + eval { B->import($_) }; + no strict 'refs'; + *{$_} = sub () {0} unless *{$_}{CODE}; + } +} + +# Todo: +# (See also BUGS section at the end of this file) +# +# - finish tr/// changes +# - add option for even more parens (generalize \&foo change) +# - left/right context +# - copy comments (look at real text with $^P?) +# - avoid semis in one-statement blocks +# - associativity of &&=, ||=, ?: +# - ',' => '=>' (auto-unquote?) +# - break long lines ("\r" as discretionary break?) +# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. +# - more style options: brace style, hex vs. octal, quotes, ... +# - print big ints as hex/octal instead of decimal (heuristic?) +# - handle 'my $x if 0'? +# - version using op_next instead of op_first/sibling? +# - avoid string copies (pass arrays, one big join?) +# - here-docs? + +# Current test.deparse failures +# comp/hints 6 - location of BEGIN blocks wrt. block openings +# run/switchI 1 - missing -I switches entirely +# perl -Ifoo -e 'print @INC' +# op/caller 2 - warning mask propagates backwards before warnings::register +# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' +# op/getpid 2 - can't assign to shared my() declaration (threads only) +# 'my $x : shared = 5' +# op/override 7 - parens on overridden require change v-string interpretation +# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' +# c.f. 'BEGIN { *f = sub {0} }; f 2' +# op/pat 774 - losing Unicode-ness of Latin1-only strings +# 'use charnames ":short"; $x="\N{latin:a with acute}"' +# op/recurse 12 - missing parens on recursive call makes it look like method +# 'sub f { f($x) }' +# op/subst 90 - inconsistent handling of utf8 under "use utf8" +# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open +# op/tiehandle compile - "use strict" deparsed in the wrong place +# uni/tr_ several +# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs +# ext/Data/Dumper/t/dumper compile +# ext/DB_file/several +# ext/Encode/several +# ext/Ernno/Errno warnings +# ext/IO/lib/IO/t/io_sel 23 +# ext/PerlIO/t/encoding compile +# ext/POSIX/t/posix 6 +# ext/Socket/Socket 8 +# ext/Storable/t/croak compile +# lib/Attribute/Handlers/t/multi compile +# lib/bignum/ several +# lib/charnames 35 +# lib/constant 32 +# lib/English 40 +# lib/ExtUtils/t/bytes 4 +# lib/File/DosGlob compile +# lib/Filter/Simple/t/data 1 +# lib/Math/BigInt/t/constant 1 +# lib/Net/t/config Deparse-warning +# lib/overload compile +# lib/Switch/ several +# lib/Symbol 4 +# lib/Test/Simple several +# lib/Term/Complete +# lib/Tie/File/t/29_downcopy 5 +# lib/vars 22 + +# Object fields: +# +# in_coderef2text: +# True when deparsing via $deparse->coderef2text; false when deparsing the +# main program. +# +# avoid_local: +# (local($a), local($b)) and local($a, $b) have the same internal +# representation but the short form looks better. We notice we can +# use a large-scale local when checking the list, but need to prevent +# individual locals too. This hash holds the addresses of OPs that +# have already had their local-ness accounted for. The same thing +# is done with my(). +# +# curcv: +# CV for current sub (or main program) being deparsed +# +# curcvlex: +# Cached hash of lexical variables for curcv: keys are +# names prefixed with "m" or "o" (representing my/our), and +# each value is an array with two elements indicating the cop_seq +# of scopes in which a var of that name is valid and a third ele- +# ment referencing the pad name. +# +# curcop: +# COP for statement being deparsed +# +# curstash: +# name of the current package for deparsed code +# +# subs_todo: +# array of [cop_seq, CV, is_format?, name] for subs and formats we still +# want to deparse. The fourth element is a pad name thingy for lexical +# subs or a string for special blocks. For other subs, it is undef. For +# lexical subs, CV may be undef, indicating a stub declaration. +# +# protos_todo: +# as above, but [name, prototype] for subs that never got a GV +# +# subs_done, forms_done: +# keys are addresses of GVs for subs and formats we've already +# deparsed (or at least put into subs_todo) +# +# subs_declared +# keys are names of subs for which we've printed declarations. +# That means we can omit parentheses from the arguments. It also means we +# need to put CORE:: on core functions of the same name. +# +# in_subst_repl +# True when deparsing the replacement part of a substitution. +# +# in_refgen +# True when deparsing the argument to \. +# +# parens: -p +# linenums: -l +# unquote: -q +# cuddle: ' ' or '\n', depending on -sC +# indent_size: -si +# use_tabs: -sT +# ex_const: -sv + +# A little explanation of how precedence contexts and associativity +# work: +# +# deparse() calls each per-op subroutine with an argument $cx (short +# for context, but not the same as the cx* in the perl core), which is +# a number describing the op's parents in terms of precedence, whether +# they're inside an expression or at statement level, etc. (see +# chart below). When ops with children call deparse on them, they pass +# along their precedence. Fractional values are used to implement +# associativity ('($x + $y) + $z' => '$x + $y + $y') and related +# parentheses hacks. The major disadvantage of this scheme is that +# it doesn't know about right sides and left sides, so say if you +# assign a listop to a variable, it can't tell it's allowed to leave +# the parens off the listop. + +# Precedences: +# 26 [TODO] inside interpolation context ("") +# 25 left terms and list operators (leftward) +# 24 left -> +# 23 nonassoc ++ -- +# 22 right ** +# 21 right ! ~ \ and unary + and - +# 20 left =~ !~ +# 19 left * / % x +# 18 left + - . +# 17 left << >> +# 16 nonassoc named unary operators +# 15 nonassoc < > <= >= lt gt le ge +# 14 nonassoc == != <=> eq ne cmp +# 13 left & +# 12 left | ^ +# 11 left && +# 10 left || +# 9 nonassoc .. ... +# 8 right ?: +# 7 right = += -= *= etc. +# 6 left , => +# 5 nonassoc list operators (rightward) +# 4 right not +# 3 left and +# 2 left or xor +# 1 statement modifiers +# 0.5 statements, but still print scopes as do { ... } +# 0 statement level +# -1 format body + +# Nonprinting characters with special meaning: +# \cS - steal parens (see maybe_parens_unop) +# \n - newline and indent +# \t - increase indent +# \b - decrease indent ('outdent') +# \f - flush left (no indent) +# \cK - kill following semicolon, if any + +# Semicolon handling: +# - Individual statements are not deparsed with trailing semicolons. +# (If necessary, \cK is tacked on to the end.) +# - Whatever code joins statements together or emits them (lineseq, +# scopeop, deparse_root) is responsible for adding semicolons where +# necessary. +# - use statements are deparsed with trailing semicolons because they are +# immediately concatenated with the following statement. +# - indent() removes semicolons wherever it sees \cK. + + +BEGIN { for (qw[ const stringify rv2sv list glob pushmark null aelem + kvaslice kvhslice padsv + nextstate dbstate rv2av rv2hv helem custom ]) { + eval "sub OP_\U$_ () { " . opnumber($_) . "}" +}} + +# _pessimise_walk(): recursively walk the optree of a sub, +# possibly undoing optimisations along the way. + +sub _pessimise_walk { + my ($self, $startop) = @_; + + return unless $$startop; + my ($op, $prevop); + for ($op = $startop; $$op; $prevop = $op, $op = $op->sibling) { + my $ppname = $op->name; + + # pessimisations start here + + if ($ppname eq "padrange") { + # remove PADRANGE: + # the original optimisation either (1) changed this: + # pushmark -> (various pad and list and null ops) -> the_rest + # or (2), for the = @_ case, changed this: + # pushmark -> gv[_] -> rv2av -> (pad stuff) -> the_rest + # into this: + # padrange ----------------------------------------> the_rest + # so we just need to convert the padrange back into a + # pushmark, and in case (1), set its op_next to op_sibling, + # which is the head of the original chain of optimised-away + # pad ops, or for (2), set it to sibling->first, which is + # the original gv[_]. + + $B::overlay->{$$op} = { + type => OP_PUSHMARK, + name => 'pushmark', + private => ($op->private & OPpLVAL_INTRO), + }; + } + + # pessimisations end here + + if (class($op) eq 'PMOP') { + if (ref($op->pmreplroot) + && ${$op->pmreplroot} + && $op->pmreplroot->isa( 'B::OP' )) + { + $self-> _pessimise_walk($op->pmreplroot); + } + + # pessimise any /(?{...})/ code blocks + my ($re, $cv); + my $code_list = $op->code_list; + if ($$code_list) { + $self->_pessimise_walk($code_list); + } + elsif (${$re = $op->pmregexp} && ${$cv = $re->qr_anoncv}) { + $code_list = $cv->ROOT # leavesub + ->first # qr + ->code_list; # list + $self->_pessimise_walk($code_list); + } + } + + if ($op->flags & OPf_KIDS) { + $self-> _pessimise_walk($op->first); + } + + } +} + + +# _pessimise_walk_exe(): recursively walk the op_next chain of a sub, +# possibly undoing optimisations along the way. + +sub _pessimise_walk_exe { + my ($self, $startop, $visited) = @_; + + no warnings 'recursion'; + + return unless $$startop; + return if $visited->{$$startop}; + my ($op, $prevop); + for ($op = $startop; $$op; $prevop = $op, $op = $op->next) { + last if $visited->{$$op}; + $visited->{$$op} = 1; + my $ppname = $op->name; + if ($ppname =~ + /^((and|d?or)(assign)?|(map|grep)while|range|cond_expr|once)$/ + # entertry is also a logop, but its op_other invariably points + # into the same chain as the main execution path, so we skip it + ) { + $self->_pessimise_walk_exe($op->other, $visited); + } + elsif ($ppname eq "subst") { + $self->_pessimise_walk_exe($op->pmreplstart, $visited); + } + elsif ($ppname =~ /^(enter(loop|iter))$/) { + # redoop and nextop will already be covered by the main block + # of the loop + $self->_pessimise_walk_exe($op->lastop, $visited); + } + + # pessimisations start here + } +} + +# Go through an optree and "remove" some optimisations by using an +# overlay to selectively modify or un-null some ops. Deparsing in the +# absence of those optimisations is then easier. +# +# Note that older optimisations are not removed, as Deparse was already +# written to recognise them before the pessimise/overlay system was added. + +sub pessimise { + my ($self, $root, $start) = @_; + + no warnings 'recursion'; + # walk tree in root-to-branch order + $self->_pessimise_walk($root); + + my %visited; + # walk tree in execution order + $self->_pessimise_walk_exe($start, \%visited); +} + + +sub null { + my $op = shift; + return class($op) eq "NULL"; +} + + +# Add a CV to the list of subs that still need deparsing. + +sub todo { + my $self = shift; + my($cv, $is_form, $name) = @_; + my $cvfile = $cv->FILE//''; + return unless ($cvfile eq $0 || exists $self->{files}{$cvfile}); + my $seq; + if ($cv->OUTSIDE_SEQ) { + $seq = $cv->OUTSIDE_SEQ; + } elsif (!null($cv->START) and is_state($cv->START)) { + $seq = $cv->START->cop_seq; + } else { + $seq = 0; + } + my $stash = $cv->STASH; + if (class($stash) eq 'HV') { + $self->{packs}{$stash->NAME}++; + } + push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form, $name]; +} + + +# Pop the next sub from the todo list and deparse it + +sub next_todo { + my $self = shift; + my $ent = shift @{$self->{'subs_todo'}}; + my ($seq, $cv, $is_form, $name) = @$ent; + + # any 'use strict; package foo' that should come before the sub + # declaration to sync with the first COP of the sub + my $pragmata = ''; + if ($cv and !null($cv->START) and is_state($cv->START)) { + $pragmata = $self->pragmata($cv->START); + } + + if (ref $name) { # lexical sub + # emit the sub. + my @text; + my $flags = $name->FLAGS; + push @text, + !$cv || $seq <= $name->COP_SEQ_RANGE_LOW + ? $self->keyword($flags & SVpad_OUR + ? "our" + : $flags & SVpad_STATE + ? "state" + : "my") . " " + : ""; + # XXX We would do $self->keyword("sub"), but ‘my CORE::sub’ + # doesn’t work and ‘my sub’ ignores a &sub in scope. I.e., + # we have a core bug here. + push @text, "sub " . substr $name->PVX, 1; + if ($cv) { + # my sub foo { } + push @text, " " . $self->deparse_sub($cv); + $text[-1] =~ s/ ;$/;/; + } + else { + # my sub foo; + push @text, ";\n"; + } + return $pragmata . join "", @text; + } + + my $gv = $cv->GV; + $name //= $self->gv_name($gv); + if ($is_form) { + return $pragmata . $self->keyword("format") . " $name =\n" + . $self->deparse_format($cv). "\n"; + } else { + my $use_dec; + if ($name eq "BEGIN") { + $use_dec = $self->begin_is_use($cv); + if (defined ($use_dec) and $self->{'expand'} < 5) { + return $pragmata if 0 == length($use_dec); + + # XXX bit of a hack: Test::More's use_ok() method + # builds a fake use statement which deparses as, e.g. + # use Net::Ping (@{$args[0];}); + # As well as being superfluous (the use_ok() is deparsed + # too) and ugly, it fails under use strict and otherwise + # makes use of a lexical var that's not in scope. + # So strip it out. + return $pragmata + if $use_dec =~ + m/ + \A + use \s \S+ \s \(\@\{ + ( + \s*\#line\ \d+\ \".*"\s* + )? + \$args\[0\];\}\); + \n + \Z + /x; + + $use_dec =~ s/^(use|no)\b/$self->keyword($1)/e; + } + } + my $l = ''; + if ($self->{'linenums'}) { + my $line = $gv->LINE; + my $file = $gv->FILE; + $l = "\n\f#line $line \"$file\"\n"; + } + my $p = ''; + my $stash; + if (class($cv->STASH) ne "SPECIAL") { + $stash = $cv->STASH->NAME; + if ($stash ne $self->{'curstash'}) { + $p = $self->keyword("package") . " $stash;\n"; + $name = "$self->{'curstash'}::$name" unless $name =~ /::/; + $self->{'curstash'} = $stash; + } + } + if ($use_dec) { + return "$pragmata$p$l$use_dec"; + } + if ( $name !~ /::/ and $self->lex_in_scope("&$name") + || $self->lex_in_scope("&$name", 1) ) + { + $name = "$self->{'curstash'}::$name"; + } elsif (defined $stash) { + $name =~ s/^\Q$stash\E::(?!\z|.*::)//; + } + my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name " + . $self->deparse_sub($cv); + $self->{'subs_declared'}{$name} = 1; + return $ret; + } +} + + +# Return a "use" declaration for this BEGIN block, if appropriate +sub begin_is_use { + my ($self, $cv) = @_; + my $root = $cv->ROOT; + local @$self{qw'curcv curcvlex'} = ($cv); + local $B::overlay = {}; + $self->pessimise($root, $cv->START); +#require B::Debug; +#B::walkoptree($cv->ROOT, "debug"); + my $lineseq = $root->first; + return if $lineseq->name ne "lineseq"; + + my $req_op = $lineseq->first->sibling; + return if $req_op->name ne "require"; + + # maybe it's C rather than C + return if ($req_op->first->name ne 'const'); + + my $module; + if ($req_op->first->private & OPpCONST_BARE) { + # Actually it should always be a bareword + $module = $self->const_sv($req_op->first)->PV; + $module =~ s[/][::]g; + $module =~ s/.pm$//; + } + else { + $module = $self->const($self->const_sv($req_op->first), 6); + } + + my $version; + my $version_op = $req_op->sibling; + return if class($version_op) eq "NULL"; + if ($version_op->name eq "lineseq") { + # We have a version parameter; skip nextstate & pushmark + my $constop = $version_op->first->next->next; + + return unless $self->const_sv($constop)->PV eq $module; + $constop = $constop->sibling; + $version = $self->const_sv($constop); + if (class($version) eq "IV") { + $version = $version->int_value; + } elsif (class($version) eq "NV") { + $version = $version->NV; + } elsif (class($version) ne "PVMG") { + # Includes PVIV and PVNV + $version = $version->PV; + } else { + # version specified as a v-string + $version = 'v'.join '.', map ord, split //, $version->PV; + } + $constop = $constop->sibling; + return if $constop->name ne "method_named"; + return if $self->meth_sv($constop)->PV ne "VERSION"; + } + + $lineseq = $version_op->sibling; + return if $lineseq->name ne "lineseq"; + my $entersub = $lineseq->first->sibling; + if ($entersub->name eq "stub") { + return "use $module $version ();\n" if defined $version; + return "use $module ();\n"; + } + return if $entersub->name ne "entersub"; + + # See if there are import arguments + my $args = ''; + + my $svop = $entersub->first->sibling; # Skip over pushmark + return unless $self->const_sv($svop)->PV eq $module; + + # Pull out the arguments + for ($svop=$svop->sibling; index($svop->name, "method_") != 0; + $svop = $svop->sibling) { + $args .= ", " if length($args); + $args .= $self->deparse($svop, 6); + } + + my $use = 'use'; + my $method_named = $svop; + return if $method_named->name ne "method_named"; + my $method_name = $self->meth_sv($method_named)->PV; + + if ($method_name eq "unimport") { + $use = 'no'; + } + + # Certain pragmas are dealt with using hint bits, + # so we ignore them here + if ($module eq 'strict' || $module eq 'integer' + || $module eq 'bytes' || $module eq 'warnings' + || $module eq 'feature') { + return ""; + } + + if (defined $version && length $args) { + return "$use $module $version ($args);\n"; + } elsif (defined $version) { + return "$use $module $version;\n"; + } elsif (length $args) { + return "$use $module ($args);\n"; + } else { + return "$use $module;\n"; + } +} + +sub stash_subs { + my ($self, $pack, $seen) = @_; + my (@ret, $stash); + if (!defined $pack) { + $pack = ''; + $stash = \%::; + } + else { + $pack =~ s/(::)?$/::/; + no strict 'refs'; + $stash = \%{"main::$pack"}; + } + return + if ($seen ||= {})->{ + $INC{"overload.pm"} ? overload::StrVal($stash) : $stash + }++; + my $stashobj = svref_2object($stash); + my %stash = $stashobj->ARRAY; + while (my ($key, $val) = each %stash) { + my $flags = $val->FLAGS; + if ($flags & SVf_ROK) { + # A reference. Dump this if it is a reference to a CV. If it + # is a constant acting as a proxy for a full subroutine, then + # we may or may not have to dump it. If some form of perl- + # space visible code must have created it, be it a use + # statement, or some direct symbol-table manipulation code that + # we will deparse, then we don’t want to dump it. If it is the + # result of a declaration like sub f () { 42 } then we *do* + # want to dump it. The only way to distinguish these seems + # to be the SVs_PADTMP flag on the constant, which is admit- + # tedly a hack. + my $class = class(my $referent = $val->RV); + if ($class eq "CV") { + $self->todo($referent, 0); + } elsif ( + $class !~ /^(AV|HV|CV|FM|IO|SPECIAL)\z/ + # A more robust way to write that would be this, but B does + # not provide the SVt_ constants: + # ($referent->FLAGS & B::SVTYPEMASK) < B::SVt_PVAV + and $referent->FLAGS & SVs_PADTMP + ) { + push @{$self->{'protos_todo'}}, [$pack . $key, $val]; + } + } elsif ($flags & (SVf_POK|SVf_IOK)) { + # Just a prototype. As an ugly but fairly effective way + # to find out if it belongs here is to see if the AUTOLOAD + # (if any) for the stash was defined in one of our files. + my $A = $stash{"AUTOLOAD"}; + if (defined ($A) && class($A) eq "GV" && defined($A->CV) + && class($A->CV) eq "CV") { + my $AF = $A->FILE; + next unless $AF eq $0 || exists $self->{'files'}{$AF}; + } + push @{$self->{'protos_todo'}}, + [$pack . $key, $flags & SVf_POK ? $val->PV: undef]; + } elsif (class($val) eq "GV") { + if (class(my $cv = $val->CV) ne "SPECIAL") { + next if $self->{'subs_done'}{$$val}++; + + # Ignore imposters (aliases etc) + my $name = $cv->NAME_HEK; + if(defined $name) { + # avoid using $cv->GV here because if the $val GV is + # an alias, CvGV() could upgrade the real stash entry + # from an RV to a GV + next unless $name eq $key; + next unless $$stashobj == ${$cv->STASH}; + } + else { + next if $$val != ${$cv->GV}; + } + + $self->todo($cv, 0); + } + if (class(my $cv = $val->FORM) ne "SPECIAL") { + next if $self->{'forms_done'}{$$val}++; + next if $$val != ${$cv->GV}; # Ignore imposters + $self->todo($cv, 1); + } + if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { + $self->stash_subs($pack . $key, $seen); + } + } + } +} + +sub print_protos { + my $self = shift; + my $ar; + my @ret; + foreach $ar (@{$self->{'protos_todo'}}) { + if (ref $ar->[1]) { + # Only print a constant if it occurs in the same package as a + # dumped sub. This is not perfect, but a heuristic that will + # hopefully work most of the time. Ideally we would use + # CvFILE, but a constant stub has no CvFILE. + my $pack = ($ar->[0] =~ /(.*)::/)[0]; + next if $pack and !$self->{packs}{$pack} + } + my $body = defined $ar->[1] + ? ref $ar->[1] + ? " () {\n " . $self->const($ar->[1]->RV,0) . ";\n}" + : " (". $ar->[1] . ");" + : ";"; + push @ret, "sub " . $ar->[0] . "$body\n"; + } + delete $self->{'protos_todo'}; + return @ret; +} + +sub style_opts { + my $self = shift; + my $opts = shift; + my $opt; + while (length($opt = substr($opts, 0, 1))) { + if ($opt eq "C") { + $self->{'cuddle'} = " "; + $opts = substr($opts, 1); + } elsif ($opt eq "i") { + $opts =~ s/^i(\d+)//; + $self->{'indent_size'} = $1; + } elsif ($opt eq "T") { + $self->{'use_tabs'} = 1; + $opts = substr($opts, 1); + } elsif ($opt eq "v") { + $opts =~ s/^v([^.]*)(.|$)//; + $self->{'ex_const'} = $1; + } + } +} + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{'cuddle'} = "\n"; + $self->{'curcop'} = undef; + $self->{'curstash'} = "main"; + $self->{'ex_const'} = "'???'"; + $self->{'expand'} = 0; + $self->{'files'} = {}; + $self->{'packs'} = {}; + $self->{'indent_size'} = 4; + $self->{'linenums'} = 0; + $self->{'parens'} = 0; + $self->{'subs_todo'} = []; + $self->{'unquote'} = 0; + $self->{'use_dumper'} = 0; + $self->{'use_tabs'} = 0; + + $self->{'ambient_arybase'} = 0; + $self->{'ambient_warnings'} = undef; # Assume no lexical warnings + $self->{'ambient_hints'} = 0; + $self->{'ambient_hinthash'} = undef; + $self->init(); + + while (my $arg = shift @_) { + if ($arg eq "-d") { + $self->{'use_dumper'} = 1; + require Data::Dumper; + } elsif ($arg =~ /^-f(.*)/) { + $self->{'files'}{$1} = 1; + } elsif ($arg eq "-l") { + $self->{'linenums'} = 1; + } elsif ($arg eq "-p") { + $self->{'parens'} = 1; + } elsif ($arg eq "-P") { + $self->{'noproto'} = 1; + } elsif ($arg eq "-q") { + $self->{'unquote'} = 1; + } elsif (substr($arg, 0, 2) eq "-s") { + $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; + } + } + return $self; +} + +{ + # Mask out the bits that L uses + my $WARN_MASK; + BEGIN { + $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; + } + sub WARN_MASK () { + return $WARN_MASK; + } +} + +# Initialise the contextual information, either from +# defaults provided with the ambient_pragmas method, +# or from perl's own defaults otherwise. +sub init { + my $self = shift; + + $self->{'arybase'} = $self->{'ambient_arybase'}; + $self->{'warnings'} = defined ($self->{'ambient_warnings'}) + ? $self->{'ambient_warnings'} & WARN_MASK + : undef; + $self->{'hints'} = $self->{'ambient_hints'}; + $self->{'hinthash'} = $self->{'ambient_hinthash'}; + + # also a convenient place to clear out subs_declared + delete $self->{'subs_declared'}; +} + +sub compile { + my(@args) = @_; + return sub { + my $self = B::Deparse->new(@args); + # First deparse command-line args + if (defined $^I) { # deparse -i + print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); + } + if ($^W) { # deparse -w + print qq(BEGIN { \$^W = $^W; }\n); + } + if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 + my $fs = perlstring($/) || 'undef'; + my $bs = perlstring($O::savebackslash) || 'undef'; + print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); + } + my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); + my @UNITCHECKs = B::unitcheck_av->isa("B::AV") + ? B::unitcheck_av->ARRAY + : (); + my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); + my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); + my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); + my @names = qw(BEGIN UNITCHECK CHECK INIT END); + my @blocks = \(@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs); + while (@names) { + my ($name, $blocks) = (shift @names, shift @blocks); + for my $block (@$blocks) { + $self->todo($block, 0, $name); + } + } + $self->stash_subs(); + local($SIG{"__DIE__"}) = + sub { + if ($self->{'curcop'}) { + my $cop = $self->{'curcop'}; + my($line, $file) = ($cop->line, $cop->file); + print STDERR "While deparsing $file near line $line,\n"; + } + }; + $self->{'curcv'} = main_cv; + $self->{'curcvlex'} = undef; + print $self->print_protos; + @{$self->{'subs_todo'}} = + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; + my $root = main_root; + local $B::overlay = {}; + unless (null $root) { + $self->pad_subs($self->{'curcv'}); + # Check for a stub-followed-by-ex-cop, resulting from a program + # consisting solely of sub declarations. For backward-compati- + # bility (and sane output) we don’t want to emit the stub. + # leave + # enter + # stub + # ex-nextstate (or ex-dbstate) + my $kid; + if ( $root->name eq 'leave' + and ($kid = $root->first)->name eq 'enter' + and !null($kid = $kid->sibling) and $kid->name eq 'stub' + and !null($kid = $kid->sibling) and $kid->name eq 'null' + and class($kid) eq 'COP' and null $kid->sibling ) + { + # ignore + } else { + $self->pessimise($root, main_start); + print $self->indent($self->deparse_root($root)), "\n"; + } + } + my @text; + while (scalar(@{$self->{'subs_todo'}})) { + push @text, $self->next_todo; + } + print $self->indent(join("", @text)), "\n" if @text; + + # Print __DATA__ section, if necessary + no strict 'refs'; + my $laststash = defined $self->{'curcop'} + ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; + if (defined *{$laststash."::DATA"}{IO}) { + print $self->keyword("package") . " $laststash;\n" + unless $laststash eq $self->{'curstash'}; + print $self->keyword("__DATA__") . "\n"; + print readline(*{$laststash."::DATA"}); + } + } +} + +sub coderef2text { + my $self = shift; + my $sub = shift; + croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); + + $self->init(); + local $self->{in_coderef2text} = 1; + return $self->indent($self->deparse_sub(svref_2object($sub))); +} + +my %strict_bits = do { + local $^H; + map +($_ => strict::bits($_)), qw/refs subs vars/ +}; + +sub ambient_pragmas { + my $self = shift; + my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0); + + while (@_ > 1) { + my $name = shift(); + my $val = shift(); + + if ($name eq 'strict') { + require strict; + + if ($val eq 'none') { + $hint_bits &= $strict_bits{$_} for qw/refs subs vars/; + next(); + } + + my @names; + if ($val eq "all") { + @names = qw/refs subs vars/; + } + elsif (ref $val) { + @names = @$val; + } + else { + @names = split' ', $val; + } + $hint_bits |= $strict_bits{$_} for @names; + } + + elsif ($name eq '$[') { + if (OPpCONST_ARYBASE) { + $arybase = $val; + } else { + croak "\$[ can't be non-zero on this perl" unless $val == 0; + } + } + + elsif ($name eq 'integer' + || $name eq 'bytes' + || $name eq 'utf8') { + require "$name.pm"; + if ($val) { + $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; + } + else { + $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; + } + } + + elsif ($name eq 're') { + require re; + if ($val eq 'none') { + $hint_bits &= ~re::bits(qw/taint eval/); + next(); + } + + my @names; + if ($val eq 'all') { + @names = qw/taint eval/; + } + elsif (ref $val) { + @names = @$val; + } + else { + @names = split' ',$val; + } + $hint_bits |= re::bits(@names); + } + + elsif ($name eq 'warnings') { + if ($val eq 'none') { + $warning_bits = $warnings::NONE; + next(); + } + + my @names; + if (ref $val) { + @names = @$val; + } + else { + @names = split/\s+/, $val; + } + + $warning_bits = $warnings::NONE if !defined ($warning_bits); + $warning_bits |= warnings::bits(@names); + } + + elsif ($name eq 'warning_bits') { + $warning_bits = $val; + } + + elsif ($name eq 'hint_bits') { + $hint_bits = $val; + } + + elsif ($name eq '%^H') { + $hinthash = $val; + } + + else { + croak "Unknown pragma type: $name"; + } + } + if (@_) { + croak "The ambient_pragmas method expects an even number of args"; + } + + $self->{'ambient_arybase'} = $arybase; + $self->{'ambient_warnings'} = $warning_bits; + $self->{'ambient_hints'} = $hint_bits; + $self->{'ambient_hinthash'} = $hinthash; +} + +# This method is the inner loop, so try to keep it simple +sub deparse { + my $self = shift; + my($op, $cx) = @_; + + Carp::confess("Null op in deparse") if !defined($op) + || class($op) eq "NULL"; + my $meth = "pp_" . $op->name; + return $self->$meth($op, $cx); +} + +sub indent { + my $self = shift; + my $txt = shift; + # \cK also swallows a preceding line break when followed by a + # semicolon. + $txt =~ s/\n\cK;//g; + my @lines = split(/\n/, $txt); + my $leader = ""; + my $level = 0; + my $line; + for $line (@lines) { + my $cmd = substr($line, 0, 1); + if ($cmd eq "\t" or $cmd eq "\b") { + $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; + if ($self->{'use_tabs'}) { + $leader = "\t" x ($level / 8) . " " x ($level % 8); + } else { + $leader = " " x $level; + } + $line = substr($line, 1); + } + if (index($line, "\f") > 0) { + $line =~ s/\f/\n/; + } + if (substr($line, 0, 1) eq "\f") { + $line = substr($line, 1); # no indent + } else { + $line = $leader . $line; + } + $line =~ s/\cK;?//g; + } + return join("\n", @lines); +} + +sub pad_subs { + my ($self, $cv) = @_; + my $padlist = $cv->PADLIST; + my @names = $padlist->ARRAYelt(0)->ARRAY; + my @values = $padlist->ARRAYelt(1)->ARRAY; + my @todo; + PADENTRY: + for my $ix (0.. $#names) { for $_ ($names[$ix]) { + next if class($_) eq "SPECIAL"; + my $name = $_->PVX; + if (defined $name && $name =~ /^&./) { + my $low = $_->COP_SEQ_RANGE_LOW; + my $flags = $_->FLAGS; + my $outer = $flags & PADNAMEt_OUTER; + if ($flags & SVpad_OUR) { + push @todo, [$low, undef, 0, $_] + # [seq, no cv, not format, padname] + unless $outer; + next; + } + my $protocv = $flags & SVpad_STATE + ? $values[$ix] + : $_->PROTOCV; + if (class ($protocv) ne 'CV') { + my $flags = $flags; + my $cv = $cv; + my $name = $_; + while ($flags & PADNAMEt_OUTER && class ($protocv) ne 'CV') + { + $cv = $cv->OUTSIDE; + next PADENTRY if class($cv) eq 'SPECIAL'; # XXX freed? + my $padlist = $cv->PADLIST; + my $ix = $name->PARENT_PAD_INDEX; + $name = $padlist->NAMES->ARRAYelt($ix); + $flags = $name->FLAGS; + $protocv = $flags & SVpad_STATE + ? $padlist->ARRAYelt(1)->ARRAYelt($ix) + : $name->PROTOCV; + } + } + my $defined_in_this_sub = ${$protocv->OUTSIDE} == $$cv || do { + my $other = $protocv->PADLIST; + $$other && $other->outid == $padlist->id; + }; + if ($flags & PADNAMEt_OUTER) { + next unless $defined_in_this_sub; + push @todo, [$protocv->OUTSIDE_SEQ, $protocv, 0, $_]; + next; + } + my $outseq = $protocv->OUTSIDE_SEQ; + if ($outseq <= $low) { + # defined before its name is visible, so it’s gotta be + # declared and defined at once: my sub foo { ... } + push @todo, [$low, $protocv, 0, $_]; + } + else { + # declared and defined separately: my sub f; sub f { ... } + push @todo, [$low, undef, 0, $_]; + push @todo, [$outseq, $protocv, 0, $_] + if $defined_in_this_sub; + } + } + }} + @{$self->{'subs_todo'}} = + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo +} + + +# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem +# ops into a subroutine signature. If successful, return the first op +# following the signature ops plus the signature string; else return the +# empty list. +# +# Normally a bunch of argelem ops will have been generated by the +# signature parsing, but it's possible that ops have been added manually +# or altered. In this case we return "()" and fall back to general +# deparsing of the individual sigelems as 'my $x = $_[N]' etc. +# +# We're only called if the first two ops are nextstate and argcheck. + +sub deparse_argops { + my ($self, $firstop, $cv) = @_; + + my @sig; + my $o = $firstop; + return if $o->label; #first nextstate; + + # OP_ARGCHECK + + $o = $o->sibling; + my ($params, $opt_params, $slurpy) = $o->aux_list($cv); + my $mandatory = $params - $opt_params; + my $seen_slurpy = 0; + my $last_ix = -1; + + # keep looking for valid nextstate + argelem pairs + + while (1) { + # OP_NEXTSTATE + $o = $o->sibling; + last unless $$o; + last unless $o->name =~ /^(next|db)state$/; + last if $o->label; + + # OP_ARGELEM + my $o2 = $o->sibling; + last unless $$o2; + + if ($o2->name eq 'argelem') { + my $ix = $o2->string($cv); + while (++$last_ix < $ix) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + my $var = $self->padname($o2->targ); + if ($var =~ /^[@%]/) { + return if $seen_slurpy; + $seen_slurpy = 1; + return if $ix != $params or !$slurpy + or substr($var,0,1) ne $slurpy; + } + else { + return if $ix >= $params; + } + if ($o2->flags & OPf_KIDS) { + my $kid = $o2->first; + return unless $$kid and $kid->name eq 'argdefelem'; + my $def = $self->deparse($kid->first, 7); + $def = "($def)" if $kid->first->flags & OPf_PARENS; + $var .= " = $def"; + } + push @sig, $var; + } + elsif ($o2->name eq 'null' + and ($o2->flags & OPf_KIDS) + and $o2->first->name eq 'argdefelem') + { + # special case - a void context default expression: $ = expr + + my $defop = $o2->first; + my $ix = $defop->targ; + while (++$last_ix < $ix) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + return if $last_ix >= $params + or $last_ix < $mandatory; + my $def = $self->deparse($defop->first, 7); + $def = "($def)" if $defop->first->flags & OPf_PARENS; + push @sig, '$ = ' . $def; + } + else { + last; + } + + $o = $o2; + } + + while (++$last_ix < $params) { + push @sig, $last_ix < $mandatory ? '$' : '$='; + } + push @sig, $slurpy if $slurpy and !$seen_slurpy; + + return ($o, join(', ', @sig)); +} + +# Deparse a sub. Returns everything except the 'sub foo', +# e.g. ($$) : method { ...; } +# or : prototype($$) lvalue ($a, $b) { ...; }; + +sub deparse_sub { + my $self = shift; + my $cv = shift; + my @attrs; + my $proto; + my $sig; + +Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); +Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); + local $self->{'curcop'} = $self->{'curcop'}; + + my $has_sig = $self->{hinthash}{feature_signatures}; + if ($cv->FLAGS & SVf_POK) { + my $myproto = $cv->PV; + if ($has_sig) { + push @attrs, "prototype($myproto)"; + } + else { + $proto = $myproto; + } + } + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) { + push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE; + push @attrs, "method" if $cv->CvFLAGS & CVf_METHOD; + push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST; + } + + local($self->{'curcv'}) = $cv; + local($self->{'curcvlex'}); + local(@$self{qw'curstash warnings hints hinthash'}) + = @$self{qw'curstash warnings hints hinthash'}; + my $body; + my $root = $cv->ROOT; + local $B::overlay = {}; + if (not null $root) { + $self->pad_subs($cv); + $self->pessimise($root, $cv->START); + my $lineseq = $root->first; + if ($lineseq->name eq "lineseq") { + my $firstop = $lineseq->first; + + if ($has_sig) { + my $o2; + # try to deparse first few ops as a signature if possible + if ( $$firstop + and $firstop->name =~ /^(next|db)state$/ + and (($o2 = $firstop->sibling)) + and $$o2) + { + if ($o2->name eq 'argcheck') { + my ($nexto, $mysig) = $self->deparse_argops($firstop, $cv); + if (defined $nexto) { + $firstop = $nexto; + $sig = $mysig; + } + } + } + } + + my @ops; + for (my $o = $firstop; $$o; $o=$o->sibling) { + push @ops, $o; + } + $body = $self->lineseq(undef, 0, @ops).";"; + if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) { + # this handles void context in + # use feature signatures; sub ($=1) {} + $body .= "\n()"; + } + my $scope_en = $self->find_scope_en($lineseq); + if (defined $scope_en) { + my $subs = join"", $self->seq_subs($scope_en); + $body .= ";\n$subs" if length($subs); + } + } + else { + $body = $self->deparse($root->first, 0); + } + + my $l = ''; + if ($self->{'linenums'}) { + # a glob's gp_line is set from the line containing a + # sub's closing '}' if the CV is the first use of the GV. + # So make sure the linenum is set correctly for '}' + my $gv = $cv->GV; + my $line = $gv->LINE; + my $file = $gv->FILE; + $l = "\f#line $line \"$file\"\n"; + } + $body = "{\n\t$body\n$l\b}"; + } + else { + my $sv = $cv->const_sv; + if ($$sv) { + # uh-oh. inlinable sub... format it differently + $body = "{ " . $self->const($sv, 0) . " }\n"; + } else { # XSUB? (or just a declaration) + $body = ';' + } + } + $proto = defined $proto ? "($proto) " : ""; + $sig = defined $sig ? "($sig) " : ""; + my $attrs = ''; + $attrs = ': ' . join('', map "$_ ", @attrs) if @attrs; + return "$proto$attrs$sig$body\n"; +} + +sub deparse_format { + my $self = shift; + my $form = shift; + my @text; + local($self->{'curcv'}) = $form; + local($self->{'curcvlex'}); + local($self->{'in_format'}) = 1; + local(@$self{qw'curstash warnings hints hinthash'}) + = @$self{qw'curstash warnings hints hinthash'}; + my $op = $form->ROOT; + local $B::overlay = {}; + $self->pessimise($op, $form->START); + my $kid; + return "\f." if $op->first->name eq 'stub' + || $op->first->name eq 'nextstate'; + $op = $op->first->first; # skip leavewrite, lineseq + while (not null $op) { + $op = $op->sibling; # skip nextstate + my @exprs; + $kid = $op->first->sibling; # skip pushmark + push @text, "\f".$self->const_sv($kid)->PV; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, -1); + $exprs[-1] =~ s/;\z//; + } + push @text, "\f".join(", ", @exprs)."\n" if @exprs; + $op = $op->sibling; + } + return join("", @text) . "\f."; +} + +sub is_scope { + my $op = shift; + return $op->name eq "leave" || $op->name eq "scope" + || $op->name eq "lineseq" + || ($op->name eq "null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->name eq "enter")); +} + +sub is_state { + my $name = $_[0]->name; + return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; +} + +sub is_miniwhile { # check for one-line loop ('foo() while $y--') + my $op = shift; + return (!null($op) and null($op->sibling) + and $op->name eq "null" and class($op) eq "UNOP" + and (($op->first->name =~ /^(and|or)$/ + and $op->first->first->sibling->name eq "lineseq") + or ($op->first->name eq "lineseq" + and not null $op->first->first->sibling + and $op->first->first->sibling->name eq "unstack") + )); +} + +# Check if the op and its sibling are the initialization and the rest of a +# for (..;..;..) { ... } loop +sub is_for_loop { + my $op = shift; + # This OP might be almost anything, though it won't be a + # nextstate. (It's the initialization, so in the canonical case it + # will be an sassign.) The sibling is (old style) a lineseq whose + # first child is a nextstate and whose second is a leaveloop, or + # (new style) an unstack whose sibling is a leaveloop. + my $lseq = $op->sibling; + return 0 unless !is_state($op) and !null($lseq); + if ($lseq->name eq "lineseq") { + if ($lseq->first && !null($lseq->first) && is_state($lseq->first) + && (my $sib = $lseq->first->sibling)) { + return (!null($sib) && $sib->name eq "leaveloop"); + } + } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) { + my $sib = $lseq->sibling; + return $sib && !null($sib) && $sib->name eq "leaveloop"; + } + return 0; +} + +sub is_scalar { + my $op = shift; + return ($op->name eq "rv2sv" or + $op->name eq "padsv" or + $op->name eq "gv" or # only in array/hash constructs + $op->flags & OPf_KIDS && !null($op->first) + && $op->first->name eq "gvsv"); +} + +sub maybe_parens { + my $self = shift; + my($text, $cx, $prec) = @_; + if ($prec < $cx # unary ops nest just fine + or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 + or $self->{'parens'}) + { + $text = "($text)"; + # In a unop, let parent reuse our parens; see maybe_parens_unop + $text = "\cS" . $text if $cx == 16; + return $text; + } else { + return $text; + } +} + +# same as above, but get around the 'if it looks like a function' rule +sub maybe_parens_unop { + my $self = shift; + my($name, $kid, $cx) = @_; + if ($cx > 16 or $self->{'parens'}) { + $kid = $self->deparse($kid, 1); + if ($name eq "umask" && $kid =~ /^\d+$/) { + $kid = sprintf("%#o", $kid); + } + return $self->keyword($name) . "($kid)"; + } else { + $kid = $self->deparse($kid, 16); + if ($name eq "umask" && $kid =~ /^\d+$/) { + $kid = sprintf("%#o", $kid); + } + $name = $self->keyword($name); + if (substr($kid, 0, 1) eq "\cS") { + # use kid's parens + return $name . substr($kid, 1); + } elsif (substr($kid, 0, 1) eq "(") { + # avoid looks-like-a-function trap with extra parens + # ('+' can lead to ambiguities) + return "$name(" . $kid . ")"; + } else { + return "$name $kid"; + } + } +} + +sub maybe_parens_func { + my $self = shift; + my($func, $text, $cx, $prec) = @_; + if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { + return "$func($text)"; + } else { + return "$func $text"; + } +} + +sub find_our_type { + my ($self, $name) = @_; + $self->populate_curcvlex() if !defined $self->{'curcvlex'}; + my $seq = $self->{'curcop'} ? $self->{'curcop'}->cop_seq : 0; + for my $a (@{$self->{'curcvlex'}{"o$name"}}) { + my ($st, undef, $padname) = @$a; + if ($st >= $seq && $padname->FLAGS & SVpad_TYPED) { + return $padname->SvSTASH->NAME; + } + } + return ''; +} + +sub maybe_local { + my $self = shift; + my($op, $cx, $text) = @_; + my $name = $op->name; + my $our_intro = ($name =~ /^(?:(?:gv|rv2)[ash]v|split|refassign + |lv(?:av)?ref)$/x) + ? OPpOUR_INTRO + : 0; + my $lval_intro = $name eq 'split' ? 0 : OPpLVAL_INTRO; + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + my $need_parens = $self->{'in_refgen'} && $name =~ /[ah]v\z/ + && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; + if ((my $priv = $op->private) & ($lval_intro|$our_intro)) { + my @our_local; + push @our_local, "local" if $priv & $lval_intro; + push @our_local, "our" if $priv & $our_intro; + my $our_local = join " ", map $self->keyword($_), @our_local; + if( $our_local[-1] eq 'our' ) { + if ( $text !~ /^\W(\w+::)*\w+\z/ + and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/ + ) { + die "Unexpected our($text)\n"; + } + $text =~ s/(\w+::)+//; + + if (my $type = $self->find_our_type($text)) { + $our_local .= ' ' . $type; + } + } + return $need_parens ? "($text)" : $text + if $self->{'avoid_local'}{$$op}; + if ($need_parens) { + return "$our_local($text)"; + } elsif (want_scalar($op) || $our_local eq 'our') { + return "$our_local $text"; + } else { + return $self->maybe_parens_func("$our_local", $text, $cx, 16); + } + } else { + return $need_parens ? "($text)" : $text; + } +} + +sub maybe_targmy { + my $self = shift; + my($op, $cx, $func, @args) = @_; + if ($op->private & OPpTARGET_MY) { + my $var = $self->padname($op->targ); + my $val = $func->($self, $op, 7, @args); + return $self->maybe_parens("$var = $val", $cx, 7); + } else { + return $func->($self, $op, $cx, @args); + } +} + +sub padname_sv { + my $self = shift; + my $targ = shift; + return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); +} + +sub maybe_my { + my $self = shift; + my($op, $cx, $text, $padname, $forbid_parens) = @_; + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + my $need_parens = !$forbid_parens && $self->{'in_refgen'} + && $op->name =~ /[ah]v\z/ + && ($op->flags & (OPf_PARENS|OPf_REF)) == OPf_PARENS; + # The @a in \my @a must not have parens. + if (!$need_parens && $self->{'in_refgen'}) { + $forbid_parens = 1; + } + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + # Check $padname->FLAGS for statehood, rather than $op->private, + # because enteriter ops do not carry the flag. + my $my = + $self->keyword($padname->FLAGS & SVpad_STATE ? "state" : "my"); + if ($padname->FLAGS & SVpad_TYPED) { + $my .= ' ' . $padname->SvSTASH->NAME; + } + if ($need_parens) { + return "$my($text)"; + } elsif ($forbid_parens || want_scalar($op)) { + return "$my $text"; + } else { + return $self->maybe_parens_func($my, $text, $cx, 16); + } + } else { + return $need_parens ? "($text)" : $text; + } +} + +# The following OPs don't have functions: + +# pp_padany -- does not exist after parsing + +sub AUTOLOAD { + if ($AUTOLOAD =~ s/^.*::pp_//) { + warn "unexpected OP_". + ($_[1]->type == OP_CUSTOM ? "CUSTOM ($AUTOLOAD)" : uc $AUTOLOAD); + return "XXX"; + } else { + die "Undefined subroutine $AUTOLOAD called"; + } +} + +sub DESTROY {} # Do not AUTOLOAD + +# $root should be the op which represents the root of whatever +# we're sequencing here. If it's undefined, then we don't append +# any subroutine declarations to the deparsed ops, otherwise we +# append appropriate declarations. +sub lineseq { + my($self, $root, $cx, @ops) = @_; + my($expr, @exprs); + + my $out_cop = $self->{'curcop'}; + my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; + my $limit_seq; + if (defined $root) { + $limit_seq = $out_seq; + my $nseq; + $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; + $limit_seq = $nseq if !defined($limit_seq) + or defined($nseq) && $nseq < $limit_seq; + } + $limit_seq = $self->{'limit_seq'} + if defined($self->{'limit_seq'}) + && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); + local $self->{'limit_seq'} = $limit_seq; + + $self->walk_lineseq($root, \@ops, + sub { push @exprs, $_[0]} ); + + my $sep = $cx ? '; ' : ";\n"; + my $body = join($sep, grep {length} @exprs); + my $subs = ""; + if (defined $root && defined $limit_seq && !$self->{'in_format'}) { + $subs = join "\n", $self->seq_subs($limit_seq); + } + return join($sep, grep {length} $body, $subs); +} + +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + + local(@$self{qw'curstash warnings hints hinthash'}) + = @$self{qw'curstash warnings hints hinthash'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = $self->keyword("while"); + } elsif ($name eq "or") { + $name = $self->keyword("until"); + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " " + . $self->keyword("while") . " 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; + } + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; + } + if ($cx > 0) { # inside an expression, (a do {} while for lineseq) + my $body = $self->lineseq($op, 0, @kids); + return is_lexical_subs(@kids) + ? $body + : ($self->lex_in_scope("&do") ? "CORE::do" : "do") + . " {\n\t$body\n\b}"; + } else { + my $lineseq = $self->lineseq($op, $cx, @kids); + return (length ($lineseq) ? "$lineseq;" : ""); + } +} + +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } + +# This is a special case of scopeop and lineseq, for the case of the +# main_root. The difference is that we print the output statements as +# soon as we get them, for the sake of impatient users. +sub deparse_root { + my $self = shift; + my($op) = @_; + local(@$self{qw'curstash warnings hints hinthash'}) + = @$self{qw'curstash warnings hints hinthash'}; + my @kids; + return if null $op->first; # Can happen, e.g., for Bytecode without -k + for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; + } + $self->walk_lineseq($op, \@kids, + sub { return unless length $_[0]; + print $self->indent($_[0].';'); + print "\n" + unless $_[1] == $#kids; + }); +} + +sub walk_lineseq { + my ($self, $op, $kids, $callback) = @_; + my @kids = @$kids; + for (my $i = 0; $i < @kids; $i++) { + my $expr = ""; + if (is_state $kids[$i]) { + $expr = $self->deparse($kids[$i++], 0); + if ($i > $#kids) { + $callback->($expr, $i); + last; + } + } + if (is_for_loop($kids[$i])) { + $callback->($expr . $self->for_loop($kids[$i], 0), + $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1); + next; + } + my $expr2 = $self->deparse($kids[$i], (@kids != 1)/2); + $expr2 =~ s/^sub :(?!:)/+sub :/; # statement label otherwise + $expr .= $expr2; + $callback->($expr, $i); + } +} + +# The BEGIN {} is used here because otherwise this code isn't executed +# when you run B::Deparse on itself. +my %globalnames; +BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", + "ENV", "ARGV", "ARGVOUT", "_"); } + +sub gv_name { + my $self = shift; + my $gv = shift; + my $raw = shift; +#Carp::confess() unless ref($gv) eq "B::GV"; + my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; + my $stash = ($cv || $gv)->STASH->NAME; + my $name = $raw + ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME + : $cv + ? B::safename($cv->NAME_HEK || $cv->GV->NAME) + : $gv->SAFENAME; + if ($stash eq 'main' && $name =~ /^::/) { + $stash = '::'; + } + elsif (($stash eq 'main' + && ($globalnames{$name} || $name =~ /^[^A-Za-z_:]/)) + or ($stash eq $self->{'curstash'} && !$globalnames{$name} + && ($stash eq 'main' || $name !~ /::/)) + ) + { + $stash = ""; + } else { + $stash = $stash . "::"; + } + if (!$raw and $name =~ /^(\^..|{)/) { + $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ + } + return $stash . $name; +} + +# Return the name to use for a stash variable. +# If a lexical with the same name is in scope, or +# if strictures are enabled, it may need to be +# fully-qualified. +sub stash_variable { + my ($self, $prefix, $name, $cx) = @_; + + return $prefix.$self->maybe_qualify($prefix, $name) if $name =~ /::/; + + unless ($prefix eq '$' || $prefix eq '@' || $prefix eq '&' || #' + $prefix eq '%' || $prefix eq '$#') { + return "$prefix$name"; + } + + if ($name =~ /^[^[:alpha:]_+-]$/) { + if (defined $cx && $cx == 26) { + if ($prefix eq '@') { + return "$prefix\{$name}"; + } + elsif ($name eq '#') { return '${#}' } # "${#}a" vs "$#a" + } + if ($prefix eq '$#') { + return "\$#{$name}"; + } + } + + return $prefix . $self->maybe_qualify($prefix, $name); +} + +my %unctrl = # portable to EBCDIC + ( + "\c@" => '@', # unused + "\cA" => 'A', + "\cB" => 'B', + "\cC" => 'C', + "\cD" => 'D', + "\cE" => 'E', + "\cF" => 'F', + "\cG" => 'G', + "\cH" => 'H', + "\cI" => 'I', + "\cJ" => 'J', + "\cK" => 'K', + "\cL" => 'L', + "\cM" => 'M', + "\cN" => 'N', + "\cO" => 'O', + "\cP" => 'P', + "\cQ" => 'Q', + "\cR" => 'R', + "\cS" => 'S', + "\cT" => 'T', + "\cU" => 'U', + "\cV" => 'V', + "\cW" => 'W', + "\cX" => 'X', + "\cY" => 'Y', + "\cZ" => 'Z', + "\c[" => '[', # unused + "\c\\" => '\\', # unused + "\c]" => ']', # unused + "\c_" => '_', # unused + ); + +# Return just the name, without the prefix. It may be returned as a quoted +# string. The second return value is a boolean indicating that. +sub stash_variable_name { + my($self, $prefix, $gv) = @_; + my $name = $self->gv_name($gv, 1); + $name = $self->maybe_qualify($prefix,$name); + if ($name =~ /^(?:\S|(?!\d)[\ca-\cz]?(?:\w|::)*|\d+)\z/) { + $name =~ s/^([\ca-\cz])/'^' . $unctrl{$1}/e; + $name =~ /^(\^..|{)/ and $name = "{$name}"; + return $name, 0; # not quoted + } + else { + single_delim("q", "'", $name, $self), 1; + } +} + +sub maybe_qualify { + my ($self,$prefix,$name) = @_; + my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; + if ($prefix eq "") { + $name .= "::" if $name =~ /(?:\ACORE::[^:]*|::)\z/; + return $name; + } + return $name if $name =~ /::/; + return $self->{'curstash'}.'::'. $name + if + $name =~ /^(?!\d)\w/ # alphabetic + && $v !~ /^\$[ab]\z/ # not $a or $b + && $v =~ /\A[\$\@\%\&]/ # scalar, array, hash, or sub + && !$globalnames{$name} # not a global name + && $self->{hints} & $strict_bits{vars} # strict vars + && !$self->lex_in_scope($v,1) # no "our" + or $self->lex_in_scope($v); # conflicts with "my" variable + return $name; +} + +sub lex_in_scope { + my ($self, $name, $our) = @_; + substr $name, 0, 0, = $our ? 'o' : 'm'; # our/my + $self->populate_curcvlex() if !defined $self->{'curcvlex'}; + + return 0 if !defined($self->{'curcop'}); + my $seq = $self->{'curcop'}->cop_seq; + return 0 if !exists $self->{'curcvlex'}{$name}; + for my $a (@{$self->{'curcvlex'}{$name}}) { + my ($st, $en) = @$a; + return 1 if $seq > $st && $seq <= $en; + } + return 0; +} + +sub populate_curcvlex { + my $self = shift; + for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { + my $padlist = $cv->PADLIST; + # an undef CV still in lexical chain + next if class($padlist) eq "SPECIAL"; + my @padlist = $padlist->ARRAY; + my @ns = $padlist[0]->ARRAY; + + for (my $i=0; $i<@ns; ++$i) { + next if class($ns[$i]) eq "SPECIAL"; + if (class($ns[$i]) eq "PV") { + # Probably that pesky lexical @_ + next; + } + my $name = $ns[$i]->PVX; + next unless defined $name; + my ($seq_st, $seq_en) = + ($ns[$i]->FLAGS & SVf_FAKE) + ? (0, 999999) + : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH); + + push @{$self->{'curcvlex'}{ + ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name + }}, [$seq_st, $seq_en, $ns[$i]]; + } + } +} + +sub find_scope_st { ((find_scope(@_))[0]); } +sub find_scope_en { ((find_scope(@_))[1]); } + +# Recurses down the tree, looking for pad variable introductions and COPs +sub find_scope { + my ($self, $op, $scope_st, $scope_en) = @_; + carp("Undefined op in find_scope") if !defined $op; + return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; + + my @queue = ($op); + while(my $op = shift @queue ) { + for (my $o=$op->first; $$o; $o=$o->sibling) { + if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { + my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW); + my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH; + $scope_st = $s if !defined($scope_st) || $s < $scope_st; + $scope_en = $e if !defined($scope_en) || $e > $scope_en; + return ($scope_st, $scope_en); + } + elsif (is_state($o)) { + my $c = $o->cop_seq; + $scope_st = $c if !defined($scope_st) || $c < $scope_st; + $scope_en = $c if !defined($scope_en) || $c > $scope_en; + return ($scope_st, $scope_en); + } + elsif ($o->flags & OPf_KIDS) { + unshift (@queue, $o); + } + } + } + + return ($scope_st, $scope_en); +} + +# Returns a list of subs which should be inserted before the COP +sub cop_subs { + my ($self, $op, $out_seq) = @_; + my $seq = $op->cop_seq; + $seq = $out_seq if defined($out_seq) && $out_seq < $seq; + return $self->seq_subs($seq); +} + +sub seq_subs { + my ($self, $seq) = @_; + my @text; +#push @text, "# ($seq)\n"; + + return "" if !defined $seq; + my @pending; + while (scalar(@{$self->{'subs_todo'}}) + and $seq > $self->{'subs_todo'}[0][0]) { + my $cv = $self->{'subs_todo'}[0][1]; + # Skip the OUTSIDE check for lexical subs. We may be deparsing a + # cloned anon sub with lexical subs declared in it, in which case + # the OUTSIDE pointer points to the anon protosub. + my $lexical = ref $self->{'subs_todo'}[0][3]; + my $outside = !$lexical && $cv && $cv->OUTSIDE; + if (!$lexical and $cv + and ${$cv->OUTSIDE || \0} != ${$self->{'curcv'}}) + { + push @pending, shift @{$self->{'subs_todo'}}; + next; + } + push @text, $self->next_todo; + } + unshift @{$self->{'subs_todo'}}, @pending; + return @text; +} + +sub _features_from_bundle { + my ($hints, $hh) = @_; + foreach (@{$feature::feature_bundle{@feature::hint_bundles[$hints >> $feature::hint_shift]}}) { + $hh->{$feature::feature{$_}} = 1; + } + return $hh; +} + +# generate any pragmas, 'package foo' etc needed to synchronise +# with the given cop + +sub pragmata { + my $self = shift; + my($op) = @_; + + my @text; + + my $stash = $op->stashpv; + if ($stash ne $self->{'curstash'}) { + push @text, $self->keyword("package") . " $stash;\n"; + $self->{'curstash'} = $stash; + } + + if (OPpCONST_ARYBASE && $self->{'arybase'} != $op->arybase) { + push @text, '$[ = '. $op->arybase .";\n"; + $self->{'arybase'} = $op->arybase; + } + + my $warnings = $op->warnings; + my $warning_bits; + if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { + $warning_bits = $warnings::Bits{"all"} & WARN_MASK; + } + elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { + $warning_bits = $warnings::NONE; + } + elsif ($warnings->isa("B::SPECIAL")) { + $warning_bits = undef; + } + else { + $warning_bits = $warnings->PV & WARN_MASK; + } + + if (defined ($warning_bits) and + !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { + push @text, + $self->declare_warnings($self->{'warnings'}, $warning_bits); + $self->{'warnings'} = $warning_bits; + } + + my $hints = $op->hints; + my $old_hints = $self->{'hints'}; + if ($self->{'hints'} != $hints) { + push @text, $self->declare_hints($self->{'hints'}, $hints); + $self->{'hints'} = $hints; + } + + my $newhh; + $newhh = $op->hints_hash->HASH; + + { + # feature bundle hints + my $from = $old_hints & $feature::hint_mask; + my $to = $ hints & $feature::hint_mask; + if ($from != $to) { + if ($to == $feature::hint_mask) { + if ($self->{'hinthash'}) { + delete $self->{'hinthash'}{$_} + for grep /^feature_/, keys %{$self->{'hinthash'}}; + } + else { $self->{'hinthash'} = {} } + $self->{'hinthash'} + = _features_from_bundle($from, $self->{'hinthash'}); + } + else { + my $bundle = + $feature::hint_bundles[$to >> $feature::hint_shift]; + $bundle =~ s/(\d[13579])\z/$1+1/e; # 5.11 => 5.12 + push @text, + $self->keyword("no") . " feature ':all';\n", + $self->keyword("use") . " feature ':$bundle';\n"; + } + } + } + + { + push @text, $self->declare_hinthash( + $self->{'hinthash'}, $newhh, + $self->{indent_size}, $self->{hints}, + ); + $self->{'hinthash'} = $newhh; + } + + return join("", @text); +} + + +# Notice how subs and formats are inserted between statements here; +# also $[ assignments and pragmas. +sub pp_nextstate { + my $self = shift; + my($op, $cx) = @_; + $self->{'curcop'} = $op; + + my @text; + + my @subs = $self->cop_subs($op); + if (@subs) { + # Special marker to swallow up the semicolon + push @subs, "\cK"; + } + push @text, @subs; + + push @text, $self->pragmata($op); + + + # This should go after of any branches that add statements, to + # increase the chances that it refers to the same line it did in + # the original program. + if ($self->{'linenums'} && $cx != .5) { # $cx == .5 means in a format + push @text, "\f#line " . $op->line . + ' "' . $op->file, qq'"\n'; + } + + push @text, $op->label . ": " if $op->label; + + return join("", @text); +} + +sub declare_warnings { + my ($self, $from, $to) = @_; + $from //= ''; + my $all = (warnings::bits("all") & WARN_MASK); + unless ((($from & WARN_MASK) & ~$all) =~ /[^\0]/) { + # no FATAL bits need turning off + if ( ($to & WARN_MASK) eq $all) { + return $self->keyword("use") . " warnings;\n"; + } + elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { + return $self->keyword("no") . " warnings;\n"; + } + } + + return "BEGIN {\${^WARNING_BITS} = \"" + . join("", map { sprintf("\\x%02x", ord $_) } split "", $to) + . "\"}\n\cK"; +} + +sub declare_hints { + my ($self, $from, $to) = @_; + my $use = $to & ~$from; + my $no = $from & ~$to; + my $decls = ""; + for my $pragma (hint_pragmas($use)) { + $decls .= $self->keyword("use") . " $pragma;\n"; + } + for my $pragma (hint_pragmas($no)) { + $decls .= $self->keyword("no") . " $pragma;\n"; + } + return $decls; +} + +# Internal implementation hints that the core sets automatically, so don't need +# (or want) to be passed back to the user +my %ignored_hints = ( + 'open<' => 1, + 'open>' => 1, + ':' => 1, + 'strict/refs' => 1, + 'strict/subs' => 1, + 'strict/vars' => 1, +); + +my %rev_feature; + +sub declare_hinthash { + my ($self, $from, $to, $indent, $hints) = @_; + my $doing_features = + ($hints & $feature::hint_mask) == $feature::hint_mask; + my @decls; + my @features; + my @unfeatures; # bugs? + for my $key (sort keys %$to) { + next if $ignored_hints{$key}; + my $is_feature = $key =~ /^feature_/; + next if $is_feature and not $doing_features; + if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) { + push(@features, $key), next if $is_feature; + push @decls, + qq(\$^H{) . single_delim("q", "'", $key, $self) . qq(} = ) + . ( + defined $to->{$key} + ? single_delim("q", "'", $to->{$key}, $self) + : 'undef' + ) + . qq(;); + } + } + for my $key (sort keys %$from) { + next if $ignored_hints{$key}; + my $is_feature = $key =~ /^feature_/; + next if $is_feature and not $doing_features; + if (!exists $to->{$key}) { + push(@unfeatures, $key), next if $is_feature; + push @decls, qq(delete \$^H{'$key'};); + } + } + my @ret; + if (@features || @unfeatures) { + if (!%rev_feature) { %rev_feature = reverse %feature::feature } + } + if (@features) { + push @ret, $self->keyword("use") . " feature " + . join(", ", map "'$rev_feature{$_}'", @features) . ";\n"; + } + if (@unfeatures) { + push @ret, $self->keyword("no") . " feature " + . join(", ", map "'$rev_feature{$_}'", @unfeatures) + . ";\n"; + } + @decls and + push @ret, + join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n\cK"; + return @ret; +} + +sub hint_pragmas { + my ($bits) = @_; + my (@pragmas, @strict); + push @pragmas, "integer" if $bits & 0x1; + for (sort keys %strict_bits) { + push @strict, "'$_'" if $bits & $strict_bits{$_}; + } + if (@strict == keys %strict_bits) { + push @pragmas, "strict"; + } + elsif (@strict) { + push @pragmas, "strict " . join ', ', @strict; + } + push @pragmas, "bytes" if $bits & 0x8; + return @pragmas; +} + +sub pp_dbstate { pp_nextstate(@_) } +sub pp_setstate { pp_nextstate(@_) } + +sub pp_unstack { return "" } # see also leaveloop + +my %feature_keywords = ( + # keyword => 'feature', + state => 'state', + say => 'say', + given => 'switch', + when => 'switch', + default => 'switch', + break => 'switch', + evalbytes=>'evalbytes', + __SUB__ => '__SUB__', + fc => 'fc', +); + +# keywords that are strong and also have a prototype +# +my %strong_proto_keywords = map { $_ => 1 } qw( + pos + prototype + scalar + study + undef +); + +sub feature_enabled { + my($self,$name) = @_; + my $hh; + my $hints = $self->{hints} & $feature::hint_mask; + if ($hints && $hints != $feature::hint_mask) { + $hh = _features_from_bundle($hints); + } + elsif ($hints) { $hh = $self->{'hinthash'} } + return $hh && $hh->{"feature_$feature_keywords{$name}"} +} + +sub keyword { + my $self = shift; + my $name = shift; + return $name if $name =~ /^CORE::/; # just in case + if (exists $feature_keywords{$name}) { + return "CORE::$name" if not $self->feature_enabled($name); + } + # This sub may be called for a program that has no nextstate ops. In + # that case we may have a lexical sub named no/use/sub in scope but + # but $self->lex_in_scope will return false because it depends on the + # current nextstate op. So we need this alternate method if there is + # no current cop. + if (!$self->{'curcop'}) { + $self->populate_curcvlex() if !defined $self->{'curcvlex'}; + return "CORE::$name" if exists $self->{'curcvlex'}{"m&$name"} + || exists $self->{'curcvlex'}{"o&$name"}; + } elsif ($self->lex_in_scope("&$name") + || $self->lex_in_scope("&$name", 1)) { + return "CORE::$name"; + } + if ($strong_proto_keywords{$name} + || ($name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/ + && !defined eval{prototype "CORE::$name"}) + ) { return $name } + if ( + exists $self->{subs_declared}{$name} + or + exists &{"$self->{curstash}::$name"} + ) { + return "CORE::$name" + } + return $name; +} + +sub baseop { + my $self = shift; + my($op, $cx, $name) = @_; + return $self->keyword($name); +} + +sub pp_stub { "()" } +sub pp_wantarray { baseop(@_, "wantarray") } +sub pp_fork { baseop(@_, "fork") } +sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } +sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } +sub pp_time { maybe_targmy(@_, \&baseop, "time") } +sub pp_tms { baseop(@_, "times") } +sub pp_ghostent { baseop(@_, "gethostent") } +sub pp_gnetent { baseop(@_, "getnetent") } +sub pp_gprotoent { baseop(@_, "getprotoent") } +sub pp_gservent { baseop(@_, "getservent") } +sub pp_ehostent { baseop(@_, "endhostent") } +sub pp_enetent { baseop(@_, "endnetent") } +sub pp_eprotoent { baseop(@_, "endprotoent") } +sub pp_eservent { baseop(@_, "endservent") } +sub pp_gpwent { baseop(@_, "getpwent") } +sub pp_spwent { baseop(@_, "setpwent") } +sub pp_epwent { baseop(@_, "endpwent") } +sub pp_ggrent { baseop(@_, "getgrent") } +sub pp_sgrent { baseop(@_, "setgrent") } +sub pp_egrent { baseop(@_, "endgrent") } +sub pp_getlogin { baseop(@_, "getlogin") } + +sub POSTFIX () { 1 } + +# I couldn't think of a good short name, but this is the category of +# symbolic unary operators with interesting precedence + +sub pfixop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0); + my $kid = $op->first; + $kid = $self->deparse($kid, $prec); + return $self->maybe_parens(($flags & POSTFIX) + ? "$kid$name" + # avoid confusion with filetests + : $name eq '-' + && $kid =~ /^[a-zA-Z](?!\w)/ + ? "$name($kid)" + : "$name$kid", + $cx, $prec); +} + +sub pp_preinc { pfixop(@_, "++", 23) } +sub pp_predec { pfixop(@_, "--", 23) } +sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_i_preinc { pfixop(@_, "++", 23) } +sub pp_i_predec { pfixop(@_, "--", 23) } +sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } +*pp_ncomplement = *pp_complement; +sub pp_scomplement { maybe_targmy(@_, \&pfixop, "~.", 21) } + +sub pp_negate { maybe_targmy(@_, \&real_negate) } +sub real_negate { + my $self = shift; + my($op, $cx) = @_; + if ($op->first->name =~ /^(i_)?negate$/) { + # avoid --$x + $self->pfixop($op, $cx, "-", 21.5); + } else { + $self->pfixop($op, $cx, "-", 21); + } +} +sub pp_i_negate { pp_negate(@_) } + +sub pp_not { + my $self = shift; + my($op, $cx) = @_; + if ($cx <= 4) { + $self->listop($op, $cx, "not", $op->first); + } else { + $self->pfixop($op, $cx, "!", 21); + } +} + +sub unop { + my $self = shift; + my($op, $cx, $name, $nollafr) = @_; + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + if (not $name) { + # this deals with 'boolkeys' right now + return $self->deparse($kid,$cx); + } + my $builtinname = $name; + $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name"; + if (defined prototype($builtinname) + && $builtinname ne 'CORE::readline' + && prototype($builtinname) =~ /^;?\*/ + && $kid->name eq "rv2gv") { + $kid = $kid->first; + } + + if ($nollafr) { + if (($kid = $self->deparse($kid, 16)) !~ s/^\cS//) { + # require foo() is a syntax error. + $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; + } + return $self->maybe_parens( + $self->keyword($name) . " $kid", $cx, 16 + ); + } + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $self->maybe_parens( + $self->keyword($name) . ($op->flags & OPf_SPECIAL ? "()" : ""), + $cx, 16, + ); + } +} + +sub pp_chop { maybe_targmy(@_, \&unop, "chop") } +sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_schop { maybe_targmy(@_, \&unop, "chop") } +sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_defined { unop(@_, "defined") } +sub pp_undef { unop(@_, "undef") } +sub pp_study { unop(@_, "study") } +sub pp_ref { unop(@_, "ref") } +sub pp_pos { maybe_local(@_, unop(@_, "pos")) } + +sub pp_sin { maybe_targmy(@_, \&unop, "sin") } +sub pp_cos { maybe_targmy(@_, \&unop, "cos") } +sub pp_rand { maybe_targmy(@_, \&unop, "rand") } +sub pp_srand { unop(@_, "srand") } +sub pp_exp { maybe_targmy(@_, \&unop, "exp") } +sub pp_log { maybe_targmy(@_, \&unop, "log") } +sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } +sub pp_int { maybe_targmy(@_, \&unop, "int") } +sub pp_hex { maybe_targmy(@_, \&unop, "hex") } +sub pp_oct { maybe_targmy(@_, \&unop, "oct") } +sub pp_abs { maybe_targmy(@_, \&unop, "abs") } + +sub pp_length { maybe_targmy(@_, \&unop, "length") } +sub pp_ord { maybe_targmy(@_, \&unop, "ord") } +sub pp_chr { maybe_targmy(@_, \&unop, "chr") } + +sub pp_each { unop(@_, "each") } +sub pp_values { unop(@_, "values") } +sub pp_keys { unop(@_, "keys") } +{ no strict 'refs'; *{"pp_r$_"} = *{"pp_$_"} for qw< keys each values >; } +sub pp_boolkeys { + # no name because its an optimisation op that has no keyword + unop(@_,""); +} +sub pp_aeach { unop(@_, "each") } +sub pp_avalues { unop(@_, "values") } +sub pp_akeys { unop(@_, "keys") } +sub pp_pop { unop(@_, "pop") } +sub pp_shift { unop(@_, "shift") } + +sub pp_caller { unop(@_, "caller") } +sub pp_reset { unop(@_, "reset") } +sub pp_exit { unop(@_, "exit") } +sub pp_prototype { unop(@_, "prototype") } + +sub pp_close { unop(@_, "close") } +sub pp_fileno { unop(@_, "fileno") } +sub pp_umask { unop(@_, "umask") } +sub pp_untie { unop(@_, "untie") } +sub pp_tied { unop(@_, "tied") } +sub pp_dbmclose { unop(@_, "dbmclose") } +sub pp_getc { unop(@_, "getc") } +sub pp_eof { unop(@_, "eof") } +sub pp_tell { unop(@_, "tell") } +sub pp_getsockname { unop(@_, "getsockname") } +sub pp_getpeername { unop(@_, "getpeername") } + +sub pp_chdir { + my ($self, $op, $cx) = @_; + if (($op->flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS)) { + my $kw = $self->keyword("chdir"); + my $kid = $self->const_sv($op->first)->PV; + my $code = $kw + . ($cx >= 16 || $self->{'parens'} ? "($kid)" : " $kid"); + maybe_targmy(@_, sub { $_[3] }, $code); + } else { + maybe_targmy(@_, \&unop, "chdir") + } +} + +sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } +sub pp_readlink { unop(@_, "readlink") } +sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } +sub pp_readdir { unop(@_, "readdir") } +sub pp_telldir { unop(@_, "telldir") } +sub pp_rewinddir { unop(@_, "rewinddir") } +sub pp_closedir { unop(@_, "closedir") } +sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } +sub pp_localtime { unop(@_, "localtime") } +sub pp_gmtime { unop(@_, "gmtime") } +sub pp_alarm { unop(@_, "alarm") } +sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } + +sub pp_dofile { + my $code = unop(@_, "do", 1); # llafr does not apply + if ($code =~ s/^((?:CORE::)?do) \{/$1({/) { $code .= ')' } + $code; +} +sub pp_entereval { + unop( + @_, + $_[1]->private & OPpEVAL_BYTES ? 'evalbytes' : "eval" + ) +} + +sub pp_ghbyname { unop(@_, "gethostbyname") } +sub pp_gnbyname { unop(@_, "getnetbyname") } +sub pp_gpbyname { unop(@_, "getprotobyname") } +sub pp_shostent { unop(@_, "sethostent") } +sub pp_snetent { unop(@_, "setnetent") } +sub pp_sprotoent { unop(@_, "setprotoent") } +sub pp_sservent { unop(@_, "setservent") } +sub pp_gpwnam { unop(@_, "getpwnam") } +sub pp_gpwuid { unop(@_, "getpwuid") } +sub pp_ggrnam { unop(@_, "getgrnam") } +sub pp_ggrgid { unop(@_, "getgrgid") } + +sub pp_lock { unop(@_, "lock") } + +sub pp_continue { unop(@_, "continue"); } +sub pp_break { unop(@_, "break"); } + +sub givwhen { + my $self = shift; + my($op, $cx, $givwhen) = @_; + + my $enterop = $op->first; + my ($head, $block); + if ($enterop->flags & OPf_SPECIAL) { + $head = $self->keyword("default"); + $block = $self->deparse($enterop->first, 0); + } + else { + my $cond = $enterop->first; + my $cond_str = $self->deparse($cond, 1); + $head = "$givwhen ($cond_str)"; + $block = $self->deparse($cond->sibling, 0); + } + + return "$head {\n". + "\t$block\n". + "\b}\cK"; +} + +sub pp_leavegiven { givwhen(@_, $_[0]->keyword("given")); } +sub pp_leavewhen { givwhen(@_, $_[0]->keyword("when")); } + +sub pp_exists { + my $self = shift; + my($op, $cx) = @_; + my $arg; + my $name = $self->keyword("exists"); + if ($op->private & OPpEXISTS_SUB) { + # Checking for the existence of a subroutine + return $self->maybe_parens_func($name, + $self->pp_rv2cv($op->first, 16), $cx, 16); + } + if ($op->flags & OPf_SPECIAL) { + # Array element, not hash element + return $self->maybe_parens_func($name, + $self->pp_aelem($op->first, 16), $cx, 16); + } + return $self->maybe_parens_func($name, $self->pp_helem($op->first, 16), + $cx, 16); +} + +sub pp_delete { + my $self = shift; + my($op, $cx) = @_; + my $arg; + my $name = $self->keyword("delete"); + if ($op->private & (OPpSLICE|OPpKVSLICE)) { + if ($op->flags & OPf_SPECIAL) { + # Deleting from an array, not a hash + return $self->maybe_parens_func($name, + $self->pp_aslice($op->first, 16), + $cx, 16); + } + return $self->maybe_parens_func($name, + $self->pp_hslice($op->first, 16), + $cx, 16); + } else { + if ($op->flags & OPf_SPECIAL) { + # Deleting from an array, not a hash + return $self->maybe_parens_func($name, + $self->pp_aelem($op->first, 16), + $cx, 16); + } + return $self->maybe_parens_func($name, + $self->pp_helem($op->first, 16), + $cx, 16); + } +} + +sub pp_require { + my $self = shift; + my($op, $cx) = @_; + my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; + my $kid = $op->first; + if ($kid->name eq 'const') { + my $priv = $kid->private; + my $sv = $self->const_sv($kid); + my $arg; + if ($priv & OPpCONST_BARE) { + $arg = $sv->PV; + $arg =~ s[/][::]g; + $arg =~ s/\.pm//g; + } elsif ($priv & OPpCONST_NOVER) { + $opname = $self->keyword('no'); + $arg = $self->const($sv, 16); + } elsif ((my $tmp = $self->const($sv, 16)) =~ /^v/) { + $arg = $tmp; + } + if ($arg) { + return $self->maybe_parens("$opname $arg", $cx, 16); + } + } + $self->unop( + $op, $cx, + $opname, + 1, # llafr does not apply + ); +} + +sub pp_scalar { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if (not null $kid->sibling) { + # XXX Was a here-doc + return $self->dquote($op); + } + $self->unop(@_, "scalar"); +} + + +sub padval { + my $self = shift; + my $targ = shift; + return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); +} + +sub anon_hash_or_list { + my $self = shift; + my($op, $cx) = @_; + + my($pre, $post) = @{{"anonlist" => ["[","]"], + "anonhash" => ["{","}"]}->{$op->name}}; + my($expr, @exprs); + $op = $op->first->sibling; # skip pushmark + for (; !null($op); $op = $op->sibling) { + $expr = $self->deparse($op, 6); + push @exprs, $expr; + } + if ($pre eq "{" and $cx < 1) { + # Disambiguate that it's not a block + $pre = "+{"; + } + return $pre . join(", ", @exprs) . $post; +} + +sub pp_anonlist { + my $self = shift; + my ($op, $cx) = @_; + if ($op->flags & OPf_SPECIAL) { + return $self->anon_hash_or_list($op, $cx); + } + warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL"; + return 'XXX'; +} + +*pp_anonhash = \&pp_anonlist; + +sub pp_refgen { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->name eq "null") { + my $anoncode = $kid = $kid->first; + if ($anoncode->name eq "anonconst") { + $anoncode = $anoncode->first->first->sibling; + } + if ($anoncode->name eq "anoncode" + or !null($anoncode = $kid->sibling) and + $anoncode->name eq "anoncode") { + return $self->e_anoncode({ code => $self->padval($anoncode->targ) }); + } elsif ($kid->name eq "pushmark") { + my $sib_name = $kid->sibling->name; + if ($sib_name eq 'entersub') { + my $text = $self->deparse($kid->sibling, 1); + # Always show parens for \(&func()), but only with -p otherwise + $text = "($text)" if $self->{'parens'} + or $kid->sibling->private & OPpENTERSUB_AMPER; + return "\\$text"; + } + } + } + local $self->{'in_refgen'} = 1; + $self->pfixop($op, $cx, "\\", 20); +} + +sub e_anoncode { + my ($self, $info) = @_; + my $text = $self->deparse_sub($info->{code}); + return $self->keyword("sub") . " $text"; +} + +sub pp_srefgen { pp_refgen(@_) } + +sub pp_readline { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if (is_scalar($kid) + and $op->flags & OPf_SPECIAL + and $self->deparse($kid, 1) eq 'ARGV') + { + return '<<>>'; + } + return $self->unop($op, $cx, "readline"); +} + +sub pp_rcatline { + my $self = shift; + my($op) = @_; + return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; +} + +# Unary operators that can occur as pseudo-listops inside double quotes +sub dq_unop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + # If there's more than one kid, the first is an ex-pushmark. + $kid = $kid->sibling if not null $kid->sibling; + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_ucfirst { dq_unop(@_, "ucfirst") } +sub pp_lcfirst { dq_unop(@_, "lcfirst") } +sub pp_uc { dq_unop(@_, "uc") } +sub pp_lc { dq_unop(@_, "lc") } +sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } +sub pp_fc { dq_unop(@_, "fc") } + +sub loopex { + my $self = shift; + my ($op, $cx, $name) = @_; + if (class($op) eq "PVOP") { + $name .= " " . $op->pv; + } elsif (class($op) eq "OP") { + # no-op + } elsif (class($op) eq "UNOP") { + (my $kid = $self->deparse($op->first, 7)) =~ s/^\cS//; + # last foo() is a syntax error. + $kid =~ /^(?!\d)\w/ and $kid = "($kid)"; + $name .= " $kid"; + } + return $self->maybe_parens($name, $cx, 7); +} + +sub pp_last { loopex(@_, "last") } +sub pp_next { loopex(@_, "next") } +sub pp_redo { loopex(@_, "redo") } +sub pp_goto { loopex(@_, "goto") } +sub pp_dump { loopex(@_, "CORE::dump") } + +sub ftst { + my $self = shift; + my($op, $cx, $name) = @_; + if (class($op) eq "UNOP") { + # Genuine '-X' filetests are exempt from the LLAFR, but not + # l?stat() + if ($name =~ /^-/) { + (my $kid = $self->deparse($op->first, 16)) =~ s/^\cS//; + return $self->maybe_parens("$name $kid", $cx, 16); + } + return $self->maybe_parens_unop($name, $op->first, $cx); + } elsif (class($op) =~ /^(SV|PAD)OP$/) { + return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); + } else { # I don't think baseop filetests ever survive ck_ftst, but... + return $name; + } +} + +sub pp_lstat { ftst(@_, "lstat") } +sub pp_stat { ftst(@_, "stat") } +sub pp_ftrread { ftst(@_, "-R") } +sub pp_ftrwrite { ftst(@_, "-W") } +sub pp_ftrexec { ftst(@_, "-X") } +sub pp_fteread { ftst(@_, "-r") } +sub pp_ftewrite { ftst(@_, "-w") } +sub pp_fteexec { ftst(@_, "-x") } +sub pp_ftis { ftst(@_, "-e") } +sub pp_fteowned { ftst(@_, "-O") } +sub pp_ftrowned { ftst(@_, "-o") } +sub pp_ftzero { ftst(@_, "-z") } +sub pp_ftsize { ftst(@_, "-s") } +sub pp_ftmtime { ftst(@_, "-M") } +sub pp_ftatime { ftst(@_, "-A") } +sub pp_ftctime { ftst(@_, "-C") } +sub pp_ftsock { ftst(@_, "-S") } +sub pp_ftchr { ftst(@_, "-c") } +sub pp_ftblk { ftst(@_, "-b") } +sub pp_ftfile { ftst(@_, "-f") } +sub pp_ftdir { ftst(@_, "-d") } +sub pp_ftpipe { ftst(@_, "-p") } +sub pp_ftlink { ftst(@_, "-l") } +sub pp_ftsuid { ftst(@_, "-u") } +sub pp_ftsgid { ftst(@_, "-g") } +sub pp_ftsvtx { ftst(@_, "-k") } +sub pp_fttty { ftst(@_, "-t") } +sub pp_fttext { ftst(@_, "-T") } +sub pp_ftbinary { ftst(@_, "-B") } + +sub SWAP_CHILDREN () { 1 } +sub ASSIGN () { 2 } # has OP= variant +sub LIST_CONTEXT () { 4 } # Assignment is in list context + +my(%left, %right); + +sub assoc_class { + my $op = shift; + my $name = $op->name; + if ($name eq "concat" and $op->first->name eq "concat") { + # avoid spurious '=' -- see comment in pp_concat + return "concat"; + } + if ($name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|x?or)$/ + and null $op->first->sibling) + { + # Like all conditional constructs, OP_ANDs and OP_ORs are topped + # with a null that's used as the common end point of the two + # flows of control. For precedence purposes, ignore it. + # (COND_EXPRs have these too, but we don't bother with + # their associativity). + return assoc_class($op->first); + } + return $name . ($op->flags & OPf_STACKED ? "=" : ""); +} + +# Left associative operators, like '+', for which +# $a + $b + $c is equivalent to ($a + $b) + $c + +BEGIN { + %left = ('multiply' => 19, 'i_multiply' => 19, + 'divide' => 19, 'i_divide' => 19, + 'modulo' => 19, 'i_modulo' => 19, + 'repeat' => 19, + 'add' => 18, 'i_add' => 18, + 'subtract' => 18, 'i_subtract' => 18, + 'concat' => 18, + 'left_shift' => 17, 'right_shift' => 17, + 'bit_and' => 13, 'nbit_and' => 13, 'sbit_and' => 13, + 'bit_or' => 12, 'bit_xor' => 12, + 'sbit_or' => 12, 'sbit_xor' => 12, + 'nbit_or' => 12, 'nbit_xor' => 12, + 'and' => 3, + 'or' => 2, 'xor' => 2, + ); +} + +sub deparse_binop_left { + my $self = shift; + my($op, $left, $prec) = @_; + if ($left{assoc_class($op)} && $left{assoc_class($left)} + and $left{assoc_class($op)} == $left{assoc_class($left)}) + { + return $self->deparse($left, $prec - .00001); + } else { + return $self->deparse($left, $prec); + } +} + +# Right associative operators, like '=', for which +# $a = $b = $c is equivalent to $a = ($b = $c) + +BEGIN { + %right = ('pow' => 22, + 'sassign=' => 7, 'aassign=' => 7, + 'multiply=' => 7, 'i_multiply=' => 7, + 'divide=' => 7, 'i_divide=' => 7, + 'modulo=' => 7, 'i_modulo=' => 7, + 'repeat=' => 7, 'refassign' => 7, 'refassign=' => 7, + 'add=' => 7, 'i_add=' => 7, + 'subtract=' => 7, 'i_subtract=' => 7, + 'concat=' => 7, + 'left_shift=' => 7, 'right_shift=' => 7, + 'bit_and=' => 7, 'sbit_and=' => 7, 'nbit_and=' => 7, + 'nbit_or=' => 7, 'nbit_xor=' => 7, + 'sbit_or=' => 7, 'sbit_xor=' => 7, + 'andassign' => 7, + 'orassign' => 7, + ); +} + +sub deparse_binop_right { + my $self = shift; + my($op, $right, $prec) = @_; + if ($right{assoc_class($op)} && $right{assoc_class($right)} + and $right{assoc_class($op)} == $right{assoc_class($right)}) + { + return $self->deparse($right, $prec - .00001); + } else { + return $self->deparse($right, $prec); + } +} + +sub binop { + my $self = shift; + my ($op, $cx, $opname, $prec, $flags) = (@_, 0); + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + if ($op->flags & OPf_STACKED && $flags & ASSIGN) { + $eq = "="; + $prec = 7; + } + if ($flags & SWAP_CHILDREN) { + ($left, $right) = ($right, $left); + } + my $leftop = $left; + $left = $self->deparse_binop_left($op, $left, $prec); + $left = "($left)" if $flags & LIST_CONTEXT + and $left !~ /^(my|our|local|state|)\s*[\@%\(]/ + || do { + # Parenthesize if the left argument is a + # lone repeat op. + my $left = $leftop->first->sibling; + $left->name eq 'repeat' + && null($left->sibling); + }; + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); +} + +sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } +sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } +sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } + +sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } +sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } +sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } +sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } +sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } +*pp_nbit_and = *pp_bit_and; +*pp_nbit_or = *pp_bit_or; +*pp_nbit_xor = *pp_bit_xor; +sub pp_sbit_and { maybe_targmy(@_, \&binop, "&.", 13, ASSIGN) } +sub pp_sbit_or { maybe_targmy(@_, \&binop, "|.", 12, ASSIGN) } +sub pp_sbit_xor { maybe_targmy(@_, \&binop, "^.", 12, ASSIGN) } + +sub pp_eq { binop(@_, "==", 14) } +sub pp_ne { binop(@_, "!=", 14) } +sub pp_lt { binop(@_, "<", 15) } +sub pp_gt { binop(@_, ">", 15) } +sub pp_ge { binop(@_, ">=", 15) } +sub pp_le { binop(@_, "<=", 15) } +sub pp_ncmp { binop(@_, "<=>", 14) } +sub pp_i_eq { binop(@_, "==", 14) } +sub pp_i_ne { binop(@_, "!=", 14) } +sub pp_i_lt { binop(@_, "<", 15) } +sub pp_i_gt { binop(@_, ">", 15) } +sub pp_i_ge { binop(@_, ">=", 15) } +sub pp_i_le { binop(@_, "<=", 15) } +sub pp_i_ncmp { maybe_targmy(@_, \&binop, "<=>", 14) } + +sub pp_seq { binop(@_, "eq", 14) } +sub pp_sne { binop(@_, "ne", 14) } +sub pp_slt { binop(@_, "lt", 15) } +sub pp_sgt { binop(@_, "gt", 15) } +sub pp_sge { binop(@_, "ge", 15) } +sub pp_sle { binop(@_, "le", 15) } +sub pp_scmp { maybe_targmy(@_, \&binop, "cmp", 14) } + +sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } +sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } + +sub pp_smartmatch { + my ($self, $op, $cx) = @_; + if (($op->flags & OPf_SPECIAL) && $self->{expand} < 2) { + return $self->deparse($op->last, $cx); + } + else { + binop(@_, "~~", 14); + } +} + +# '.' is special because concats-of-concats are optimized to save copying +# by making all but the first concat stacked. The effect is as if the +# programmer had written '($a . $b) .= $c', except legal. +sub pp_concat { maybe_targmy(@_, \&real_concat) } +sub real_concat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 18; + if (($op->flags & OPf_STACKED) and !($op->private & OPpCONCAT_NESTED)) { + # '.=' rather than optimised '.' + $eq = "="; + $prec = 7; + } + $left = $self->deparse_binop_left($op, $left, $prec); + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left .$eq $right", $cx, $prec); +} + +sub pp_repeat { maybe_targmy(@_, \&repeat) } + +# 'x' is weird when the left arg is a list +sub repeat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 19; + if ($op->flags & OPf_STACKED) { + $eq = "="; + $prec = 7; + } + if (null($right)) { # list repeat; count is inside left-side ex-list + # in 5.21.5 and earlier + my $kid = $left->first->sibling; # skip pushmark + my @exprs; + for (; !null($kid->sibling); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + $right = $kid; + $left = "(" . join(", ", @exprs). ")"; + } else { + my $dolist = $op->private & OPpREPEAT_DOLIST; + $left = $self->deparse_binop_left($op, $left, $dolist ? 1 : $prec); + if ($dolist) { + $left = "($left)"; + } + } + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left x$eq $right", $cx, $prec); +} + +sub range { + my $self = shift; + my ($op, $cx, $type) = @_; + my $left = $op->first; + my $right = $left->sibling; + $left = $self->deparse($left, 9); + $right = $self->deparse($right, 9); + return $self->maybe_parens("$left $type $right", $cx, 9); +} + +sub pp_flop { + my $self = shift; + my($op, $cx) = @_; + my $flip = $op->first; + my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; + return $self->range($flip->first, $cx, $type); +} + +# one-line while/until is handled in pp_leave + +sub logop { + my $self = shift; + my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; + my $left = $op->first; + my $right = $op->first->sibling; + $blockname &&= $self->keyword($blockname); + if ($cx < 1 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} + $left = $self->deparse($left, 1); + $right = $self->deparse($right, 0); + return "$blockname ($left) {\n\t$right\n\b}\cK"; + } elsif ($cx < 1 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a + $right = $self->deparse($right, 1); + $left = $self->deparse($left, 1); + return "$right $blockname $left"; + } elsif ($cx > $lowprec and $highop) { # $a && $b + $left = $self->deparse_binop_left($op, $left, $highprec); + $right = $self->deparse_binop_right($op, $right, $highprec); + return $self->maybe_parens("$left $highop $right", $cx, $highprec); + } else { # $a and $b + $left = $self->deparse_binop_left($op, $left, $lowprec); + $right = $self->deparse_binop_right($op, $right, $lowprec); + return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); + } +} + +sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } +sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_dor { logop(@_, "//", 10) } + +# xor is syntactically a logop, but it's really a binop (contrary to +# old versions of opcode.pl). Syntax is what matters here. +sub pp_xor { logop(@_, "xor", 2, "", 0, "") } + +sub logassignop { + my $self = shift; + my ($op, $cx, $opname) = @_; + my $left = $op->first; + my $right = $op->first->sibling->first; # skip sassign + $left = $self->deparse($left, 7); + $right = $self->deparse($right, 7); + return $self->maybe_parens("$left $opname $right", $cx, 7); +} + +sub pp_andassign { logassignop(@_, "&&=") } +sub pp_orassign { logassignop(@_, "||=") } +sub pp_dorassign { logassignop(@_, "//=") } + +sub rv2gv_or_string { + my($self,$op) = @_; + if ($op->name eq "gv") { # could be open("open") or open("###") + my($name,$quoted) = + $self->stash_variable_name("", $self->gv_or_padgv($op)); + $quoted ? $name : "*$name"; + } + else { + $self->deparse($op, 6); + } +} + +sub listop { + my $self = shift; + my($op, $cx, $name, $kid, $nollafr) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + $kid ||= $op->first->sibling; + # If there are no arguments, add final parentheses (or parenthesize the + # whole thing if the llafr does not apply) to account for cases like + # (return)+1 or setpgrp()+1. When the llafr does not apply, we use a + # precedence of 6 (< comma), as "return, 1" does not need parentheses. + if (null $kid) { + return $nollafr + ? $self->maybe_parens($self->keyword($name), $cx, 7) + : $self->keyword($name) . '()' x (7 < $cx); + } + my $first; + my $fullname = $self->keyword($name); + my $proto = prototype("CORE::$name"); + if ( + ( (defined $proto && $proto =~ /^;?\*/) + || $name eq 'select' # select(F) doesn't have a proto + ) + && $kid->name eq "rv2gv" + && !($kid->private & OPpLVAL_INTRO) + ) { + $first = $self->rv2gv_or_string($kid->first); + } + else { + $first = $self->deparse($kid, 6); + } + if ($name eq "chmod" && $first =~ /^\d+$/) { + $first = sprintf("%#o", $first); + } + $first = "+$first" + if not $parens and not $nollafr and substr($first, 0, 1) eq "("; + push @exprs, $first; + $kid = $kid->sibling; + if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv" + && !($kid->private & OPpLVAL_INTRO)) { + push @exprs, $first = $self->rv2gv_or_string($kid->first); + $kid = $kid->sibling; + } + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) { + return "$exprs[0] = $fullname" + . ($parens ? "($exprs[0])" : " $exprs[0]"); + } + + if ($parens && $nollafr) { + return "($fullname " . join(", ", @exprs) . ")"; + } elsif ($parens) { + return "$fullname(" . join(", ", @exprs) . ")"; + } else { + return "$fullname " . join(", ", @exprs); + } +} + +sub pp_bless { listop(@_, "bless") } +sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } +sub pp_substr { + my ($self,$op,$cx) = @_; + if ($op->private & OPpSUBSTR_REPL_FIRST) { + return + listop($self, $op, 7, "substr", $op->first->sibling->sibling) + . " = " + . $self->deparse($op->first->sibling, 7); + } + maybe_local(@_, listop(@_, "substr")) +} + +sub pp_index { + # Also handles pp_rindex. + # + # The body of this function includes an unrolled maybe_targmy(), + # since the two parts of that sub's actions need to have have the + # '== -1' bit in between + + my($self, $op, $cx) = @_; + + my $lex = ($op->private & OPpTARGET_MY); + my $bool = ($op->private & OPpTRUEBOOL); + + my $val = $self->listop($op, ($bool ? 14 : $lex ? 7 : $cx), $op->name); + + # (index() == -1) has op_eq and op_const optimised away + if ($bool) { + $val .= ($op->private & OPpINDEX_BOOLNEG) ? " == -1" : " != -1"; + $val = "($val)" if ($op->flags & OPf_PARENS); + } + if ($lex) { + my $var = $self->padname($op->targ); + $val = $self->maybe_parens("$var = $val", $cx, 7); + } + $val; +} + +sub pp_rindex { pp_index(@_); } +sub pp_vec { maybe_targmy(@_, \&maybe_local, listop(@_, "vec")) } +sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } +sub pp_formline { listop(@_, "formline") } # see also deparse_format +sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } +sub pp_unpack { listop(@_, "unpack") } +sub pp_pack { listop(@_, "pack") } +sub pp_join { maybe_targmy(@_, \&listop, "join") } +sub pp_splice { listop(@_, "splice") } +sub pp_push { maybe_targmy(@_, \&listop, "push") } +sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } +sub pp_reverse { listop(@_, "reverse") } +sub pp_warn { listop(@_, "warn") } +sub pp_die { listop(@_, "die") } +sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply +sub pp_open { listop(@_, "open") } +sub pp_pipe_op { listop(@_, "pipe") } +sub pp_tie { listop(@_, "tie") } +sub pp_binmode { listop(@_, "binmode") } +sub pp_dbmopen { listop(@_, "dbmopen") } +sub pp_sselect { listop(@_, "select") } +sub pp_select { listop(@_, "select") } +sub pp_read { listop(@_, "read") } +sub pp_sysopen { listop(@_, "sysopen") } +sub pp_sysseek { listop(@_, "sysseek") } +sub pp_sysread { listop(@_, "sysread") } +sub pp_syswrite { listop(@_, "syswrite") } +sub pp_send { listop(@_, "send") } +sub pp_recv { listop(@_, "recv") } +sub pp_seek { listop(@_, "seek") } +sub pp_fcntl { listop(@_, "fcntl") } +sub pp_ioctl { listop(@_, "ioctl") } +sub pp_flock { maybe_targmy(@_, \&listop, "flock") } +sub pp_socket { listop(@_, "socket") } +sub pp_sockpair { listop(@_, "socketpair") } +sub pp_bind { listop(@_, "bind") } +sub pp_connect { listop(@_, "connect") } +sub pp_listen { listop(@_, "listen") } +sub pp_accept { listop(@_, "accept") } +sub pp_shutdown { listop(@_, "shutdown") } +sub pp_gsockopt { listop(@_, "getsockopt") } +sub pp_ssockopt { listop(@_, "setsockopt") } +sub pp_chown { maybe_targmy(@_, \&listop, "chown") } +sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } +sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } +sub pp_utime { maybe_targmy(@_, \&listop, "utime") } +sub pp_rename { maybe_targmy(@_, \&listop, "rename") } +sub pp_link { maybe_targmy(@_, \&listop, "link") } +sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } +sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } +sub pp_open_dir { listop(@_, "opendir") } +sub pp_seekdir { listop(@_, "seekdir") } +sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } +sub pp_system { maybe_targmy(@_, \&indirop, "system") } +sub pp_exec { maybe_targmy(@_, \&indirop, "exec") } +sub pp_kill { maybe_targmy(@_, \&listop, "kill") } +sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } +sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } +sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } +sub pp_shmget { listop(@_, "shmget") } +sub pp_shmctl { listop(@_, "shmctl") } +sub pp_shmread { listop(@_, "shmread") } +sub pp_shmwrite { listop(@_, "shmwrite") } +sub pp_msgget { listop(@_, "msgget") } +sub pp_msgctl { listop(@_, "msgctl") } +sub pp_msgsnd { listop(@_, "msgsnd") } +sub pp_msgrcv { listop(@_, "msgrcv") } +sub pp_semget { listop(@_, "semget") } +sub pp_semctl { listop(@_, "semctl") } +sub pp_semop { listop(@_, "semop") } +sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } +sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } +sub pp_gpbynumber { listop(@_, "getprotobynumber") } +sub pp_gsbyname { listop(@_, "getservbyname") } +sub pp_gsbyport { listop(@_, "getservbyport") } +sub pp_syscall { listop(@_, "syscall") } + +sub pp_glob { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first->sibling; # skip pushmark + my $keyword = + $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob'); + my $text = $self->deparse($kid); + return $cx >= 5 || $self->{'parens'} + ? "$keyword($text)" + : "$keyword $text"; +} + +# Truncate is special because OPf_SPECIAL makes a bareword first arg +# be a filehandle. This could probably be better fixed in the core +# by moving the GV lookup into ck_truc. + +sub pp_truncate { + my $self = shift; + my($op, $cx) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + my $kid = $op->first->sibling; + my $fh; + if ($op->flags & OPf_SPECIAL) { + # $kid is an OP_CONST + $fh = $self->const_sv($kid)->PV; + } else { + $fh = $self->deparse($kid, 6); + $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; + } + my $len = $self->deparse($kid->sibling, 6); + my $name = $self->keyword('truncate'); + if ($parens) { + return "$name($fh, $len)"; + } else { + return "$name $fh, $len"; + } +} + +sub indirop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $firstkid = my $kid = $op->first->sibling; + my $indir = ""; + if ($op->flags & OPf_STACKED) { + $indir = $kid; + $indir = $indir->first; # skip rv2gv + if (is_scope($indir)) { + $indir = "{" . $self->deparse($indir, 0) . "}"; + $indir = "{;}" if $indir eq "{}"; + } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { + $indir = $self->const_sv($indir)->PV; + } else { + $indir = $self->deparse($indir, 24); + } + $indir = $indir . " "; + $kid = $kid->sibling; + } + if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { + $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' + : '{$a <=> $b} '; + } + elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { + $indir = '{$b cmp $a} '; + } + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6); + push @exprs, $expr; + } + my $name2; + if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { + $name2 = $self->keyword('reverse') . ' ' . $self->keyword('sort'); + } + else { $name2 = $self->keyword($name) } + if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { + return "$exprs[0] = $name2 $indir $exprs[0]"; + } + + my $args = $indir . join(", ", @exprs); + if ($indir ne "" && $name eq "sort") { + # We don't want to say "sort(f 1, 2, 3)", since perl -w will + # give bareword warnings in that case. Therefore if context + # requires, we'll put parens around the outside "(sort f 1, 2, + # 3)". Unfortunately, we'll currently think the parens are + # necessary more often that they really are, because we don't + # distinguish which side of an assignment we're on. + if ($cx >= 5) { + return "($name2 $args)"; + } else { + return "$name2 $args"; + } + } elsif ( + !$indir && $name eq "sort" + && !null($op->first->sibling) + && $op->first->sibling->name eq 'entersub' + ) { + # We cannot say sort foo(bar), as foo will be interpreted as a + # comparison routine. We have to say sort(...) in that case. + return "$name2($args)"; + } else { + return length $args + ? $self->maybe_parens_func($name2, $args, $cx, 5) + : $name2 . '()' x (7 < $cx); + } + +} + +sub pp_prtf { indirop(@_, "printf") } +sub pp_print { indirop(@_, "print") } +sub pp_say { indirop(@_, "say") } +sub pp_sort { indirop(@_, "sort") } + +sub mapop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $kid = $op->first; # this is the (map|grep)start + $kid = $kid->first->sibling; # skip a pushmark + my $code = $kid->first; # skip a null + if (is_scope $code) { + $code = "{" . $self->deparse($code, 0) . "} "; + } else { + $code = $self->deparse($code, 24); + $code .= ", " if !null($kid->sibling); + } + $kid = $kid->sibling; + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr if defined $expr; + } + return $self->maybe_parens_func($self->keyword($name), + $code . join(", ", @exprs), $cx, 5); +} + +sub pp_mapwhile { mapop(@_, "map") } +sub pp_grepwhile { mapop(@_, "grep") } +sub pp_mapstart { baseop(@_, "map") } +sub pp_grepstart { baseop(@_, "grep") } + +my %uses_intro; +BEGIN { + @uses_intro{ + eval { require B::Op_private } + ? @{$B::Op_private::ops_using{OPpLVAL_INTRO}} + : qw(gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice + hslice delete padsv padav padhv enteriter entersub padrange + pushmark cond_expr refassign list) + } = (); + delete @uses_intro{qw( lvref lvrefslice lvavref entersub )}; +} + + +# Look for a my/state attribute declaration in a list or ex-list. +# Returns undef if not found, 'my($x, @a) :Foo(bar)' etc otherwise. +# +# There are three basic tree structs that are expected: +# +# my $x :foo; +# <1> ex-list vK/LVINTRO ->c +# <0> ex-pushmark v ->3 +# <1> entersub[t2] vKRS*/TARG ->b +# .... +# <0> padsv[$x:64,65] vM/LVINTRO ->c +# +# my @a :foo; +# my %h :foo; +# +# <1> ex-list vK ->c +# <0> ex-pushmark v ->3 +# <0> padav[@a:64,65] vM/LVINTRO ->4 +# <1> entersub[t2] vKRS*/TARG ->c +# .... +# +# my ($x,@a,%h) :foo; +# +# <;> nextstate(main 64 -e:1) v:{ ->3 +# <@> list vKP ->w +# <0> pushmark vM/LVINTRO ->4 +# <0> padsv[$x:64,65] vM/LVINTRO ->5 +# <0> padav[@a:64,65] vM/LVINTRO ->6 +# <0> padhv[%h:64,65] vM/LVINTRO ->7 +# <1> entersub[t4] vKRS*/TARG ->f +# .... +# <1> entersub[t5] vKRS*/TARG ->n +# .... +# <1> entersub[t6] vKRS*/TARG ->v +# .... +# where the entersub in all cases looks like +# <1> entersub[t2] vKRS*/TARG ->c +# <0> pushmark s ->5 +# <$> const[PV "attributes"] sM ->6 +# <$> const[PV "main"] sM ->7 +# <1> srefgen sKM/1 ->9 +# <1> ex-list lKRM ->8 +# <0> padsv[@a:64,65] sRM ->8 +# <$> const[PV "foo"] sM ->a +# <.> method_named[PV "import"] ->b + +sub maybe_var_attr { + my ($self, $op, $cx) = @_; + + my $kid = $op->first->sibling; # skip pushmark + return if class($kid) eq 'NULL'; + + my $lop; + my $type; + + # Extract out all the pad ops and entersub ops into + # @padops and @entersubops. Return if anything else seen. + # Also determine what class (if any) all the pad vars belong to + my $class; + my $decl; # 'my' or 'state' + my (@padops, @entersubops); + for ($lop = $kid; !null($lop); $lop = $lop->sibling) { + my $lopname = $lop->name; + my $loppriv = $lop->private; + if ($lopname =~ /^pad[sah]v$/) { + return unless $loppriv & OPpLVAL_INTRO; + + my $padname = $self->padname_sv($lop->targ); + my $thisclass = ($padname->FLAGS & SVpad_TYPED) + ? $padname->SvSTASH->NAME : 'main'; + + # all pad vars must be in the same class + $class //= $thisclass; + return unless $thisclass eq $class; + + # all pad vars must be the same sort of declaration + # (all my, all state, etc) + my $this = ($loppriv & OPpPAD_STATE) ? 'state' : 'my'; + if (defined $decl) { + return unless $this eq $decl; + } + $decl = $this; + + push @padops, $lop; + } + elsif ($lopname eq 'entersub') { + push @entersubops, $lop; + } + else { + return; + } + } + + return unless @padops && @padops == @entersubops; + + # there should be a balance: each padop has a corresponding + # 'attributes'->import() method call, in the same order. + + my @varnames; + my $attr_text; + + for my $i (0..$#padops) { + my $padop = $padops[$i]; + my $esop = $entersubops[$i]; + + push @varnames, $self->padname($padop->targ); + + return unless ($esop->flags & OPf_KIDS); + + my $kid = $esop->first; + return unless $kid->type == OP_PUSHMARK; + + $kid = $kid->sibling; + return unless $$kid && $kid->type == OP_CONST; + return unless $self->const_sv($kid)->PV eq 'attributes'; + + $kid = $kid->sibling; + return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__ + + $kid = $kid->sibling; + return unless $$kid + && $kid->name eq "srefgen" + && ($kid->flags & OPf_KIDS) + && ($kid->first->flags & OPf_KIDS) + && $kid->first->first->name =~ /^pad[sah]v$/ + && $kid->first->first->targ == $padop->targ; + + $kid = $kid->sibling; + my @attr; + while ($$kid) { + last if ($kid->type != OP_CONST); + push @attr, $self->const_sv($kid)->PV; + $kid = $kid->sibling; + } + return unless @attr; + my $thisattr = ":" . join(' ', @attr); + $attr_text //= $thisattr; + # all import calls must have the same list of attributes + return unless $attr_text eq $thisattr; + + return unless $kid->name eq 'method_named'; + return unless $self->meth_sv($kid)->PV eq 'import'; + + $kid = $kid->sibling; + return if $$kid; + } + + my $res = $decl; + $res .= " $class " if $class ne 'main'; + $res .= + (@varnames > 1) + ? "(" . join(', ', @varnames) . ')' + : " $varnames[0]"; + + return "$res $attr_text"; +} + + +sub pp_list { + my $self = shift; + my($op, $cx) = @_; + + { + # might be my ($s,@a,%h) :Foo(bar); + my $my_attr = maybe_var_attr($self, $op, $cx); + return $my_attr if defined $my_attr; + } + + my($expr, @exprs); + my $kid = $op->first->sibling; # skip pushmark + return '' if class($kid) eq 'NULL'; + my $lop; + my $local = "either"; # could be local(...), my(...), state(...) or our(...) + my $type; + for ($lop = $kid; !null($lop); $lop = $lop->sibling) { + my $lopname = $lop->name; + my $loppriv = $lop->private; + my $newtype; + if ($lopname =~ /^pad[ash]v$/ && $loppriv & OPpLVAL_INTRO) { + if ($loppriv & OPpPAD_STATE) { # state() + ($local = "", last) if $local !~ /^(?:either|state)$/; + $local = "state"; + } else { # my() + ($local = "", last) if $local !~ /^(?:either|my)$/; + $local = "my"; + } + my $padname = $self->padname_sv($lop->targ); + if ($padname->FLAGS & SVpad_TYPED) { + $newtype = $padname->SvSTASH->NAME; + } + } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/ + && $loppriv & OPpOUR_INTRO + or $lopname eq "null" && class($lop) eq 'UNOP' + && $lop->first->name eq "gvsv" + && $lop->first->private & OPpOUR_INTRO) { # our() + my $newlocal = "local " x !!($loppriv & OPpLVAL_INTRO) . "our"; + ($local = "", last) + if $local ne 'either' && $local ne $newlocal; + $local = $newlocal; + my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%'; + if (my $t = $self->find_our_type( + $funny . $self->gv_or_padgv($lop->first)->NAME + )) { + $newtype = $t; + } + } elsif ($lopname ne 'undef' + and !($loppriv & OPpLVAL_INTRO) + || !exists $uses_intro{$lopname eq 'null' + ? substr B::ppname($lop->targ), 3 + : $lopname}) + { + $local = ""; # or not + last; + } elsif ($lopname ne "undef") + { + # local() + ($local = "", last) if $local !~ /^(?:either|local)$/; + $local = "local"; + } + if (defined $type && defined $newtype && $newtype ne $type) { + $local = ''; + last; + } + $type = $newtype; + } + $local = "" if $local eq "either"; # no point if it's all undefs + $local &&= join ' ', map $self->keyword($_), split / /, $local; + $local .= " $type " if $local && length $type; + return $self->deparse($kid, $cx) if null $kid->sibling and not $local; + for (; !null($kid); $kid = $kid->sibling) { + if ($local) { + if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { + $lop = $kid->first; + } else { + $lop = $kid; + } + $self->{'avoid_local'}{$$lop}++; + $expr = $self->deparse($kid, 6); + delete $self->{'avoid_local'}{$$lop}; + } else { + $expr = $self->deparse($kid, 6); + } + push @exprs, $expr; + } + if ($local) { + if (@exprs == 1 && ($local eq 'state' || $local eq 'CORE::state')) { + # 'state @a = ...' is legal, while 'state(@a) = ...' currently isn't + return "$local $exprs[0]"; + } + return "$local(" . join(", ", @exprs) . ")"; + } else { + return $self->maybe_parens( join(", ", @exprs), $cx, 6); + } +} + +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + +sub pp_cond_expr { + my $self = shift; + my($op, $cx) = @_; + my $cond = $op->first; + my $true = $cond->sibling; + my $false = $true->sibling; + my $cuddle = $self->{'cuddle'}; + unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 6); + $false = $self->deparse($false, 8); + return $self->maybe_parens("$cond ? $true : $false", $cx, 8); + } + + $cond = $self->deparse($cond, 1); + $true = $self->deparse($true, 0); + my $head = $self->keyword("if") . " ($cond) {\n\t$true\n\b}"; + my @elsifs; + my $elsif; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + if ($newcond->name eq "lineseq") + { + # lineseq to ensure correct line numbers in elsif() + # Bug #37302 fixed by change #33710. + $newcond = $newcond->first->sibling; + } + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + $elsif ||= $self->keyword("elsif"); + push @elsifs, "$elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . $self->keyword("else") . " {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; + } + return $head . join($cuddle, "", @elsifs) . $false; +} + +sub pp_once { + my ($self, $op, $cx) = @_; + my $cond = $op->first; + my $true = $cond->sibling; + + my $ret = $self->deparse($true, $cx); + $ret =~ s/^(\(?)\$/$1 . $self->keyword("state") . ' $'/e; + $ret; +} + +sub loop_common { + my $self = shift; + my($op, $cx, $init) = @_; + my $enter = $op->first; + my $kid = $enter->sibling; + local(@$self{qw'curstash warnings hints hinthash'}) + = @$self{qw'curstash warnings hints hinthash'}; + my $head = ""; + my $bare = 0; + my $body; + my $cond = undef; + my $name; + if ($kid->name eq "lineseq") { # bare or infinite loop + if ($kid->last->name eq "unstack") { # infinite + $head = "while (1) "; # Can't use for(;;) if there's a continue + $cond = ""; + } else { + $bare = 1; + } + $body = $kid; + } elsif ($enter->name eq "enteriter") { # foreach + my $ary = $enter->first->sibling; # first was pushmark + my $var = $ary->sibling; + if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { + # "reverse" was optimised away + $ary = listop($self, $ary->first->sibling, 1, 'reverse'); + } elsif ($enter->flags & OPf_STACKED + and not null $ary->first->sibling->sibling) + { + $ary = $self->deparse($ary->first->sibling, 9) . " .. " . + $self->deparse($ary->first->sibling->sibling, 9); + } else { + $ary = $self->deparse($ary, 1); + } + if (null $var) { + $var = $self->pp_padsv($enter, 1, 1); + } elsif ($var->name eq "rv2gv") { + $var = $self->pp_rv2sv($var, 1); + if ($enter->private & OPpOUR_INTRO) { + # our declarations don't have package names + $var =~ s/^(.).*::/$1/; + $var = "our $var"; + } + } elsif ($var->name eq "gv") { + $var = "\$" . $self->deparse($var, 1); + } else { + $var = $self->deparse($var, 1); + } + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER + if (!is_state $body->first and $body->first->name !~ /^(?:stub|leave|scope)$/) { + confess unless $var eq '$_'; + $body = $body->first; + return $self->deparse($body, 2) . " " + . $self->keyword("foreach") . " ($ary)"; + } + $head = "foreach $var ($ary) "; + } elsif ($kid->name eq "null") { # while/until + $kid = $kid->first; + $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $kid->first; + $body = $kid->first->sibling; + } elsif ($kid->name eq "stub") { # bare and empty + return "{;}"; # {} could be a hashref + } + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's last child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the second-to-last child is the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + my $precond; + my $postcond; + if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(undef, 0, @states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $precond = "for ($init; "; + $postcond = "; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; + } + } else { + return "" if !defined $body; + if (length $init) { + $precond = "for ($init; "; + $postcond = ";) "; + } + $cont = "\cK"; + $body = $self->deparse($body, 0); + } + if ($precond) { # for(;;) + $cond &&= $name eq 'until' + ? listop($self, undef, 1, "not", $cond->first) + : $self->deparse($cond, 1); + $head = "$precond$cond$postcond"; + } + if ($name && !$head) { + ref $cond and $cond = $self->deparse($cond, 1); + $head = "$name ($cond) "; + } + $head =~ s/^(for(?:each)?|while|until)/$self->keyword($1)/e; + $body =~ s/;?$/;\n/; + + return $head . "{\n\t" . $body . "\b}" . $cont; +} + +sub pp_leaveloop { shift->loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + my $s = $op->sibling; + my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling; + return $self->loop_common($ll, $cx, $init); +} + +sub pp_leavetry { + my $self = shift; + return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; +} + +sub _op_is_or_was { + my ($op, $expect_type) = @_; + my $type = $op->type; + return($type == $expect_type + || ($type == OP_NULL && $op->targ == $expect_type)); +} + +sub pp_null { + my($self, $op, $cx) = @_; + + # might be 'my $s :Foo(bar);' + if ($op->targ == OP_LIST) { + my $my_attr = maybe_var_attr($self, $op, $cx); + return $my_attr if defined $my_attr; + } + + if (class($op) eq "OP") { + # old value is lost + return $self->{'ex_const'} if $op->targ == OP_CONST; + } elsif (class ($op) eq "COP") { + return &pp_nextstate; + } elsif ($op->first->name eq 'pushmark' + or $op->first->name eq 'null' + && $op->first->targ == OP_PUSHMARK + && _op_is_or_was($op, OP_LIST)) { + return $self->pp_list($op, $cx); + } elsif ($op->first->name eq "enter") { + return $self->pp_leave($op, $cx); + } elsif ($op->first->name eq "leave") { + return $self->pp_leave($op->first, $cx); + } elsif ($op->first->name eq "scope") { + return $self->pp_scope($op->first, $cx); + } elsif ($op->targ == OP_STRINGIFY) { + return $self->dquote($op, $cx); + } elsif ($op->targ == OP_GLOB) { + return $self->pp_glob( + $op->first # entersub + ->first # ex-list + ->first # pushmark + ->sibling, # glob + $cx + ); + } elsif (!null($op->first->sibling) and + $op->first->sibling->name eq "readline" and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 7) . " = " + . $self->deparse($op->first->sibling, 7), + $cx, 7); + } elsif (!null($op->first->sibling) and + $op->first->sibling->name =~ /^transr?\z/ and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " + . $self->deparse($op->first->sibling, 20), + $cx, 20); + } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { + return ($self->lex_in_scope("&do") ? "CORE::do" : "do") + . " {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; + } elsif (!null($op->first->sibling) and + $op->first->sibling->name eq "null" and + class($op->first->sibling) eq "UNOP" and + $op->first->sibling->first->flags & OPf_STACKED and + $op->first->sibling->first->name eq "rcatline") { + return $self->maybe_parens($self->deparse($op->first, 18) . " .= " + . $self->deparse($op->first->sibling, 18), + $cx, 18); + } else { + return $self->deparse($op->first, $cx); + } +} + +sub padname { + my $self = shift; + my $targ = shift; + return $self->padname_sv($targ)->PVX; +} + +sub padany { + my $self = shift; + my $op = shift; + return substr($self->padname($op->targ), 1); # skip $/@/% +} + +sub pp_padsv { + my $self = shift; + my($op, $cx, $forbid_parens) = @_; + my $targ = $op->targ; + return $self->maybe_my($op, $cx, $self->padname($targ), + $self->padname_sv($targ), + $forbid_parens); +} + +sub pp_padav { pp_padsv(@_) } + +# prepend 'keys' where its been optimised away, with suitable handling +# of CORE:: and parens + +sub add_keys_keyword { + my ($self, $str, $cx) = @_; + $str = $self->maybe_parens($str, $cx, 16); + # 'keys %h' versus 'keys(%h)' + $str = " $str" unless $str =~ /^\(/; + return $self->keyword("keys") . $str; +} + +sub pp_padhv { + my ($self, $op, $cx) = @_; + my $str = pp_padsv(@_); + # with OPpPADHV_ISKEYS the keys op is optimised away, except + # in scalar context the old op is kept (but not executed) so its targ + # can be used. + if ( ($op->private & OPpPADHV_ISKEYS) + && !(($op->flags & OPf_WANT) == OPf_WANT_SCALAR)) + { + $str = $self->add_keys_keyword($str, $cx); + } + $str; +} + +sub gv_or_padgv { + my $self = shift; + my $op = shift; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; + } +} + +sub pp_gvsv { + my $self = shift; + my($op, $cx) = @_; + my $gv = $self->gv_or_padgv($op); + return $self->maybe_local($op, $cx, $self->stash_variable("\$", + $self->gv_name($gv), $cx)); +} + +sub pp_gv { + my $self = shift; + my($op, $cx) = @_; + my $gv = $self->gv_or_padgv($op); + return $self->maybe_qualify("", $self->gv_name($gv)); +} + +sub pp_aelemfast_lex { + my $self = shift; + my($op, $cx) = @_; + my $name = $self->padname($op->targ); + $name =~ s/^@/\$/; + my $i = $op->private; + $i -= 256 if $i > 127; + return $name . "[" . ($i + $self->{'arybase'}) . "]"; +} + +sub pp_aelemfast { + my $self = shift; + my($op, $cx) = @_; + # optimised PADAV, pre 5.15 + return $self->pp_aelemfast_lex(@_) if ($op->flags & OPf_SPECIAL); + + my $gv = $self->gv_or_padgv($op); + my($name,$quoted) = $self->stash_variable_name('@',$gv); + $name = $quoted ? "$name->" : '$' . $name; + my $i = $op->private; + $i -= 256 if $i > 127; + return $name . "[" . ($i + $self->{'arybase'}) . "]"; +} + +sub rv2x { + my $self = shift; + my($op, $cx, $type) = @_; + + if (class($op) eq 'NULL' || !$op->can("first")) { + carp("Unexpected op in pp_rv2x"); + return 'XXX'; + } + my $kid = $op->first; + if ($kid->name eq "gv") { + return $self->stash_variable($type, + $self->gv_name($self->gv_or_padgv($kid)), $cx); + } elsif (is_scalar $kid) { + my $str = $self->deparse($kid, 0); + if ($str =~ /^\$([^\w\d])\z/) { + # "$$+" isn't a legal way to write the scalar dereference + # of $+, since the lexer can't tell you aren't trying to + # do something like "$$ + 1" to get one more than your + # PID. Either "${$+}" or "$${+}" are workable + # disambiguations, but if the programmer did the former, + # they'd be in the "else" clause below rather than here. + # It's not clear if this should somehow be unified with + # the code in dq and re_dq that also adds lexer + # disambiguation braces. + $str = '$' . "{$1}"; #' + } + return $type . $str; + } else { + return $type . "{" . $self->deparse($kid, 0) . "}"; + } +} + +sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } +sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } + +sub pp_rv2hv { + my ($self, $op, $cx) = @_; + my $str = rv2x(@_, "%"); + if ($op->private & OPpRV2HV_ISKEYS) { + $str = $self->add_keys_keyword($str, $cx); + } + return maybe_local(@_, $str); +} + +# skip rv2av +sub pp_av2arylen { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->name eq "padav") { + return $self->maybe_local($op, $cx, '$#' . $self->padany($kid)); + } else { + my $kkid; + if ( $kid->name eq "rv2av" + && ($kkid = $kid->first) + && $kkid->name !~ /^(scope|leave|gv)$/) + { + # handle (expr)->$#* postfix form + my $expr; + $expr = $self->deparse($kkid, 24); # 24 is '->' + $expr = "$expr->\$#*"; + # XXX maybe_local is probably wrong here: local($#-expression) + # doesn't "do" local (the is no INTRO flag set) + return $self->maybe_local($op, $cx, $expr); + } + else { + # handle $#{expr} form + # XXX see maybe_local comment above + return $self->maybe_local($op, $cx, $self->rv2x($kid, $cx, '$#')); + } + } +} + +# skip down to the old, ex-rv2cv +sub pp_rv2cv { + my ($self, $op, $cx) = @_; + if (!null($op->first) && $op->first->name eq 'null' && + $op->first->targ == OP_LIST) + { + return $self->rv2x($op->first->first->sibling, $cx, "&") + } + else { + return $self->rv2x($op, $cx, "") + } +} + +sub list_const { + my $self = shift; + my($cx, @list) = @_; + my @a = map $self->const($_, 6), @list; + if (@a == 0) { + return "()"; + } elsif (@a == 1) { + return $a[0]; + } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { + # collapse (-1,0,1,2) into (-1..2) + my ($s, $e) = @a[0,-1]; + my $i = $s; + return $self->maybe_parens("$s..$e", $cx, 9) + unless grep $i++ != $_, @a; + } + return $self->maybe_parens(join(", ", @a), $cx, 6); +} + +sub pp_rv2av { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->name eq "const") { # constant list + my $av = $self->const_sv($kid); + return $self->list_const($cx, $av->ARRAY); + } else { + return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); + } + } + +sub is_subscriptable { + my $op = shift; + if ($op->name =~ /^([ahg]elem|multideref$)/) { + return 1; + } elsif ($op->name eq "entersub") { + my $kid = $op->first; + return 0 unless null $kid->sibling; + $kid = $kid->first; + $kid = $kid->sibling until null $kid->sibling; + return 0 if is_scope($kid); + $kid = $kid->first; + return 0 if $kid->name eq "gv" || $kid->name eq "padcv"; + return 0 if is_scalar($kid); + return is_subscriptable($kid); + } else { + return 0; + } +} + +sub elem_or_slice_array_name +{ + my $self = shift; + my ($array, $left, $padname, $allow_arrow) = @_; + + if ($array->name eq $padname) { + return $self->padany($array); + } elsif (is_scope($array)) { # ${expr}[0] + return "{" . $self->deparse($array, 0) . "}"; + } elsif ($array->name eq "gv") { + ($array, my $quoted) = + $self->stash_variable_name( + $left eq '[' ? '@' : '%', $self->gv_or_padgv($array) + ); + if (!$allow_arrow && $quoted) { + # This cannot happen. + die "Invalid variable name $array for slice"; + } + return $quoted ? "$array->" : $array; + } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ... + return $self->deparse($array, 24); + } else { + return undef; + } +} + +sub elem_or_slice_single_index +{ + my $self = shift; + my ($idx) = @_; + + $idx = $self->deparse($idx, 1); + + # Outer parens in an array index will confuse perl + # if we're interpolating in a regular expression, i.e. + # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ + # + # If $self->{parens}, then an initial '(' will + # definitely be paired with a final ')'. If + # !$self->{parens}, the misleading parens won't + # have been added in the first place. + # + # [You might think that we could get "(...)...(...)" + # where the initial and final parens do not match + # each other. But we can't, because the above would + # only happen if there's an infix binop between the + # two pairs of parens, and *that* means that the whole + # expression would be parenthesized as well.] + # + $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; + + # Hash-element braces will autoquote a bareword inside themselves. + # We need to make sure that C<$hash{warn()}> doesn't come out as + # C<$hash{warn}>, which has a quite different meaning. Currently + # B::Deparse will always quote strings, even if the string was a + # bareword in the original (i.e. the OPpCONST_BARE flag is ignored + # for constant strings.) So we can cheat slightly here - if we see + # a bareword, we know that it is supposed to be a function call. + # + $idx =~ s/^([A-Za-z_]\w*)$/$1()/; + + return $idx; +} + +sub elem { + my $self = shift; + my ($op, $cx, $left, $right, $padname) = @_; + my($array, $idx) = ($op->first, $op->first->sibling); + + $idx = $self->elem_or_slice_single_index($idx); + + unless ($array->name eq $padname) { # Maybe this has been fixed + $array = $array->first; # skip rv2av (or ex-rv2av in _53+) + } + if (my $array_name=$self->elem_or_slice_array_name + ($array, $left, $padname, 1)) { + return ($array_name =~ /->\z/ + ? $array_name + : $array_name eq '#' ? '${#}' : "\$" . $array_name) + . $left . $idx . $right; + } else { + # $x[20][3]{hi} or expr->[20] + my $arrow = is_subscriptable($array) ? "" : "->"; + return $self->deparse($array, 24) . $arrow . $left . $idx . $right; + } + +} + +# a simplified version of elem_or_slice_array_name() +# for the use of pp_multideref + +sub multideref_var_name { + my $self = shift; + my ($gv, $is_hash) = @_; + + my ($name, $quoted) = + $self->stash_variable_name( $is_hash ? '%' : '@', $gv); + return $quoted ? "$name->" + : $name eq '#' + ? '${#}' # avoid ${#}[1] => $#[1] + : '$' . $name; +} + + +# deparse an OP_MULTICONCAT. If $in_dq is 1, we're within +# a double-quoted string, so for example. +# "abc\Qdef$x\Ebar" +# might get compiled as +# multiconcat("abc", metaquote(multiconcat("def", $x)), "bar") +# and the inner multiconcat should be deparsed as C rather than +# the normal C +# Ditto if $in_dq is 2, handle qr/...\Qdef$x\E.../. + +sub do_multiconcat { + my $self = shift; + my($op, $cx, $in_dq) = @_; + + my $kid; + my @kids; + my $assign; + my $append; + my $lhs = ""; + + for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { + # skip the consts and/or padsv we've optimised away + push @kids, $kid + unless $kid->type == OP_NULL + && ( $kid->targ == OP_PADSV + || $kid->targ == OP_CONST + || $kid->targ == OP_PUSHMARK); + } + + $append = ($op->private & OPpMULTICONCAT_APPEND); + + if ($op->private & OPpTARGET_MY) { + # '$lex = ...' or '$lex .= ....' or 'my $lex = ' + $lhs = $self->padname($op->targ); + $lhs = "my $lhs" if ($op->private & OPpLVAL_INTRO); + $assign = 1; + } + elsif ($op->flags & OPf_STACKED) { + # 'expr = ...' or 'expr .= ....' + my $expr = $append ? shift(@kids) : pop(@kids); + $lhs = $self->deparse($expr, 7); + $assign = 1; + } + + if ($assign) { + $lhs .= $append ? ' .= ' : ' = '; + } + + my ($nargs, $const_str, @const_lens) = $op->aux_list($self->{curcv}); + + my @consts; + my $i = 0; + for (@const_lens) { + if ($_ == -1) { + push @consts, undef; + } + else { + push @consts, substr($const_str, $i, $_); + my @args; + $i += $_; + } + } + + my $rhs = ""; + + if ( $in_dq + || (($op->private & OPpMULTICONCAT_STRINGIFY) && !$self->{'unquote'})) + { + # "foo=$foo bar=$bar " + my $not_first; + while (@consts) { + if ($not_first) { + my $s = $self->dq(shift(@kids), 18); + # don't deparse "a${$}b" as "a$$b" + $s = '${$}' if $s eq '$$'; + $rhs = dq_disambiguate($rhs, $s); + } + $not_first = 1; + my $c = shift @consts; + if (defined $c) { + if ($in_dq == 2) { + # in pattern: don't convert newline to '\n' etc etc + my $s = re_uninterp(escape_re(re_unback($c))); + $rhs = re_dq_disambiguate($rhs, $s) + } + else { + my $s = uninterp(escape_str(unback($c))); + $rhs = dq_disambiguate($rhs, $s) + } + } + } + return $rhs if $in_dq; + $rhs = single_delim("qq", '"', $rhs, $self); + } + elsif ($op->private & OPpMULTICONCAT_FAKE) { + # sprintf("foo=%s bar=%s ", $foo, $bar) + + my @all; + @consts = map { $_ //= ''; s/%/%%/g; $_ } @consts; + my $fmt = join '%s', @consts; + push @all, $self->quoted_const_str($fmt); + + # the following is a stripped down copy of sub listop {} + my $parens = $assign || ($cx >= 5) || $self->{'parens'}; + my $fullname = $self->keyword('sprintf'); + push @all, map $self->deparse($_, 6), @kids; + + $rhs = $parens + ? "$fullname(" . join(", ", @all) . ")" + : "$fullname " . join(", ", @all); + } + else { + # "foo=" . $foo . " bar=" . $bar + my @all; + my $not_first; + while (@consts) { + push @all, $self->deparse(shift(@kids), 18) if $not_first; + $not_first = 1; + my $c = shift @consts; + if (defined $c) { + push @all, $self->quoted_const_str($c); + } + } + $rhs .= join ' . ', @all; + } + + my $text = $lhs . $rhs; + + $text = "($text)" if ($cx >= (($assign) ? 7 : 18+1)) + || $self->{'parens'}; + + return $text; +} + + +sub pp_multiconcat { + my $self = shift; + $self->do_multiconcat(@_, 0); +} + + +sub pp_multideref { + my $self = shift; + my($op, $cx) = @_; + my $text = ""; + + if ($op->private & OPpMULTIDEREF_EXISTS) { + $text = $self->keyword("exists"). " "; + } + elsif ($op->private & OPpMULTIDEREF_DELETE) { + $text = $self->keyword("delete"). " "; + } + elsif ($op->private & OPpLVAL_INTRO) { + $text = $self->keyword("local"). " "; + } + + if ($op->first && ($op->first->flags & OPf_KIDS)) { + # arbitrary initial expression, e.g. f(1,2,3)->[...] + my $expr = $self->deparse($op->first, 24); + # stop "exists (expr)->{...}" being interpreted as + #"(exists (expr))->{...}" + $expr = "+$expr" if $expr =~ /^\(/; + $text .= $expr; + } + + my @items = $op->aux_list($self->{curcv}); + my $actions = shift @items; + + my $is_hash; + my $derefs = 0; + + while (1) { + if (($actions & MDEREF_ACTION_MASK) == MDEREF_reload) { + $actions = shift @items; + next; + } + + $is_hash = ( + ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_pop_rv2hv_helem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvsv_vivify_rv2hv_helem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padsv_vivify_rv2hv_helem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_vivify_rv2hv_helem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem + ); + + if ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_padav_aelem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_padhv_helem) + { + $derefs = 1; + $text .= '$' . substr($self->padname(shift @items), 1); + } + elsif ( ($actions & MDEREF_ACTION_MASK) == MDEREF_AV_gvav_aelem + || ($actions & MDEREF_ACTION_MASK) == MDEREF_HV_gvhv_helem) + { + $derefs = 1; + $text .= $self->multideref_var_name(shift @items, $is_hash); + } + else { + if ( ($actions & MDEREF_ACTION_MASK) == + MDEREF_AV_padsv_vivify_rv2av_aelem + || ($actions & MDEREF_ACTION_MASK) == + MDEREF_HV_padsv_vivify_rv2hv_helem) + { + $text .= $self->padname(shift @items); + } + elsif ( ($actions & MDEREF_ACTION_MASK) == + MDEREF_AV_gvsv_vivify_rv2av_aelem + || ($actions & MDEREF_ACTION_MASK) == + MDEREF_HV_gvsv_vivify_rv2hv_helem) + { + $text .= $self->multideref_var_name(shift @items, $is_hash); + } + elsif ( ($actions & MDEREF_ACTION_MASK) == + MDEREF_AV_pop_rv2av_aelem + || ($actions & MDEREF_ACTION_MASK) == + MDEREF_HV_pop_rv2hv_helem) + { + if ( ($op->flags & OPf_KIDS) + && ( _op_is_or_was($op->first, OP_RV2AV) + || _op_is_or_was($op->first, OP_RV2HV)) + && ($op->first->flags & OPf_KIDS) + && ( _op_is_or_was($op->first->first, OP_AELEM) + || _op_is_or_was($op->first->first, OP_HELEM)) + ) + { + $derefs++; + } + } + + $text .= '->' if !$derefs++; + } + + + if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_none) { + last; + } + + $text .= $is_hash ? '{' : '['; + + if (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_const) { + my $key = shift @items; + if ($is_hash) { + $text .= $self->const($key, $cx); + } + else { + $text .= $key; + } + } + elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_padsv) { + $text .= $self->padname(shift @items); + } + elsif (($actions & MDEREF_INDEX_MASK) == MDEREF_INDEX_gvsv) { + $text .= '$' . ($self->stash_variable_name('$', shift @items))[0]; + } + + $text .= $is_hash ? '}' : ']'; + + if ($actions & MDEREF_FLAG_last) { + last; + } + $actions >>= MDEREF_SHIFT; + } + + return $text; +} + + +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } + +sub pp_gelem { + my $self = shift; + my($op, $cx) = @_; + my($glob, $part) = ($op->first, $op->last); + $glob = $glob->first; # skip rv2gv + $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug + my $scope = is_scope($glob); + $glob = $self->deparse($glob, 0); + $part = $self->deparse($part, 1); + $glob =~ s/::\z// unless $scope; + return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; +} + +sub slice { + my $self = shift; + my ($op, $cx, $left, $right, $regname, $padname) = @_; + my $last; + my(@elems, $kid, $array, $list); + if (class($op) eq "LISTOP") { + $last = $op->last; + } else { # ex-hslice inside delete() + for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} + $last = $kid; + } + $array = $last; + $array = $array->first + if $array->name eq $regname or $array->name eq "null"; + $array = $self->elem_or_slice_array_name($array,$left,$padname,0); + $kid = $op->first->sibling; # skip pushmark + if ($kid->name eq "list") { + $kid = $kid->first->sibling; # skip list, pushmark + for (; !null $kid; $kid = $kid->sibling) { + push @elems, $self->deparse($kid, 6); + } + $list = join(", ", @elems); + } else { + $list = $self->elem_or_slice_single_index($kid); + } + my $lead = ( _op_is_or_was($op, OP_KVHSLICE) + || _op_is_or_was($op, OP_KVASLICE)) + ? '%' : '@'; + return $lead . $array . $left . $list . $right; +} + +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } +sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } +sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") } + +sub pp_lslice { + my $self = shift; + my($op, $cx) = @_; + my $idx = $op->first; + my $list = $op->last; + my(@elems, $kid); + $list = $self->deparse($list, 1); + $idx = $self->deparse($idx, 1); + return "($list)" . "[$idx]"; +} + +sub want_scalar { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; +} + +sub want_list { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_LIST; +} + +sub _method { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first->sibling; # skip pushmark + my($meth, $obj, @exprs); + if ($kid->name eq "list" and want_list $kid) { + # When an indirect object isn't a bareword but the args are in + # parens, the parens aren't part of the method syntax (the LLAFR + # doesn't apply), but they make a list with OPf_PARENS set that + # doesn't get flattened by the append_elem that adds the method, + # making a (object, arg1, arg2, ...) list where the object + # usually is. This can be distinguished from + # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an + # object) because in the later the list is in scalar context + # as the left side of -> always is, while in the former + # the list is in list context as method arguments always are. + # (Good thing there aren't method prototypes!) + $meth = $kid->sibling; + $kid = $kid->first->sibling; # skip pushmark + $obj = $kid; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $kid; + } + } else { + $obj = $kid; + $kid = $kid->sibling; + for (; !null ($kid->sibling) && $kid->name!~/^method(?:_named)?\z/; + $kid = $kid->sibling) { + push @exprs, $kid + } + $meth = $kid; + } + + if ($meth->name eq "method_named") { + $meth = $self->meth_sv($meth)->PV; + } elsif ($meth->name eq "method_super") { + $meth = "SUPER::".$self->meth_sv($meth)->PV; + } elsif ($meth->name eq "method_redir") { + $meth = $self->meth_rclass_sv($meth)->PV.'::'.$self->meth_sv($meth)->PV; + } elsif ($meth->name eq "method_redir_super") { + $meth = $self->meth_rclass_sv($meth)->PV.'::SUPER::'. + $self->meth_sv($meth)->PV; + } else { + $meth = $meth->first; + if ($meth->name eq "const") { + # As of 5.005_58, this case is probably obsoleted by the + # method_named case above + $meth = $self->const_sv($meth)->PV; # needs to be bare + } + } + + return { method => $meth, variable_method => ref($meth), + object => $obj, args => \@exprs }, + $cx; +} + +# compat function only +sub method { + my $self = shift; + my $info = $self->_method(@_); + return $self->e_method( $self->_method(@_) ); +} + +sub e_method { + my ($self, $info, $cx) = @_; + my $obj = $self->deparse($info->{object}, 24); + + my $meth = $info->{method}; + $meth = $self->deparse($meth, 1) if $info->{variable_method}; + my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); + if ($info->{object}->name eq 'scope' && want_list $info->{object}) { + # method { $object } + # This must be deparsed this way to preserve list context + # of $object. + my $need_paren = $cx >= 6; + return '(' x $need_paren + . $meth . substr($obj,2) # chop off the "do" + . " $args" + . ')' x $need_paren; + } + my $kid = $obj . "->" . $meth; + if (length $args) { + return $kid . "(" . $args . ")"; # parens mandatory + } else { + return $kid; + } +} + +# returns "&" if the prototype doesn't match the args, +# or ("", $args_after_prototype_demunging) if it does. +sub check_proto { + my $self = shift; + return "&" if $self->{'noproto'}; + my($proto, @args) = @_; + my($arg, $real); + my $doneok = 0; + my @reals; + # An unbackslashed @ or % gobbles up the rest of the args + 1 while $proto =~ s/(?deparse($_, 6), @args); + @args = (); + } else { + $arg = shift @args; + last unless $arg; + if ($chr eq "\$" || $chr eq "_") { + if (want_scalar $arg) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "&") { + if ($arg->name =~ /^(s?refgen|undef)$/) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "*") { + if ($arg->name =~ /^s?refgen$/ + and $arg->first->first->name eq "rv2gv") + { + $real = $arg->first->first; # skip refgen, null + if ($real->first->name eq "gv") { + push @reals, $self->deparse($real, 6); + } else { + push @reals, $self->deparse($real->first, 6); + } + } else { + return "&"; + } + } elsif (substr($chr, 0, 1) eq "\\") { + $chr =~ tr/\\[]//d; + if ($arg->name =~ /^s?refgen$/ and + !null($real = $arg->first) and + ($chr =~ /\$/ && is_scalar($real->first) + or ($chr =~ /@/ + && class($real->first->sibling) ne 'NULL' + && $real->first->sibling->name + =~ /^(rv2|pad)av$/) + or ($chr =~ /%/ + && class($real->first->sibling) ne 'NULL' + && $real->first->sibling->name + =~ /^(rv2|pad)hv$/) + #or ($chr =~ /&/ # This doesn't work + # && $real->first->name eq "rv2cv") + or ($chr =~ /\*/ + && $real->first->name eq "rv2gv"))) + { + push @reals, $self->deparse($real, 6); + } else { + return "&"; + } + } + } + } + return "&" if $proto and !$doneok; # too few args and no ';' + return "&" if @args; # too many args + return ("", join ", ", @reals); +} + +sub retscalar { + my $name = $_[0]->name; + # XXX There has to be a better way of doing this scalar-op check. + # Currently PL_opargs is not exposed. + if ($name eq 'null') { + $name = substr B::ppname($_[0]->targ), 3 + } + $name =~ /^(?:scalar|pushmark|wantarray|const|gvsv|gv|padsv|rv2gv + |rv2sv|av2arylen|anoncode|prototype|srefgen|ref|bless + |regcmaybe|regcreset|regcomp|qr|subst|substcont|trans + |transr|sassign|chop|schop|chomp|schomp|defined|undef + |study|pos|preinc|i_preinc|predec|i_predec|postinc + |i_postinc|postdec|i_postdec|pow|multiply|i_multiply + |divide|i_divide|modulo|i_modulo|add|i_add|subtract + |i_subtract|concat|multiconcat|stringify|left_shift|right_shift|lt + |i_lt|gt|i_gt|le|i_le|ge|i_ge|eq|i_eq|ne|i_ne|ncmp|i_ncmp + |slt|sgt|sle|sge|seq|sne|scmp|[sn]?bit_(?:and|x?or)|negate + |i_negate|not|[sn]?complement|smartmatch|atan2|sin|cos + |rand|srand|exp|log|sqrt|int|hex|oct|abs|length|substr + |vec|index|rindex|sprintf|formline|ord|chr|crypt|ucfirst + |lcfirst|uc|lc|quotemeta|aelemfast|aelem|exists|helem + |pack|join|anonlist|anonhash|push|pop|shift|unshift|xor + |andassign|orassign|dorassign|warn|die|reset|nextstate + |dbstate|unstack|last|next|redo|dump|goto|exit|open|close + |pipe_op|fileno|umask|binmode|tie|untie|tied|dbmopen + |dbmclose|select|getc|read|enterwrite|prtf|print|say + |sysopen|sysseek|sysread|syswrite|eof|tell|seek|truncate + |fcntl|ioctl|flock|send|recv|socket|sockpair|bind|connect + |listen|accept|shutdown|gsockopt|ssockopt|getsockname + |getpeername|ftrread|ftrwrite|ftrexec|fteread|ftewrite + |fteexec|ftis|ftsize|ftmtime|ftatime|ftctime|ftrowned + |fteowned|ftzero|ftsock|ftchr|ftblk|ftfile|ftdir|ftpipe + |ftsuid|ftsgid|ftsvtx|ftlink|fttty|fttext|ftbinary|chdir + |chown|chroot|unlink|chmod|utime|rename|link|symlink + |readlink|mkdir|rmdir|open_dir|telldir|seekdir|rewinddir + |closedir|fork|wait|waitpid|system|exec|kill|getppid + |getpgrp|setpgrp|getpriority|setpriority|time|alarm|sleep + |shmget|shmctl|shmread|shmwrite|msgget|msgctl|msgsnd + |msgrcv|semop|semget|semctl|hintseval|shostent|snetent + |sprotoent|sservent|ehostent|enetent|eprotoent|eservent + |spwent|epwent|sgrent|egrent|getlogin|syscall|lock|runcv + |fc)\z/x +} + +sub pp_entersub { + my $self = shift; + my($op, $cx) = @_; + return $self->e_method($self->_method($op, $cx)) + unless null $op->first->sibling; + my $prefix = ""; + my $amper = ""; + my($kid, @exprs); + if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { + $prefix = "do "; + } elsif ($op->private & OPpENTERSUB_AMPER) { + $amper = "&"; + } + $kid = $op->first; + $kid = $kid->first->sibling; # skip ex-list, pushmark + for (; not null $kid->sibling; $kid = $kid->sibling) { + push @exprs, $kid; + } + my $simple = 0; + my $proto = undef; + my $lexical; + if (is_scope($kid)) { + $amper = "&"; + $kid = "{" . $self->deparse($kid, 0) . "}"; + } elsif ($kid->first->name eq "gv") { + my $gv = $self->gv_or_padgv($kid->first); + my $cv; + if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" + || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { + $proto = $cv->PV if $cv->FLAGS & SVf_POK; + } + $simple = 1; # only calls of named functions can be prototyped + $kid = $self->maybe_qualify("!", $self->gv_name($gv)); + my $fq; + # Fully qualify any sub name that conflicts with a lexical. + if ($self->lex_in_scope("&$kid") + || $self->lex_in_scope("&$kid", 1)) + { + $fq++; + } elsif (!$amper) { + if ($kid eq 'main::') { + $kid = '::'; + } + else { + if ($kid !~ /::/ && $kid ne 'x') { + # Fully qualify any sub name that is also a keyword. While + # we could check the import flag, we cannot guarantee that + # the code deparsed so far would set that flag, so we qual- + # ify the names regardless of importation. + if (exists $feature_keywords{$kid}) { + $fq++ if $self->feature_enabled($kid); + } elsif (do { local $@; local $SIG{__DIE__}; + eval { () = prototype "CORE::$kid"; 1 } }) { + $fq++ + } + } + if ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) { + $kid = single_delim("q", "'", $kid, $self) . '->'; + } + } + } + $fq and substr $kid, 0, 0, = $self->{'curstash'}.'::'; + } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { + $amper = "&"; + $kid = $self->deparse($kid, 24); + } else { + $prefix = ""; + my $grandkid = $kid->first; + my $arrow = ($lexical = $grandkid->name eq "padcv") + || is_subscriptable($grandkid) + ? "" + : "->"; + $kid = $self->deparse($kid, 24) . $arrow; + if ($lexical) { + my $padlist = $self->{'curcv'}->PADLIST; + my $padoff = $grandkid->targ; + my $padname = $padlist->ARRAYelt(0)->ARRAYelt($padoff); + my $protocv = $padname->FLAGS & SVpad_STATE + ? $padlist->ARRAYelt(1)->ARRAYelt($padoff) + : $padname->PROTOCV; + if ($protocv->FLAGS & SVf_POK) { + $proto = $protocv->PV + } + $simple = 1; + } + } + + # Doesn't matter how many prototypes there are, if + # they haven't happened yet! + my $declared = $lexical || exists $self->{'subs_declared'}{$kid}; + if (not $declared and $self->{'in_coderef2text'}) { + no strict 'refs'; + no warnings 'uninitialized'; + $declared = + ( + defined &{ ${$self->{'curstash'}."::"}{$kid} } + && !exists + $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} + && defined prototype $self->{'curstash'}."::".$kid + ); + } + if (!$declared && defined($proto)) { + # Avoid "too early to check prototype" warning + ($amper, $proto) = ('&'); + } + + my $args; + my $listargs = 1; + if ($declared and defined $proto and not $amper) { + ($amper, $args) = $self->check_proto($proto, @exprs); + $listargs = $amper; + } + if ($listargs) { + $args = join(", ", map( + ($_->flags & OPf_WANT) == OPf_WANT_SCALAR + && !retscalar($_) + ? $self->maybe_parens_unop('scalar', $_, 6) + : $self->deparse($_, 6), + @exprs + )); + } + if ($prefix or $amper) { + if ($kid eq '&') { $kid = "{$kid}" } # &{&} cannot be written as && + if ($op->flags & OPf_STACKED) { + return $prefix . $amper . $kid . "(" . $args . ")"; + } else { + return $prefix . $amper. $kid; + } + } else { + # It's a syntax error to call CORE::GLOBAL::foo with a prefix, + # so it must have been translated from a keyword call. Translate + # it back. + $kid =~ s/^CORE::GLOBAL:://; + + my $dproto = defined($proto) ? $proto : "undefined"; + my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/; + if (!$declared) { + return "$kid(" . $args . ")"; + } elsif ($dproto =~ /^\s*\z/) { + return $kid; + } elsif ($scalar_proto and is_scalar($exprs[0])) { + # is_scalar is an excessively conservative test here: + # really, we should be comparing to the precedence of the + # top operator of $exprs[0] (ala unop()), but that would + # take some major code restructuring to do right. + return $self->maybe_parens_func($kid, $args, $cx, 16); + } elsif (not $scalar_proto and defined($proto) || $simple) { #' + return $self->maybe_parens_func($kid, $args, $cx, 5); + } else { + return "$kid(" . $args . ")"; + } + } +} + +sub pp_enterwrite { unop(@_, "write") } + +# escape things that cause interpolation in double quotes, +# but not character escapes +sub uninterp { + my($str) = @_; + $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; + return $str; +} + +{ +my $bal; +BEGIN { + use re "eval"; + # Matches any string which is balanced with respect to {braces} + $bal = qr( + (?: + [^\\{}] + | \\\\ + | \\[{}] + | \{(??{$bal})\} + )* + )x; +} + +# the same, but treat $|, $), $( and $ at the end of the string differently +# and leave comments unmangled for the sake of /x and (?x). +sub re_uninterp { + my($str) = @_; + + $str =~ s/ + ( ^|\G # $1 + | [^\\] + ) + + ( # $2 + (?:\\\\)* + ) + + ( # $3 + ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) + | \#[^\n]* # (skip over comments) + ) + | [\$\@] + (?!\||\)|\(|$|\s) + | \\[uUlLQE] + ) + + /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; + + return $str; +} +} + +# character escapes, but not delimiters that might need to be escaped +sub escape_str { # ASCII, UTF8 + my($str) = @_; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/\a/\\a/g; +# $str =~ s/\cH/\\b/g; # \b means something different in a regex; and \cH + # isn't a backspace in EBCDIC + $str =~ s/\t/\\t/g; + $str =~ s/\n/\\n/g; + $str =~ s/\e/\\e/g; + $str =~ s/\f/\\f/g; + $str =~ s/\r/\\r/g; + $str =~ s/([\cA-\cZ])/'\\c' . $unctrl{$1}/ge; + $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/age; + return $str; +} + +# For regexes. Leave whitespace unmangled in case of /x or (?x). +sub escape_re { + my($str) = @_; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/([[:^print:]])/ + ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/age; + $str =~ s/\n/\n\f/g; + return $str; +} + +# Don't do this for regexen +sub unback { + my($str) = @_; + $str =~ s/\\/\\\\/g; + return $str; +} + +# Remove backslashes which precede literal control characters, +# to avoid creating ambiguity when we escape the latter. +# +# Don't remove a backslash from escaped whitespace: where the T represents +# a literal tab character, /T/x is not equivalent to /\T/x + +sub re_unback { + my($str) = @_; + + # the insane complexity here is due to the behaviour of "\c\" + $str =~ s/ + # these two lines ensure that the backslash we're about to + # remove isn't preceeded by something which makes it part + # of a \c + + (^ | [^\\] | \\c\\) # $1 + (?'], ['{','}']) { + ($open, $close) = @$ar; + $fail = 0; $cnt = 0; $last_bs = 0; + for $c (@str) { + if ($c eq $open) { + $fail = 1 if $last_bs; + $cnt++; + } elsif ($c eq $close) { + $fail = 1 if $last_bs; + $cnt--; + if ($cnt < 0) { + # qq()() isn't ")(" + $fail = 1; + last; + } + } + $last_bs = $c eq '\\'; + } + $fail = 1 if $cnt != 0; + return ($open, "$open$str$close") if not $fail; + } + return ("", $str); +} + +sub single_delim { + my($q, $default, $str, $self) = @_; + return "$default$str$default" if $default and index($str, $default) == -1; + my $coreq = $self->keyword($q); # maybe CORE::q + if ($q ne 'qr') { + (my $succeed, $str) = balanced_delim($str); + return "$coreq$str" if $succeed; + } + for my $delim ('/', '"', '#') { + return "$coreq$delim" . $str . $delim if index($str, $delim) == -1; + } + if ($default) { + $str =~ s/$default/\\$default/g; + return "$default$str$default"; + } else { + $str =~ s[/][\\/]g; + return "$coreq/$str/"; + } +} + +my $max_prec; +BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } + +# Split a floating point number into an integer mantissa and a binary +# exponent. Assumes you've already made sure the number isn't zero or +# some weird infinity or NaN. +sub split_float { + my($f) = @_; + my $exponent = 0; + if ($f == int($f)) { + while ($f % 2 == 0) { + $f /= 2; + $exponent++; + } + } else { + while ($f != int($f)) { + $f *= 2; + $exponent--; + } + } + my $mantissa = sprintf("%.0f", $f); + return ($mantissa, $exponent); +} + + +# suitably single- or double-quote a literal constant string + +sub quoted_const_str { + my ($self, $str) =@_; + if ($str =~ /[[:^print:]]/a) { + return single_delim("qq", '"', + uninterp(escape_str unback $str), $self); + } else { + return single_delim("q", "'", unback($str), $self); + } +} + + +sub const { + my $self = shift; + my($sv, $cx) = @_; + if ($self->{'use_dumper'}) { + return $self->const_dumper($sv, $cx); + } + if (class($sv) eq "SPECIAL") { + # sv_undef, sv_yes, sv_no + return $$sv == 3 ? $self->maybe_parens("!1", $cx, 21) + : ('undef', '1')[$$sv-1]; + } + if (class($sv) eq "NULL") { + return 'undef'; + } + # convert a version object into the "v1.2.3" string in its V magic + if ($sv->FLAGS & SVs_RMG) { + for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { + return $mg->PTR if $mg->TYPE eq 'V'; + } + } + + if ($sv->FLAGS & SVf_IOK) { + my $str = $sv->int_value; + $str = $self->maybe_parens($str, $cx, 21) if $str < 0; + return $str; + } elsif ($sv->FLAGS & SVf_NOK) { + my $nv = $sv->NV; + if ($nv == 0) { + if (pack("F", $nv) eq pack("F", 0)) { + # positive zero + return "0"; + } else { + # negative zero + return $self->maybe_parens("-.0", $cx, 21); + } + } elsif (1/$nv == 0) { + if ($nv > 0) { + # positive infinity + return $self->maybe_parens("9**9**9", $cx, 22); + } else { + # negative infinity + return $self->maybe_parens("-9**9**9", $cx, 21); + } + } elsif ($nv != $nv) { + # NaN + if (pack("F", $nv) eq pack("F", sin(9**9**9))) { + # the normal kind + return "sin(9**9**9)"; + } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { + # the inverted kind + return $self->maybe_parens("-sin(9**9**9)", $cx, 21); + } else { + # some other kind + my $hex = unpack("h*", pack("F", $nv)); + return qq'unpack("F", pack("h*", "$hex"))'; + } + } + # first, try the default stringification + my $str = "$nv"; + if ($str != $nv) { + # failing that, try using more precision + $str = sprintf("%.${max_prec}g", $nv); +# if (pack("F", $str) ne pack("F", $nv)) { + if ($str != $nv) { + # not representable in decimal with whatever sprintf() + # and atof() Perl is using here. + my($mant, $exp) = split_float($nv); + return $self->maybe_parens("$mant * 2**$exp", $cx, 19); + } + } + $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; + return $str; + } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { + my $ref = $sv->RV; + my $class = class($ref); + if ($class eq "AV") { + return "[" . $self->list_const(2, $ref->ARRAY) . "]"; + } elsif ($class eq "HV") { + my %hash = $ref->ARRAY; + my @elts; + for my $k (sort keys %hash) { + push @elts, "$k => " . $self->const($hash{$k}, 6); + } + return "{" . join(", ", @elts) . "}"; + } elsif ($class eq "CV") { + no overloading; + if ($self->{curcv} && + $self->{curcv}->object_2svref == $ref->object_2svref) { + return $self->keyword("__SUB__"); + } + return "sub " . $self->deparse_sub($ref); + } + if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) { + for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { + if ($mg->TYPE eq 'r') { + my $re = re_uninterp(escape_re(re_unback($mg->precomp))); + return single_delim("qr", "", $re, $self); + } + } + } + + my $const = $self->const($ref, 20); + if ($self->{in_subst_repl} && $const =~ /^[0-9]/) { + $const = "($const)"; + } + return $self->maybe_parens("\\$const", $cx, 20); + } elsif ($sv->FLAGS & SVf_POK) { + my $str = $sv->PV; + return $self->quoted_const_str($str); + } else { + return "undef"; + } +} + +sub const_dumper { + my $self = shift; + my($sv, $cx) = @_; + my $ref = $sv->object_2svref(); + my $dumper = Data::Dumper->new([$$ref], ['$v']); + $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); + my $str = $dumper->Dump(); + if ($str =~ /^\$v/) { + return '${my ' . $str . ' \$v}'; + } else { + return $str; + } +} + +sub const_sv { + my $self = shift; + my $op = shift; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + +sub meth_sv { + my $self = shift; + my $op = shift; + my $sv = $op->meth_sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + +sub meth_rclass_sv { + my $self = shift; + my $op = shift; + my $sv = $op->rclass; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($sv) unless ref $sv; + return $sv; +} + +sub pp_const { + my $self = shift; + my($op, $cx) = @_; + if ($op->private & OPpCONST_ARYBASE) { + return '$['; + } +# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting +# return $self->const_sv($op)->PV; +# } + my $sv = $self->const_sv($op); + return $self->const($sv, $cx); +} + + +# Join two components of a double-quoted string, disambiguating +# "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" + +sub dq_disambiguate { + my ($first, $last) = @_; + ($last =~ /^[A-Z\\\^\[\]_?]/ && + $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc + || ($last =~ /^[:'{\[\w_]/ && #' + $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); + return $first . $last; +} + + +# Deparse a double-quoted optree. For example, "$a[0]\Q$b\Efo\"o" gets +# compiled to concat(concat($[0],quotemeta($b)),const("fo\"o")), and this +# sub deparses it back to $a[0]\Q$b\Efo"o +# (It does not add delimiters) + +sub dq { + my $self = shift; + my $op = shift; + my $type = $op->name; + if ($type eq "const") { + return '$[' if $op->private & OPpCONST_ARYBASE; + return uninterp(escape_str(unback($self->const_sv($op)->as_string))); + } elsif ($type eq "concat") { + return dq_disambiguate($self->dq($op->first), $self->dq($op->last)); + } elsif ($type eq "multiconcat") { + return $self->do_multiconcat($op, 26, 1); + } elsif ($type eq "uc") { + return '\U' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "lc") { + return '\L' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "ucfirst") { + return '\u' . $self->dq($op->first->sibling); + } elsif ($type eq "lcfirst") { + return '\l' . $self->dq($op->first->sibling); + } elsif ($type eq "quotemeta") { + return '\Q' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "fc") { + return '\F' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + return $self->deparse($op, 26); + } +} + +sub pp_backtick { + my $self = shift; + my($op, $cx) = @_; + # skip pushmark if it exists (readpipe() vs ``) + my $child = $op->first->sibling->isa('B::NULL') + ? $op->first : $op->first->sibling; + if ($self->pure_string($child)) { + return single_delim("qx", '`', $self->dq($child, 1), $self); + } + unop($self, @_, "readpipe"); +} + +sub dquote { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first->sibling; # skip ex-stringify, pushmark + return $self->deparse($kid, $cx) if $self->{'unquote'}; + $self->maybe_targmy($kid, $cx, + sub {single_delim("qq", '"', $self->dq($_[1]), + $self)}); +} + +# OP_STRINGIFY is a listop, but it only ever has one arg +sub pp_stringify { + my ($self, $op, $cx) = @_; + my $kid = $op->first->sibling; + while ($kid->name eq 'null' && !null($kid->first)) { + $kid = $kid->first; + } + if ($kid->name =~ /^(?:const|padsv|rv2sv|av2arylen|gvsv|multideref + |aelemfast(?:_lex)?|[ah]elem|join|concat)\z/x) { + maybe_targmy(@_, \&dquote); + } + else { + # Actually an optimised join. + my $result = listop(@_,"join"); + $result =~ s/join([( ])/join$1$self->{'ex_const'}, /; + $result; + } +} + +# tr/// and s/// (and tr[][], tr[]//, tr###, etc) +# note that tr(from)/to/ is OK, but not tr/from/(to) +sub double_delim { + my($from, $to) = @_; + my($succeed, $delim); + if ($from !~ m[/] and $to !~ m[/]) { + return "/$from/$to/"; + } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { + if (($succeed, $to) = balanced_delim($to) and $succeed) { + return "$from$to"; + } else { + for $delim ('/', '"', '#') { # note no "'" -- s''' is special + return "$from$delim$to$delim" if index($to, $delim) == -1; + } + $to =~ s[/][\\/]g; + return "$from/$to/"; + } + } else { + for $delim ('/', '"', '#') { # note no ' + return "$delim$from$delim$to$delim" + if index($to . $from, $delim) == -1; + } + $from =~ s[/][\\/]g; + $to =~ s[/][\\/]g; + return "/$from/$to/"; + } +} + +# Escape a characrter. +# Only used by tr///, so backslashes hyphens + +sub pchr { # ASCII + my($n) = @_; + if ($n == ord '\\') { + return '\\\\'; + } elsif ($n == ord "-") { + return "\\-"; + } elsif (utf8::native_to_unicode($n) >= utf8::native_to_unicode(ord(' ')) + and utf8::native_to_unicode($n) <= utf8::native_to_unicode(ord('~'))) + { + # I'm presuming a regex is not ok here, otherwise we could have used + # /[[:print:]]/a to get here + return chr($n); + } elsif ($n == ord "\a") { + return '\\a'; + } elsif ($n == ord "\b") { + return '\\b'; + } elsif ($n == ord "\t") { + return '\\t'; + } elsif ($n == ord "\n") { + return '\\n'; + } elsif ($n == ord "\e") { + return '\\e'; + } elsif ($n == ord "\f") { + return '\\f'; + } elsif ($n == ord "\r") { + return '\\r'; + } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { + return '\\c' . $unctrl{chr $n}; + } else { +# return '\x' . sprintf("%02x", $n); + return '\\' . sprintf("%03o", $n); + } +} + +# Convert a list of characters into a string suitable for tr/// search or +# replacement, with suitable escaping and collapsing of ranges + +sub collapse { + my(@chars) = @_; + my($str, $c, $tr) = (""); + for ($c = 0; $c < @chars; $c++) { + $tr = $chars[$c]; + $str .= pchr($tr); + if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and + $chars[$c + 2] == $tr + 2) + { + for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) + {} + $str .= "-"; + $str .= pchr($chars[$c]); + } + } + return $str; +} + +sub tr_decode_byte { + my($table, $flags) = @_; + my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l'; + my ($size, @table) = unpack("${ssize_t}s*", $table); + pop @table; # remove the wildcard final entry + + my($c, $tr, @from, @to, @delfrom, $delhyphen); + if ($table[ord "-"] != -1 and + $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) + { + $tr = $table[ord "-"]; + $table[ord "-"] = -1; + if ($tr >= 0) { + @from = ord("-"); + @to = $tr; + } else { # -2 ==> delete + $delhyphen = 1; + } + } + for ($c = 0; $c < @table; $c++) { + $tr = $table[$c]; + if ($tr >= 0) { + push @from, $c; push @to, $tr; + } elsif ($tr == -2) { + push @delfrom, $c; + } + } + @from = (@from, @delfrom); + + if ($flags & OPpTRANS_COMPLEMENT) { + unless ($flags & OPpTRANS_DELETE) { + @to = () if ("@from" eq "@to"); + } + + my @newfrom = (); + my %from; + @from{@from} = (1) x @from; + for ($c = 0; $c < 256; $c++) { + push @newfrom, $c unless $from{$c}; + } + @from = @newfrom; + } + unless ($flags & OPpTRANS_DELETE || !@to) { + pop @to while $#to and $to[$#to] == $to[$#to -1]; + } + my($from, $to); + $from = collapse(@from); + $to = collapse(@to); + $from .= "-" if $delhyphen; + return ($from, $to); +} + +sub tr_chr { + my $x = shift; + if ($x == ord "-") { + return "\\-"; + } elsif ($x == ord "\\") { + return "\\\\"; + } else { + return chr $x; + } +} + +# XXX This doesn't yet handle all cases correctly either + +sub tr_decode_utf8 { + my($swash_hv, $flags) = @_; + my %swash = $swash_hv->ARRAY; + my $final = undef; + $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; + my $none = $swash{"NONE"}->IV; + my $extra = $none + 1; + my(@from, @delfrom, @to); + my $line; + foreach $line (split /\n/, $swash{'LIST'}->PV) { + my($min, $max, $result) = split(/\t/, $line); + $min = hex $min; + if (length $max) { + $max = hex $max; + } else { + $max = $min; + } + $result = hex $result; + if ($result == $extra) { + push @delfrom, [$min, $max]; + } else { + push @from, [$min, $max]; + push @to, [$result, $result + $max - $min]; + } + } + for my $i (0 .. $#from) { + if ($from[$i][0] == ord '-') { + unshift @from, splice(@from, $i, 1); + unshift @to, splice(@to, $i, 1); + last; + } elsif ($from[$i][1] == ord '-') { + $from[$i][1]--; + $to[$i][1]--; + unshift @from, ord '-'; + unshift @to, ord '-'; + last; + } + } + for my $i (0 .. $#delfrom) { + if ($delfrom[$i][0] == ord '-') { + push @delfrom, splice(@delfrom, $i, 1); + last; + } elsif ($delfrom[$i][1] == ord '-') { + $delfrom[$i][1]--; + push @delfrom, ord '-'; + last; + } + } + if (defined $final and $to[$#to][1] != $final) { + push @to, [$final, $final]; + } + push @from, @delfrom; + if ($flags & OPpTRANS_COMPLEMENT) { + my @newfrom; + my $next = 0; + for my $i (0 .. $#from) { + push @newfrom, [$next, $from[$i][0] - 1]; + $next = $from[$i][1] + 1; + } + @from = (); + for my $range (@newfrom) { + if ($range->[0] <= $range->[1]) { + push @from, $range; + } + } + } + my($from, $to, $diff); + for my $chunk (@from) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $from .= tr_chr($chunk->[0]); + } + } + for my $chunk (@to) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $to .= tr_chr($chunk->[0]); + } + } + #$final = sprintf("%04x", $final) if defined $final; + #$none = sprintf("%04x", $none) if defined $none; + #$extra = sprintf("%04x", $extra) if defined $extra; + #print STDERR "final: $final\n none: $none\nextra: $extra\n"; + #print STDERR $swash{'LIST'}->PV; + return (escape_str($from), escape_str($to)); +} + +sub pp_trans { + my $self = shift; + my($op, $cx, $morflags) = @_; + my($from, $to); + my $class = class($op); + my $priv_flags = $op->private; + if ($class eq "PVOP") { + ($from, $to) = tr_decode_byte($op->pv, $priv_flags); + } elsif ($class eq "PADOP") { + ($from, $to) + = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags); + } else { # class($op) eq "SVOP" + ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags); + } + my $flags = ""; + $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT; + $flags .= "d" if $priv_flags & OPpTRANS_DELETE; + $to = "" if $from eq $to and $flags eq ""; + $flags .= "s" if $priv_flags & OPpTRANS_SQUASH; + $flags .= $morflags if defined $morflags; + my $ret = $self->keyword("tr") . double_delim($from, $to) . $flags; + if (my $targ = $op->targ) { + return $self->maybe_parens($self->padname($targ) . " =~ $ret", + $cx, 20); + } + return $ret; +} + +sub pp_transr { push @_, 'r'; goto &pp_trans } + +# Join two components of a double-quoted re, disambiguating +# "${foo}bar", "${foo}{bar}", "${foo}[1]". + +sub re_dq_disambiguate { + my ($first, $last) = @_; + ($last =~ /^[A-Z\\\^\[\]_?]/ && + $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc + || ($last =~ /^[{\[\w_]/ && + $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); + return $first . $last; +} + +# Like dq(), but different +sub re_dq { + my $self = shift; + my ($op) = @_; + + my $type = $op->name; + if ($type eq "const") { + return '$[' if $op->private & OPpCONST_ARYBASE; + my $unbacked = re_unback($self->const_sv($op)->as_string); + return re_uninterp(escape_re($unbacked)); + } elsif ($type eq "concat") { + my $first = $self->re_dq($op->first); + my $last = $self->re_dq($op->last); + return re_dq_disambiguate($first, $last); + } elsif ($type eq "multiconcat") { + return $self->do_multiconcat($op, 26, 2); + } elsif ($type eq "uc") { + return '\U' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "lc") { + return '\L' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "ucfirst") { + return '\u' . $self->re_dq($op->first->sibling); + } elsif ($type eq "lcfirst") { + return '\l' . $self->re_dq($op->first->sibling); + } elsif ($type eq "quotemeta") { + return '\Q' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "fc") { + return '\F' . $self->re_dq($op->first->sibling) . '\E'; + } elsif ($type eq "join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + my $ret = $self->deparse($op, 26); + $ret =~ s/^\$([(|)])\z/\${$1}/ # $( $| $) need braces + or $ret =~ s/^\@([-+])\z/\@{$1}/; # @- @+ need braces + return $ret; + } +} + +sub pure_string { + my ($self, $op) = @_; + return 0 if null $op; + my $type = $op->name; + + if ($type eq 'const' || $type eq 'av2arylen') { + return 1; + } + elsif ($type =~ /^(?:[ul]c(first)?|fc)$/ || $type eq 'quotemeta') { + return $self->pure_string($op->first->sibling); + } + elsif ($type eq 'join') { + my $join_op = $op->first->sibling; # Skip pushmark + return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV; + + my $gvop = $join_op->first; + return 0 unless $gvop->name eq 'gvsv'; + return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); + + return 0 unless ${$join_op->sibling} eq ${$op->last}; + return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/; + } + elsif ($type eq 'concat') { + return $self->pure_string($op->first) + && $self->pure_string($op->last); + } + elsif ($type eq 'multiconcat') { + my ($kid, @kids); + for ($kid = $op->first; !null $kid; $kid = $kid->sibling) { + # skip the consts and/or padsv we've optimised away + push @kids, $kid + unless $kid->type == OP_NULL + && ( $kid->targ == OP_PADSV + || $kid->targ == OP_CONST + || $kid->targ == OP_PUSHMARK); + } + + if ($op->flags & OPf_STACKED) { + # remove expr from @kids where 'expr = ...' or 'expr .= ....' + if ($op->private & OPpMULTICONCAT_APPEND) { + shift(@kids); + } + else { + pop(@kids); + } + } + for (@kids) { + return 0 unless $self->pure_string($_); + } + return 1; + } + elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { + return 1; + } + elsif ($type eq "null" and $op->can('first') and not null $op->first) { + my $first = $op->first; + + return 1 if $first->name eq "multideref"; + return 1 if $first->name eq "aelemfast_lex"; + + if ( $first->name eq "null" + and $first->can('first') + and not null $first->first + and $first->first->name eq "aelemfast" + ) + { + return 1; + } + } + + return 0; +} + +sub code_list { + my ($self,$op,$cv) = @_; + + # localise stuff relating to the current sub + $cv and + local($self->{'curcv'}) = $cv, + local($self->{'curcvlex'}), + local(@$self{qw'curstash warnings hints hinthash curcop'}) + = @$self{qw'curstash warnings hints hinthash curcop'}; + + my $re; + for ($op = $op->first->sibling; !null($op); $op = $op->sibling) { + if ($op->name eq 'null' and $op->flags & OPf_SPECIAL) { + my $scope = $op->first; + # 0 context (last arg to scopeop) means statement context, so + # the contents of the block will not be wrapped in do{...}. + my $block = scopeop($scope->first->name eq "enter", $self, + $scope, 0); + # next op is the source code of the block + $op = $op->sibling; + $re .= ($self->const_sv($op)->PV =~ m|^(\(\?\??\{)|)[0]; + my $multiline = $block =~ /\n/; + $re .= $multiline ? "\n\t" : ' '; + $re .= $block; + $re .= $multiline ? "\n\b})" : " })"; + } else { + $re = re_dq_disambiguate($re, $self->re_dq($op)); + } + } + $re; +} + +sub regcomp { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + $kid = $kid->first if $kid->name eq "regcmaybe"; + $kid = $kid->first if $kid->name eq "regcreset"; + my $kname = $kid->name; + if ($kname eq "null" and !null($kid->first) + and $kid->first->name eq 'pushmark') + { + my $str = ''; + $kid = $kid->first->sibling; + while (!null($kid)) { + my $first = $str; + my $last = $self->re_dq($kid); + $str = re_dq_disambiguate($first, $last); + $kid = $kid->sibling; + } + return $str, 1; + } + + return ($self->re_dq($kid), 1) + if $kname =~ /^(?:rv2|pad)av/ or $self->pure_string($kid); + return ($self->deparse($kid, $cx), 0); +} + +sub pp_regcomp { + my ($self, $op, $cx) = @_; + return (($self->regcomp($op, $cx, 0))[0]); +} + +sub re_flags { + my ($self, $op) = @_; + my $flags = ''; + my $pmflags = $op->pmflags; + if (!$pmflags) { + my $re = $op->pmregexp; + if ($$re) { + $pmflags = $re->compflags; + } + } + $flags .= "g" if $pmflags & PMf_GLOBAL; + $flags .= "i" if $pmflags & PMf_FOLD; + $flags .= "m" if $pmflags & PMf_MULTILINE; + $flags .= "o" if $pmflags & PMf_KEEP; + $flags .= "s" if $pmflags & PMf_SINGLELINE; + $flags .= "x" if $pmflags & PMf_EXTENDED; + $flags .= "x" if $pmflags & PMf_EXTENDED_MORE; + $flags .= "p" if $pmflags & PMf_KEEPCOPY; + $flags .= "n" if $pmflags & PMf_NOCAPTURE; + if (my $charset = $pmflags & PMf_CHARSET) { + # Hardcoding this is fragile, but B does not yet export the + # constants we need. + $flags .= qw(d l u a aa)[$charset >> 7] + } + # The /d flag is indicated by 0; only show it if necessary. + elsif ($self->{hinthash} and + $self->{hinthash}{reflags_charset} + || $self->{hinthash}{feature_unicode} + or $self->{hints} & $feature::hint_mask + && ($self->{hints} & $feature::hint_mask) + != $feature::hint_mask + && $self->{hints} & $feature::hint_uni8bit + ) { + $flags .= 'd'; + } + $flags; +} + +# osmic acid -- see osmium tetroxide + +my %matchwords; +map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', + 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', + 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi', 'soup', 'soupmix'); + +# When deparsing a regular expression with code blocks, we have to look in +# various places to find the blocks. +# +# For qr/(?{...})/ without interpolation, the CV is under $qr->qr_anoncv +# and the code list (list of blocks and constants, maybe vars) is under +# $cv->ROOT->first->code_list: +# ./perl -Ilib -MB -e 'use O "Concise", B::svref_2object(sub {qr/(?{die})/})->ROOT->first->first->sibling->pmregexp->qr_anoncv->object_2svref' +# +# For qr/$a(?{...})/ with interpolation, the code list is more accessible, +# under $pmop->code_list, but the $cv is something you have to dig for in +# the regcomp op’s kids: +# ./perl -Ilib -mO=Concise -e 'qr/$a(?{die})/' +# +# For m// and split //, things are much simpler. There is no CV. The code +# list is under $pmop->code_list. + +sub matchop { + my $self = shift; + my($op, $cx, $name, $delim) = @_; + my $kid = $op->first; + my ($binop, $var, $re) = ("", "", ""); + if ($op->name ne 'split' && $op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + # not $name; $name will be 'm' for both match and split + elsif ($op->name eq 'match' and my $targ = $op->targ) { + $binop = 1; + $var = $self->padname($targ); + } + my $quote = 1; + my $pmflags = $op->pmflags; + my $rhs_bound_to_defsv; + my ($cv, $bregexp); + my $have_kid = !null $kid; + # Check for code blocks first + if (not null my $code_list = $op->code_list) { + $re = $self->code_list($code_list, + $op->name eq 'qr' + ? $self->padval( + $kid->first # ex-list + ->first # pushmark + ->sibling # entersub + ->first # ex-list + ->first # pushmark + ->sibling # srefgen + ->first # ex-list + ->first # anoncode + ->targ + ) + : undef); + } elsif (${$bregexp = $op->pmregexp} && ${$cv = $bregexp->qr_anoncv}) { + my $patop = $cv->ROOT # leavesub + ->first # qr + ->code_list;# list + $re = $self->code_list($patop, $cv); + } elsif (!$have_kid) { + $re = re_uninterp(escape_re(re_unback($op->precomp))); + } elsif ($kid->name ne 'regcomp') { + if ($op->name eq 'split') { + # split has other kids, not just regcomp + $re = re_uninterp(escape_re(re_unback($op->precomp))); + } + else { + carp("found ".$kid->name." where regcomp expected"); + } + } else { + ($re, $quote) = $self->regcomp($kid, 21); + } + if ($have_kid and $kid->name eq 'regcomp') { + my $matchop = $kid->first; + if ($matchop->name eq 'regcreset') { + $matchop = $matchop->first; + } + if ($matchop->name =~ /^(?:match|transr?|subst)\z/ + && $matchop->flags & OPf_SPECIAL) { + $rhs_bound_to_defsv = 1; + } + } + my $flags = ""; + $flags .= "c" if $pmflags & PMf_CONTINUE; + $flags .= $self->re_flags($op); + $flags = join '', sort split //, $flags; + $flags = $matchwords{$flags} if $matchwords{$flags}; + if ($pmflags & PMf_ONCE) { # only one kind of delimiter works here + $re =~ s/\?/\\?/g; + $re = $self->keyword("m") . "?$re?"; # explicit 'm' is required + } elsif ($quote) { + $re = single_delim($name, $delim, $re, $self); + } + $re = $re . $flags if $quote; + if ($binop) { + return + $self->maybe_parens( + $rhs_bound_to_defsv + ? "$var =~ (\$_ =~ $re)" + : "$var =~ $re", + $cx, 20 + ); + } else { + return $re; + } +} + +sub pp_match { matchop(@_, "m", "/") } +sub pp_qr { matchop(@_, "qr", "") } + +sub pp_runcv { unop(@_, "__SUB__"); } + +sub pp_split { + my $self = shift; + my($op, $cx) = @_; + my($kid, @exprs, $ary, $expr); + my $stacked = $op->flags & OPf_STACKED; + + $kid = $op->first; + $kid = $kid->sibling if $kid->name eq 'regcomp'; + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + + unshift @exprs, $self->matchop($op, $cx, "m", "/"); + + if ($op->private & OPpSPLIT_ASSIGN) { + # With C<@array = split(/pat/, str);>, + # array is stored in split's pmreplroot; either + # as an integer index into the pad (for a lexical array) + # or as GV for a package array (which will be a pad index + # on threaded builds) + # With my/our @array = split(/pat/, str), the array is instead + # accessed via an extra padav/rv2av op at the end of the + # split's kid ops. + + if ($stacked) { + $ary = pop @exprs; + } + else { + if ($op->private & OPpSPLIT_LEX) { + $ary = $self->padname($op->pmreplroot); + } + else { + # union with op_pmtargetoff, op_pmtargetgv + my $gv = $op->pmreplroot; + $gv = $self->padval($gv) if !ref($gv); + $ary = $self->maybe_local(@_, + $self->stash_variable('@', + $self->gv_name($gv), + $cx)) + } + if ($op->private & OPpLVAL_INTRO) { + $ary = $op->private & OPpSPLIT_LEX ? "my $ary" : "local $ary"; + } + } + } + + # handle special case of split(), and split(' ') that compiles to /\s+/ + $exprs[0] = q{' '} if ($op->reflags // 0) & RXf_SKIPWHITE(); + + $expr = "split(" . join(", ", @exprs) . ")"; + if ($ary) { + return $self->maybe_parens("$ary = $expr", $cx, 7); + } else { + return $expr; + } +} + +# oxime -- any of various compounds obtained chiefly by the action of +# hydroxylamine on aldehydes and ketones and characterized by the +# bivalent grouping C=NOH [Webster's Tenth] + +my %substwords; +map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', + 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', + 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', + 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi', 'rogue', + 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime', + 'or', 'rose', 'rosie'); + +sub pp_subst { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + my($binop, $var, $re, $repl) = ("", "", "", ""); + if ($op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + elsif (my $targ = $op->targ) { + $binop = 1; + $var = $self->padname($targ); + } + my $flags = ""; + my $pmflags = $op->pmflags; + if (null($op->pmreplroot)) { + $repl = $kid; + $kid = $kid->sibling; + } else { + $repl = $op->pmreplroot->first; # skip substcont + } + while ($repl->name eq "entereval") { + $repl = $repl->first; + $flags .= "e"; + } + { + local $self->{in_subst_repl} = 1; + if ($pmflags & PMf_EVAL) { + $repl = $self->deparse($repl->first, 0); + } else { + $repl = $self->dq($repl); + } + } + if (not null my $code_list = $op->code_list) { + $re = $self->code_list($code_list); + } elsif (null $kid) { + $re = re_uninterp(escape_re(re_unback($op->precomp))); + } else { + ($re) = $self->regcomp($kid, 1); + } + $flags .= "r" if $pmflags & PMf_NONDESTRUCT; + $flags .= "e" if $pmflags & PMf_EVAL; + $flags .= $self->re_flags($op); + $flags = join '', sort split //, $flags; + $flags = $substwords{$flags} if $substwords{$flags}; + my $core_s = $self->keyword("s"); # maybe CORE::s + if ($binop) { + return $self->maybe_parens("$var =~ $core_s" + . double_delim($re, $repl) . $flags, + $cx, 20); + } else { + return "$core_s". double_delim($re, $repl) . $flags; + } +} + +sub is_lexical_subs { + my (@ops) = shift; + for my $op (@ops) { + return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/; + } + return 1; +} + +# Pretend these two ops do not exist. The perl parser adds them to the +# beginning of any block containing my-sub declarations, whereas we handle +# the subs in pad_subs and next_todo. +*pp_clonecv = *pp_introcv; +sub pp_introcv { + my $self = shift; + my($op, $cx) = @_; + # For now, deparsing doesn't worry about the distinction between introcv + # and clonecv, so pretend this op doesn't exist: + return ''; +} + +sub pp_padcv { + my $self = shift; + my($op, $cx) = @_; + return $self->padany($op); +} + +my %lvref_funnies = ( + OPpLVREF_SV, => '$', + OPpLVREF_AV, => '@', + OPpLVREF_HV, => '%', + OPpLVREF_CV, => '&', +); + +sub pp_refassign { + my ($self, $op, $cx) = @_; + my $left; + if ($op->private & OPpLVREF_ELEM) { + $left = $op->first->sibling; + $left = maybe_local(@_, elem($self, $left, undef, + $left->targ == OP_AELEM + ? qw([ ] padav) + : qw({ } padhv))); + } elsif ($op->flags & OPf_STACKED) { + $left = maybe_local(@_, + $lvref_funnies{$op->private & OPpLVREF_TYPE} + . $self->deparse($op->first->sibling)); + } else { + $left = &pp_padsv; + } + my $right = $self->deparse_binop_right($op, $op->first, 7); + return $self->maybe_parens("\\$left = $right", $cx, 7); +} + +sub pp_lvref { + my ($self, $op, $cx) = @_; + my $code; + if ($op->private & OPpLVREF_ELEM) { + $code = $op->first->name =~ /av\z/ ? &pp_aelem : &pp_helem; + } elsif ($op->flags & OPf_STACKED) { + $code = maybe_local(@_, + $lvref_funnies{$op->private & OPpLVREF_TYPE} + . $self->deparse($op->first)); + } else { + $code = &pp_padsv; + } + "\\$code"; +} + +sub pp_lvrefslice { + my ($self, $op, $cx) = @_; + '\\' . ($op->last->name =~ /av\z/ ? &pp_aslice : &pp_hslice); +} + +sub pp_lvavref { + my ($self, $op, $cx) = @_; + '\\(' . ($op->flags & OPf_STACKED + ? maybe_local(@_, rv2x(@_, "\@")) + : &pp_padsv) . ')' +} + + +sub pp_argcheck { + my $self = shift; + my($op, $cx) = @_; + my ($params, $opt_params, $slurpy) = $op->aux_list($self->{curcv}); + my $mandatory = $params - $opt_params; + my $check = ''; + + $check .= < 0; +die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $mandatory; +EOF + + my $cond = ($params & 1) ? 'unless' : 'if'; + $check .= < $params && ((\@_ - $params) & 1); +EOF + + $check =~ s/;\n\z//; + return $check; +} + + +sub pp_argelem { + my $self = shift; + my($op, $cx) = @_; + my $var = $self->padname($op->targ); + my $ix = $op->string($self->{curcv}); + my $expr; + if ($op->flags & OPf_KIDS) { + $expr = $self->deparse($op->first, 7); + } + elsif ($var =~ /^[@%]/) { + $expr = $ix ? "\@_[$ix .. \$#_]" : '@_'; + } + else { + $expr = "\$_[$ix]"; + } + return "my $var = $expr"; +} + + +sub pp_argdefelem { + my $self = shift; + my($op, $cx) = @_; + my $ix = $op->targ; + my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : "; + my $def = $self->deparse($op->first, 7); + $def = "($def)" if $op->first->flags & OPf_PARENS; + $expr .= $self->deparse($op->first, $cx); + return $expr; +} + + +1; +__END__ + +# -*- buffer-read-only: t -*- +# +# lib/B/Op_private.pm +# +# Copyright (C) 2014 by Larry Wall and others +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by regen/opcode.pl from data in +# regen/op_private and pod embedded in regen/opcode.pl. +# Any changes made here will be lost! + + +package B::Op_private; + +our %bits; + + +our $VERSION = "5.028001"; + +$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); +$bits{$_}{6} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); +$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv); +$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop); +$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite); +$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv); +$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); +$bits{$_}{6} = 'OPpINDEX_BOOLNEG' for qw(index rindex); +$bits{$_}{1} = 'OPpITER_REVERSED' for qw(enteriter iter); +$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop); +$bits{$_}{6} = 'OPpLVAL_DEFER' for qw(aelem helem multideref); +$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split); +$bits{$_}{2} = 'OPpLVREF_ELEM' for qw(lvref refassign); +$bits{$_}{3} = 'OPpLVREF_ITER' for qw(lvref refassign); +$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec); +$bits{$_}{4} = 'OPpMAYBE_TRUEBOOL' for qw(padhv ref rv2hv); +$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray); +$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open); +$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open); +$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open); +$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open); +$bits{$_}{6} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv split); +$bits{$_}{6} = 'OPpPAD_STATE' for qw(lvavref lvref padav padhv padsv pushmark refassign); +$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo); +$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite); +$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv); +$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid); +$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr); +$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr); +$bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr); +$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr); +$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr); +$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr); +$bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr); +$bits{$_}{5} = 'OPpTRUEBOOL' for qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst); + +my @bf = ( + { + label => '-', + mask_def => 'OPpARG1_MASK', + bitmin => 0, + bitmax => 0, + bitmask => 1, + }, + { + label => '-', + mask_def => 'OPpARG2_MASK', + bitmin => 0, + bitmax => 1, + bitmask => 3, + }, + { + label => 'offset', + mask_def => 'OPpAVHVSWITCH_MASK', + bitmin => 0, + bitmax => 1, + bitmask => 3, + }, + { + label => '-', + mask_def => 'OPpARG3_MASK', + bitmin => 0, + bitmax => 2, + bitmask => 7, + }, + { + label => '-', + mask_def => 'OPpARG4_MASK', + bitmin => 0, + bitmax => 3, + bitmask => 15, + }, + { + label => 'range', + mask_def => 'OPpPADRANGE_COUNTMASK', + bitcount_def => 'OPpPADRANGE_COUNTSHIFT', + bitmin => 0, + bitmax => 6, + bitmask => 127, + }, + { + label => 'key', + bitmin => 0, + bitmax => 7, + bitmask => 255, + }, + { + mask_def => 'OPpARGELEM_MASK', + bitmin => 1, + bitmax => 2, + bitmask => 6, + enum => [ + 0, 'OPpARGELEM_SV', 'SV', + 1, 'OPpARGELEM_AV', 'AV', + 2, 'OPpARGELEM_HV', 'HV', + ], + }, + { + mask_def => 'OPpDEREF', + bitmin => 4, + bitmax => 5, + bitmask => 48, + enum => [ + 1, 'OPpDEREF_AV', 'DREFAV', + 2, 'OPpDEREF_HV', 'DREFHV', + 3, 'OPpDEREF_SV', 'DREFSV', + ], + }, + { + mask_def => 'OPpLVREF_TYPE', + bitmin => 4, + bitmax => 5, + bitmask => 48, + enum => [ + 0, 'OPpLVREF_SV', 'SV', + 1, 'OPpLVREF_AV', 'AV', + 2, 'OPpLVREF_HV', 'HV', + 3, 'OPpLVREF_CV', 'CV', + ], + }, +); + +@{$bits{aassign}}{6,5,4,2,1,0} = ('OPpASSIGN_COMMON_SCALAR', 'OPpASSIGN_COMMON_RC1', 'OPpASSIGN_COMMON_AGG', 'OPpASSIGN_TRUEBOOL', $bf[1], $bf[1]); +$bits{abs}{0} = $bf[0]; +@{$bits{accept}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{add}}{1,0} = ($bf[1], $bf[1]); +$bits{aeach}{0} = $bf[0]; +@{$bits{aelem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]); +@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]); +@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6], $bf[6]); +$bits{akeys}{0} = $bf[0]; +$bits{alarm}{0} = $bf[0]; +$bits{and}{0} = $bf[0]; +$bits{andassign}{0} = $bf[0]; +$bits{anonconst}{0} = $bf[0]; +@{$bits{anonhash}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{anonlist}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{argcheck}{0} = $bf[0]; +$bits{argdefelem}{0} = $bf[0]; +@{$bits{argelem}}{2,1,0} = ($bf[7], $bf[7], $bf[0]); +@{$bits{atan2}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{av2arylen}{0} = $bf[0]; +$bits{avalues}{0} = $bf[0]; +@{$bits{avhvswitch}}{1,0} = ($bf[2], $bf[2]); +$bits{backtick}{0} = $bf[0]; +@{$bits{bind}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{binmode}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bless}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{caller}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{chdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{chmod}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{chomp}{0} = $bf[0]; +$bits{chop}{0} = $bf[0]; +@{$bits{chown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{chr}{0} = $bf[0]; +$bits{chroot}{0} = $bf[0]; +@{$bits{close}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{closedir}{0} = $bf[0]; +$bits{complement}{0} = $bf[0]; +@{$bits{concat}}{6,1,0} = ('OPpCONCAT_NESTED', $bf[1], $bf[1]); +$bits{cond_expr}{0} = $bf[0]; +@{$bits{connect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER'); +@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1'); +$bits{cos}{0} = $bf[0]; +@{$bits{crypt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{dbmclose}{0} = $bf[0]; +@{$bits{dbmopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{defined}{0} = $bf[0]; +@{$bits{delete}}{6,5,0} = ('OPpSLICE', 'OPpKVSLICE', $bf[0]); +@{$bits{die}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{divide}}{1,0} = ($bf[1], $bf[1]); +$bits{dofile}{0} = $bf[0]; +$bits{dor}{0} = $bf[0]; +$bits{dorassign}{0} = $bf[0]; +$bits{dump}{0} = $bf[0]; +$bits{each}{0} = $bf[0]; +@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]); +$bits{entergiven}{0} = $bf[0]; +$bits{enteriter}{3} = 'OPpITER_DEF'; +@{$bits{entersub}}{5,4,0} = ($bf[8], $bf[8], 'OPpENTERSUB_INARGS'); +$bits{entertry}{0} = $bf[0]; +$bits{enterwhen}{0} = $bf[0]; +@{$bits{enterwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{eof}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{eq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{exec}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]); +@{$bits{exit}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{exp}{0} = $bf[0]; +$bits{fc}{0} = $bf[0]; +@{$bits{fcntl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{fileno}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{flip}{0} = $bf[0]; +@{$bits{flock}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{flop}{0} = $bf[0]; +@{$bits{formline}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{ftatime}{0} = $bf[0]; +$bits{ftbinary}{0} = $bf[0]; +$bits{ftblk}{0} = $bf[0]; +$bits{ftchr}{0} = $bf[0]; +$bits{ftctime}{0} = $bf[0]; +$bits{ftdir}{0} = $bf[0]; +$bits{fteexec}{0} = $bf[0]; +$bits{fteowned}{0} = $bf[0]; +$bits{fteread}{0} = $bf[0]; +$bits{ftewrite}{0} = $bf[0]; +$bits{ftfile}{0} = $bf[0]; +$bits{ftis}{0} = $bf[0]; +$bits{ftlink}{0} = $bf[0]; +$bits{ftmtime}{0} = $bf[0]; +$bits{ftpipe}{0} = $bf[0]; +$bits{ftrexec}{0} = $bf[0]; +$bits{ftrowned}{0} = $bf[0]; +$bits{ftrread}{0} = $bf[0]; +$bits{ftrwrite}{0} = $bf[0]; +$bits{ftsgid}{0} = $bf[0]; +$bits{ftsize}{0} = $bf[0]; +$bits{ftsock}{0} = $bf[0]; +$bits{ftsuid}{0} = $bf[0]; +$bits{ftsvtx}{0} = $bf[0]; +$bits{fttext}{0} = $bf[0]; +$bits{fttty}{0} = $bf[0]; +$bits{ftzero}{0} = $bf[0]; +@{$bits{ge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]); +@{$bits{getc}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{getpeername}{0} = $bf[0]; +@{$bits{getpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{getpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{getsockname}{0} = $bf[0]; +$bits{ggrgid}{0} = $bf[0]; +$bits{ggrnam}{0} = $bf[0]; +@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{ghbyname}{0} = $bf[0]; +@{$bits{glob}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gmtime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{gnbyname}{0} = $bf[0]; +$bits{goto}{0} = $bf[0]; +$bits{gpbyname}{0} = $bf[0]; +@{$bits{gpbynumber}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{gpwnam}{0} = $bf[0]; +$bits{gpwuid}{0} = $bf[0]; +$bits{grepstart}{0} = $bf[0]; +$bits{grepwhile}{0} = $bf[0]; +@{$bits{gsbyname}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gsbyport}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gsockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{gt}}{1,0} = ($bf[1], $bf[1]); +$bits{gv}{5} = 'OPpEARLY_CV'; +@{$bits{helem}}{5,4,1,0} = ($bf[8], $bf[8], $bf[1], $bf[1]); +$bits{hex}{0} = $bf[0]; +@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]); +$bits{i_negate}{0} = $bf[0]; +$bits{i_postdec}{0} = $bf[0]; +$bits{i_postinc}{0} = $bf[0]; +$bits{i_predec}{0} = $bf[0]; +$bits{i_preinc}{0} = $bf[0]; +@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]); +@{$bits{index}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{int}{0} = $bf[0]; +@{$bits{ioctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{join}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{keys}{0} = $bf[0]; +@{$bits{kill}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{last}{0} = $bf[0]; +$bits{lc}{0} = $bf[0]; +$bits{lcfirst}{0} = $bf[0]; +@{$bits{le}}{1,0} = ($bf[1], $bf[1]); +$bits{leaveeval}{0} = $bf[0]; +$bits{leavegiven}{0} = $bf[0]; +@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]); +$bits{leavesub}{0} = $bf[0]; +$bits{leavesublv}{0} = $bf[0]; +$bits{leavewhen}{0} = $bf[0]; +$bits{leavewrite}{0} = $bf[0]; +@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]); +$bits{length}{0} = $bf[0]; +@{$bits{link}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{list}{6} = 'OPpLIST_GUESSED'; +@{$bits{listen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{localtime}{0} = $bf[0]; +$bits{lock}{0} = $bf[0]; +$bits{log}{0} = $bf[0]; +@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]); +$bits{lstat}{0} = $bf[0]; +@{$bits{lt}}{1,0} = ($bf[1], $bf[1]); +$bits{lvavref}{0} = $bf[0]; +@{$bits{lvref}}{5,4,0} = ($bf[9], $bf[9], $bf[0]); +$bits{mapstart}{0} = $bf[0]; +$bits{mapwhile}{0} = $bf[0]; +$bits{method}{0} = $bf[0]; +$bits{method_named}{0} = $bf[0]; +$bits{method_redir}{0} = $bf[0]; +$bits{method_redir_super}{0} = $bf[0]; +$bits{method_super}{0} = $bf[0]; +@{$bits{mkdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]); +@{$bits{msgctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgrcv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{msgsnd}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{multiconcat}}{6,5,3,0} = ('OPpMULTICONCAT_APPEND', 'OPpMULTICONCAT_FAKE', 'OPpMULTICONCAT_STRINGIFY', $bf[0]); +@{$bits{multideref}}{5,4,0} = ('OPpMULTIDEREF_DELETE', 'OPpMULTIDEREF_EXISTS', $bf[0]); +@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]); +@{$bits{nbit_and}}{1,0} = ($bf[1], $bf[1]); +@{$bits{nbit_or}}{1,0} = ($bf[1], $bf[1]); +@{$bits{nbit_xor}}{1,0} = ($bf[1], $bf[1]); +@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]); +$bits{ncomplement}{0} = $bf[0]; +@{$bits{ne}}{1,0} = ($bf[1], $bf[1]); +$bits{negate}{0} = $bf[0]; +$bits{next}{0} = $bf[0]; +$bits{not}{0} = $bf[0]; +$bits{oct}{0} = $bf[0]; +$bits{once}{0} = $bf[0]; +@{$bits{open}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{open_dir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{or}{0} = $bf[0]; +$bits{orassign}{0} = $bf[0]; +$bits{ord}{0} = $bf[0]; +@{$bits{pack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{padhv}{0} = 'OPpPADHV_ISKEYS'; +@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]); +@{$bits{padsv}}{5,4} = ($bf[8], $bf[8]); +@{$bits{pipe_op}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{pop}{0} = $bf[0]; +$bits{pos}{0} = $bf[0]; +$bits{postdec}{0} = $bf[0]; +$bits{postinc}{0} = $bf[0]; +@{$bits{pow}}{1,0} = ($bf[1], $bf[1]); +$bits{predec}{0} = $bf[0]; +$bits{preinc}{0} = $bf[0]; +$bits{prototype}{0} = $bf[0]; +@{$bits{push}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{quotemeta}{0} = $bf[0]; +@{$bits{rand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{range}{0} = $bf[0]; +@{$bits{read}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{readdir}{0} = $bf[0]; +$bits{readline}{0} = $bf[0]; +$bits{readlink}{0} = $bf[0]; +@{$bits{recv}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{redo}{0} = $bf[0]; +$bits{ref}{0} = $bf[0]; +@{$bits{refassign}}{5,4,1,0} = ($bf[9], $bf[9], $bf[1], $bf[1]); +$bits{refgen}{0} = $bf[0]; +$bits{regcmaybe}{0} = $bf[0]; +$bits{regcomp}{0} = $bf[0]; +$bits{regcreset}{0} = $bf[0]; +@{$bits{rename}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]); +$bits{require}{0} = $bf[0]; +@{$bits{reset}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]); +$bits{rewinddir}{0} = $bf[0]; +@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]); +@{$bits{rindex}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{rmdir}{0} = $bf[0]; +$bits{rv2av}{0} = $bf[0]; +@{$bits{rv2cv}}{7,5,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]); +@{$bits{rv2gv}}{6,5,4,2,0} = ('OPpALLOW_FAKE', $bf[8], $bf[8], 'OPpDONT_INIT_GV', $bf[0]); +$bits{rv2hv}{0} = 'OPpRV2HV_ISKEYS'; +@{$bits{rv2sv}}{5,4,0} = ($bf[8], $bf[8], $bf[0]); +@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]); +@{$bits{sbit_and}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sbit_or}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sbit_xor}}{1,0} = ($bf[1], $bf[1]); +$bits{scalar}{0} = $bf[0]; +$bits{schomp}{0} = $bf[0]; +$bits{schop}{0} = $bf[0]; +@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]); +$bits{scomplement}{0} = $bf[0]; +@{$bits{seek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{seekdir}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{select}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{semop}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{send}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{seq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{setpgrp}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{setpriority}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]); +$bits{shift}{0} = $bf[0]; +@{$bits{shmctl}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmget}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{shmwrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{shostent}{0} = $bf[0]; +@{$bits{shutdown}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{sin}{0} = $bf[0]; +@{$bits{sle}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sleep}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{slt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sne}}{1,0} = ($bf[1], $bf[1]); +$bits{snetent}{0} = $bf[0]; +@{$bits{socket}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sockpair}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sort}}{7,6,4,3,2,1,0} = ('OPpSORT_UNSTABLE', 'OPpSORT_STABLE', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC'); +@{$bits{splice}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{split}}{4,3,2} = ('OPpSPLIT_ASSIGN', 'OPpSPLIT_LEX', 'OPpSPLIT_IMPLIM'); +@{$bits{sprintf}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{sprotoent}{0} = $bf[0]; +$bits{sqrt}{0} = $bf[0]; +@{$bits{srand}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{srefgen}{0} = $bf[0]; +@{$bits{sselect}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{sservent}{0} = $bf[0]; +@{$bits{ssockopt}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{stat}{0} = $bf[0]; +@{$bits{stringify}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{study}{0} = $bf[0]; +$bits{substcont}{0} = $bf[0]; +@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[3], $bf[3], $bf[3]); +@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]); +@{$bits{symlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{syscall}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysopen}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysread}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{sysseek}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{system}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{syswrite}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{tell}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{telldir}{0} = $bf[0]; +@{$bits{tie}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{tied}{0} = $bf[0]; +@{$bits{truncate}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{uc}{0} = $bf[0]; +$bits{ucfirst}{0} = $bf[0]; +@{$bits{umask}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{undef}{0} = $bf[0]; +@{$bits{unlink}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{unpack}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{unshift}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{untie}{0} = $bf[0]; +@{$bits{utime}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +$bits{values}{0} = $bf[0]; +@{$bits{vec}}{1,0} = ($bf[1], $bf[1]); +@{$bits{waitpid}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{warn}}{3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{xor}}{1,0} = ($bf[1], $bf[1]); + + +our %defines = ( + OPpALLOW_FAKE => 64, + OPpARG1_MASK => 1, + OPpARG2_MASK => 3, + OPpARG3_MASK => 7, + OPpARG4_MASK => 15, + OPpARGELEM_AV => 2, + OPpARGELEM_HV => 4, + OPpARGELEM_MASK => 6, + OPpARGELEM_SV => 0, + OPpASSIGN_BACKWARDS => 64, + OPpASSIGN_COMMON_AGG => 16, + OPpASSIGN_COMMON_RC1 => 32, + OPpASSIGN_COMMON_SCALAR => 64, + OPpASSIGN_CV_TO_GV => 128, + OPpASSIGN_TRUEBOOL => 4, + OPpAVHVSWITCH_MASK => 3, + OPpCONCAT_NESTED => 64, + OPpCONST_BARE => 64, + OPpCONST_ENTERED => 16, + OPpCONST_NOVER => 2, + OPpCONST_SHORTCIRCUIT => 4, + OPpCONST_STRICT => 8, + OPpCOREARGS_DEREF1 => 1, + OPpCOREARGS_DEREF2 => 2, + OPpCOREARGS_PUSHMARK => 128, + OPpCOREARGS_SCALARMOD => 64, + OPpDEREF => 48, + OPpDEREF_AV => 16, + OPpDEREF_HV => 32, + OPpDEREF_SV => 48, + OPpDONT_INIT_GV => 4, + OPpEARLY_CV => 32, + OPpENTERSUB_AMPER => 8, + OPpENTERSUB_DB => 64, + OPpENTERSUB_HASTARG => 4, + OPpENTERSUB_INARGS => 1, + OPpENTERSUB_NOPAREN => 128, + OPpEVAL_BYTES => 8, + OPpEVAL_COPHH => 16, + OPpEVAL_HAS_HH => 2, + OPpEVAL_RE_REPARSING => 32, + OPpEVAL_UNICODE => 4, + OPpEXISTS_SUB => 64, + OPpFLIP_LINENUM => 64, + OPpFT_ACCESS => 2, + OPpFT_AFTER_t => 16, + OPpFT_STACKED => 4, + OPpFT_STACKING => 8, + OPpHINT_STRICT_REFS => 2, + OPpHUSH_VMSISH => 32, + OPpINDEX_BOOLNEG => 64, + OPpITER_DEF => 8, + OPpITER_REVERSED => 2, + OPpKVSLICE => 32, + OPpLIST_GUESSED => 64, + OPpLVALUE => 128, + OPpLVAL_DEFER => 64, + OPpLVAL_INTRO => 128, + OPpLVREF_AV => 16, + OPpLVREF_CV => 48, + OPpLVREF_ELEM => 4, + OPpLVREF_HV => 32, + OPpLVREF_ITER => 8, + OPpLVREF_SV => 0, + OPpLVREF_TYPE => 48, + OPpMAYBE_LVSUB => 8, + OPpMAYBE_TRUEBOOL => 16, + OPpMAY_RETURN_CONSTANT => 32, + OPpMULTICONCAT_APPEND => 64, + OPpMULTICONCAT_FAKE => 32, + OPpMULTICONCAT_STRINGIFY => 8, + OPpMULTIDEREF_DELETE => 32, + OPpMULTIDEREF_EXISTS => 16, + OPpOFFBYONE => 128, + OPpOPEN_IN_CRLF => 32, + OPpOPEN_IN_RAW => 16, + OPpOPEN_OUT_CRLF => 128, + OPpOPEN_OUT_RAW => 64, + OPpOUR_INTRO => 64, + OPpPADHV_ISKEYS => 1, + OPpPADRANGE_COUNTMASK => 127, + OPpPADRANGE_COUNTSHIFT => 7, + OPpPAD_STATE => 64, + OPpPV_IS_UTF8 => 128, + OPpREFCOUNTED => 64, + OPpREPEAT_DOLIST => 64, + OPpREVERSE_INPLACE => 8, + OPpRV2HV_ISKEYS => 1, + OPpSLICE => 64, + OPpSLICEWARNING => 4, + OPpSORT_DESCEND => 16, + OPpSORT_INPLACE => 8, + OPpSORT_INTEGER => 2, + OPpSORT_NUMERIC => 1, + OPpSORT_REVERSE => 4, + OPpSORT_STABLE => 64, + OPpSORT_UNSTABLE => 128, + OPpSPLIT_ASSIGN => 16, + OPpSPLIT_IMPLIM => 4, + OPpSPLIT_LEX => 8, + OPpSUBSTR_REPL_FIRST => 16, + OPpTARGET_MY => 16, + OPpTRANS_COMPLEMENT => 32, + OPpTRANS_DELETE => 128, + OPpTRANS_FROM_UTF => 1, + OPpTRANS_GROWS => 64, + OPpTRANS_IDENTICAL => 4, + OPpTRANS_SQUASH => 8, + OPpTRANS_TO_UTF => 2, + OPpTRUEBOOL => 32, +); + +our %labels = ( + OPpALLOW_FAKE => 'FAKE', + OPpARGELEM_AV => 'AV', + OPpARGELEM_HV => 'HV', + OPpARGELEM_SV => 'SV', + OPpASSIGN_BACKWARDS => 'BKWARD', + OPpASSIGN_COMMON_AGG => 'COM_AGG', + OPpASSIGN_COMMON_RC1 => 'COM_RC1', + OPpASSIGN_COMMON_SCALAR => 'COM_SCALAR', + OPpASSIGN_CV_TO_GV => 'CV2GV', + OPpASSIGN_TRUEBOOL => 'BOOL', + OPpCONCAT_NESTED => 'NESTED', + OPpCONST_BARE => 'BARE', + OPpCONST_ENTERED => 'ENTERED', + OPpCONST_NOVER => 'NOVER', + OPpCONST_SHORTCIRCUIT => 'SHORT', + OPpCONST_STRICT => 'STRICT', + OPpCOREARGS_DEREF1 => 'DEREF1', + OPpCOREARGS_DEREF2 => 'DEREF2', + OPpCOREARGS_PUSHMARK => 'MARK', + OPpCOREARGS_SCALARMOD => '$MOD', + OPpDEREF_AV => 'DREFAV', + OPpDEREF_HV => 'DREFHV', + OPpDEREF_SV => 'DREFSV', + OPpDONT_INIT_GV => 'NOINIT', + OPpEARLY_CV => 'EARLYCV', + OPpENTERSUB_AMPER => 'AMPER', + OPpENTERSUB_DB => 'DBG', + OPpENTERSUB_HASTARG => 'TARG', + OPpENTERSUB_INARGS => 'INARGS', + OPpENTERSUB_NOPAREN => 'NO()', + OPpEVAL_BYTES => 'BYTES', + OPpEVAL_COPHH => 'COPHH', + OPpEVAL_HAS_HH => 'HAS_HH', + OPpEVAL_RE_REPARSING => 'REPARSE', + OPpEVAL_UNICODE => 'UNI', + OPpEXISTS_SUB => 'SUB', + OPpFLIP_LINENUM => 'LINENUM', + OPpFT_ACCESS => 'FTACCESS', + OPpFT_AFTER_t => 'FTAFTERt', + OPpFT_STACKED => 'FTSTACKED', + OPpFT_STACKING => 'FTSTACKING', + OPpHINT_STRICT_REFS => 'STRICT', + OPpHUSH_VMSISH => 'HUSH', + OPpINDEX_BOOLNEG => 'NEG', + OPpITER_DEF => 'DEF', + OPpITER_REVERSED => 'REVERSED', + OPpKVSLICE => 'KVSLICE', + OPpLIST_GUESSED => 'GUESSED', + OPpLVALUE => 'LV', + OPpLVAL_DEFER => 'LVDEFER', + OPpLVAL_INTRO => 'LVINTRO', + OPpLVREF_AV => 'AV', + OPpLVREF_CV => 'CV', + OPpLVREF_ELEM => 'ELEM', + OPpLVREF_HV => 'HV', + OPpLVREF_ITER => 'ITER', + OPpLVREF_SV => 'SV', + OPpMAYBE_LVSUB => 'LVSUB', + OPpMAYBE_TRUEBOOL => 'BOOL?', + OPpMAY_RETURN_CONSTANT => 'CONST', + OPpMULTICONCAT_APPEND => 'APPEND', + OPpMULTICONCAT_FAKE => 'FAKE', + OPpMULTICONCAT_STRINGIFY => 'STRINGIFY', + OPpMULTIDEREF_DELETE => 'DELETE', + OPpMULTIDEREF_EXISTS => 'EXISTS', + OPpOFFBYONE => '+1', + OPpOPEN_IN_CRLF => 'INCR', + OPpOPEN_IN_RAW => 'INBIN', + OPpOPEN_OUT_CRLF => 'OUTCR', + OPpOPEN_OUT_RAW => 'OUTBIN', + OPpOUR_INTRO => 'OURINTR', + OPpPADHV_ISKEYS => 'KEYS', + OPpPAD_STATE => 'STATE', + OPpPV_IS_UTF8 => 'UTF', + OPpREFCOUNTED => 'REFC', + OPpREPEAT_DOLIST => 'DOLIST', + OPpREVERSE_INPLACE => 'INPLACE', + OPpRV2HV_ISKEYS => 'KEYS', + OPpSLICE => 'SLICE', + OPpSLICEWARNING => 'SLICEWARN', + OPpSORT_DESCEND => 'DESC', + OPpSORT_INPLACE => 'INPLACE', + OPpSORT_INTEGER => 'INT', + OPpSORT_NUMERIC => 'NUM', + OPpSORT_REVERSE => 'REV', + OPpSORT_STABLE => 'STABLE', + OPpSORT_UNSTABLE => 'UNSTABLE', + OPpSPLIT_ASSIGN => 'ASSIGN', + OPpSPLIT_IMPLIM => 'IMPLIM', + OPpSPLIT_LEX => 'LEX', + OPpSUBSTR_REPL_FIRST => 'REPL1ST', + OPpTARGET_MY => 'TARGMY', + OPpTRANS_COMPLEMENT => 'COMPL', + OPpTRANS_DELETE => 'DEL', + OPpTRANS_FROM_UTF => ' 'GROWS', + OPpTRANS_IDENTICAL => 'IDENT', + OPpTRANS_SQUASH => 'SQUASH', + OPpTRANS_TO_UTF => '>UTF', + OPpTRUEBOOL => 'BOOL', +); + + +our %ops_using = ( + OPpALLOW_FAKE => [qw(rv2gv)], + OPpASSIGN_BACKWARDS => [qw(sassign)], + OPpASSIGN_COMMON_AGG => [qw(aassign)], + OPpCONCAT_NESTED => [qw(concat)], + OPpCONST_BARE => [qw(const)], + OPpCOREARGS_DEREF1 => [qw(coreargs)], + OPpEARLY_CV => [qw(gv)], + OPpENTERSUB_AMPER => [qw(entersub rv2cv)], + OPpENTERSUB_INARGS => [qw(entersub)], + OPpENTERSUB_NOPAREN => [qw(rv2cv)], + OPpEVAL_BYTES => [qw(entereval)], + OPpEXISTS_SUB => [qw(exists)], + OPpFLIP_LINENUM => [qw(flip flop)], + OPpFT_ACCESS => [qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite)], + OPpFT_AFTER_t => [qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero)], + OPpHINT_STRICT_REFS => [qw(entersub multideref rv2av rv2cv rv2gv rv2hv rv2sv)], + OPpHUSH_VMSISH => [qw(dbstate nextstate)], + OPpINDEX_BOOLNEG => [qw(index rindex)], + OPpITER_DEF => [qw(enteriter)], + OPpITER_REVERSED => [qw(enteriter iter)], + OPpKVSLICE => [qw(delete)], + OPpLIST_GUESSED => [qw(list)], + OPpLVALUE => [qw(leave leaveloop)], + OPpLVAL_DEFER => [qw(aelem helem multideref)], + OPpLVAL_INTRO => [qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list lvavref lvref lvrefslice multiconcat multideref padav padhv padrange padsv pushmark refassign rv2av rv2gv rv2hv rv2sv split)], + OPpLVREF_ELEM => [qw(lvref refassign)], + OPpMAYBE_LVSUB => [qw(aassign aelem akeys aslice av2arylen avhvswitch helem hslice keys kvaslice kvhslice multideref padav padhv pos rv2av rv2gv rv2hv substr values vec)], + OPpMAYBE_TRUEBOOL => [qw(padhv ref rv2hv)], + OPpMULTICONCAT_APPEND => [qw(multiconcat)], + OPpMULTIDEREF_DELETE => [qw(multideref)], + OPpOFFBYONE => [qw(caller runcv wantarray)], + OPpOPEN_IN_CRLF => [qw(backtick open)], + OPpOUR_INTRO => [qw(enteriter gvsv rv2av rv2hv rv2sv split)], + OPpPADHV_ISKEYS => [qw(padhv)], + OPpPAD_STATE => [qw(lvavref lvref padav padhv padsv pushmark refassign)], + OPpPV_IS_UTF8 => [qw(dump goto last next redo)], + OPpREFCOUNTED => [qw(leave leaveeval leavesub leavesublv leavewrite)], + OPpREPEAT_DOLIST => [qw(repeat)], + OPpREVERSE_INPLACE => [qw(reverse)], + OPpRV2HV_ISKEYS => [qw(rv2hv)], + OPpSLICEWARNING => [qw(aslice hslice padav padhv rv2av rv2hv)], + OPpSORT_DESCEND => [qw(sort)], + OPpSPLIT_ASSIGN => [qw(split)], + OPpSUBSTR_REPL_FIRST => [qw(substr)], + OPpTARGET_MY => [qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_subtract index int kill left_shift length link log mkdir modulo multiconcat multiply nbit_and nbit_or nbit_xor ncomplement oct ord pow push rand rename right_shift rindex rmdir schomp scomplement setpgrp setpriority sin sleep sqrt srand stringify subtract symlink system time unlink unshift utime wait waitpid)], + OPpTRANS_COMPLEMENT => [qw(trans transr)], + OPpTRUEBOOL => [qw(grepwhile index length padav padhv pos ref rindex rv2av rv2hv subst)], +); + +$ops_using{OPpASSIGN_COMMON_RC1} = $ops_using{OPpASSIGN_COMMON_AGG}; +$ops_using{OPpASSIGN_COMMON_SCALAR} = $ops_using{OPpASSIGN_COMMON_AGG}; +$ops_using{OPpASSIGN_CV_TO_GV} = $ops_using{OPpASSIGN_BACKWARDS}; +$ops_using{OPpASSIGN_TRUEBOOL} = $ops_using{OPpASSIGN_COMMON_AGG}; +$ops_using{OPpCONST_ENTERED} = $ops_using{OPpCONST_BARE}; +$ops_using{OPpCONST_NOVER} = $ops_using{OPpCONST_BARE}; +$ops_using{OPpCONST_SHORTCIRCUIT} = $ops_using{OPpCONST_BARE}; +$ops_using{OPpCONST_STRICT} = $ops_using{OPpCONST_BARE}; +$ops_using{OPpCOREARGS_DEREF2} = $ops_using{OPpCOREARGS_DEREF1}; +$ops_using{OPpCOREARGS_PUSHMARK} = $ops_using{OPpCOREARGS_DEREF1}; +$ops_using{OPpCOREARGS_SCALARMOD} = $ops_using{OPpCOREARGS_DEREF1}; +$ops_using{OPpDONT_INIT_GV} = $ops_using{OPpALLOW_FAKE}; +$ops_using{OPpENTERSUB_DB} = $ops_using{OPpENTERSUB_AMPER}; +$ops_using{OPpENTERSUB_HASTARG} = $ops_using{OPpENTERSUB_AMPER}; +$ops_using{OPpEVAL_COPHH} = $ops_using{OPpEVAL_BYTES}; +$ops_using{OPpEVAL_HAS_HH} = $ops_using{OPpEVAL_BYTES}; +$ops_using{OPpEVAL_RE_REPARSING} = $ops_using{OPpEVAL_BYTES}; +$ops_using{OPpEVAL_UNICODE} = $ops_using{OPpEVAL_BYTES}; +$ops_using{OPpFT_STACKED} = $ops_using{OPpFT_AFTER_t}; +$ops_using{OPpFT_STACKING} = $ops_using{OPpFT_AFTER_t}; +$ops_using{OPpLVREF_ITER} = $ops_using{OPpLVREF_ELEM}; +$ops_using{OPpMAY_RETURN_CONSTANT} = $ops_using{OPpENTERSUB_NOPAREN}; +$ops_using{OPpMULTICONCAT_FAKE} = $ops_using{OPpMULTICONCAT_APPEND}; +$ops_using{OPpMULTICONCAT_STRINGIFY} = $ops_using{OPpMULTICONCAT_APPEND}; +$ops_using{OPpMULTIDEREF_EXISTS} = $ops_using{OPpMULTIDEREF_DELETE}; +$ops_using{OPpOPEN_IN_RAW} = $ops_using{OPpOPEN_IN_CRLF}; +$ops_using{OPpOPEN_OUT_CRLF} = $ops_using{OPpOPEN_IN_CRLF}; +$ops_using{OPpOPEN_OUT_RAW} = $ops_using{OPpOPEN_IN_CRLF}; +$ops_using{OPpSLICE} = $ops_using{OPpKVSLICE}; +$ops_using{OPpSORT_INPLACE} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSORT_INTEGER} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSORT_NUMERIC} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSORT_REVERSE} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSORT_STABLE} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSORT_UNSTABLE} = $ops_using{OPpSORT_DESCEND}; +$ops_using{OPpSPLIT_IMPLIM} = $ops_using{OPpSPLIT_ASSIGN}; +$ops_using{OPpSPLIT_LEX} = $ops_using{OPpSPLIT_ASSIGN}; +$ops_using{OPpTRANS_DELETE} = $ops_using{OPpTRANS_COMPLEMENT}; +$ops_using{OPpTRANS_FROM_UTF} = $ops_using{OPpTRANS_COMPLEMENT}; +$ops_using{OPpTRANS_GROWS} = $ops_using{OPpTRANS_COMPLEMENT}; +$ops_using{OPpTRANS_IDENTICAL} = $ops_using{OPpTRANS_COMPLEMENT}; +$ops_using{OPpTRANS_SQUASH} = $ops_using{OPpTRANS_COMPLEMENT}; +$ops_using{OPpTRANS_TO_UTF} = $ops_using{OPpTRANS_COMPLEMENT}; + +# ex: set ro: +package B::Debug; + +our $VERSION = '1.26'; +BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } } + +use strict; +require 5.006; +use B qw(peekop walkoptree walkoptree_exec + main_start main_root cstring sv_undef SVf_NOK SVf_IOK); +use Config; +my (@optype, @specialsv_name); +require B; +if ($] < 5.009) { + require B::Asmdata; + B::Asmdata->import (qw(@optype @specialsv_name)); +} else { + B->import (qw(@optype @specialsv_name)); +} + +if ($] < 5.006002) { + eval q|sub B::GV::SAFENAME { + my $name = (shift())->NAME; + # The regex below corresponds to the isCONTROLVAR macro from toke.c + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; + return $name; + }|; +} + +my ($have_B_Flags, $have_B_Flags_extra); +if (!$ENV{PERL_CORE}){ # avoid CORE test crashes + eval { require B::Flags and $have_B_Flags++ }; + $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03'; +} +my %done_gv; + +sub _printop { + my $op = shift; + my $addr = ${$op} ? $op->ppaddr : ''; + $addr =~ s/^PL_ppaddr// if $addr; + if (${$op}) { + return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr; + } else { + return sprintf "0x%x %6s %s", ${$op}, '', $addr; + } +} + +sub B::OP::debug { + my ($op) = @_; + printf <<'EOT', B::class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name; +%s (0x%lx) + op_ppaddr %s + op_next %s + op_sibling %s + op_targ %d + op_type %d %s +EOT + if ($] > 5.009) { + printf <<'EOT', $op->opt; + op_opt %d +EOT + } else { + printf <<'EOT', $op->seq; + op_seq %d +EOT + } + if ($have_B_Flags) { + printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv; + op_flags %u %s + op_private %u %s +EOT + } else { + printf <<'EOT', $op->flags, $op->private; + op_flags %u + op_private %u +EOT + } + if ($op->can('rettype')) { + printf <<'EOT', $op->rettype; + op_rettype %u +EOT + } +} + +sub B::UNOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_first\t%s\n", _printop($op->first); +} + +sub B::BINOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_last \t%s\n", _printop($op->last); +} + +sub B::LOOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop); + op_redoop %s + op_nextop %s + op_lastop %s +EOT +} + +sub B::LOGOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_other\t%s\n", _printop($op->other); +} + +sub B::LISTOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf "\top_children\t%d\n", $op->children; +} + +sub B::PMOP::debug { + my ($op) = @_; + $op->B::LISTOP::debug(); + printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot; + printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; + printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005; + if ($Config{'useithreads'}) { + printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv); + printf "\top_pmoffset\t%d\n", $op->pmoffset; + } else { + printf "\top_pmstash\t%s\n", cstring($op->pmstash); + } + printf "\top_precomp\t%s\n", cstring($op->precomp); + printf "\top_pmflags\t0x%x\n", $op->pmflags; + printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009; + printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009; + printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009; + $op->pmreplroot->debug if $] < 5.008; +} + +sub B::COP::debug { + my ($op) = @_; + $op->B::OP::debug(); + my $warnings = ref $op->warnings ? ${$op->warnings} : 0; + printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings; + cop_label "%s" + cop_stashpv "%s" + cop_file "%s" + cop_seq %d + cop_arybase %d + cop_line %d + cop_warnings 0x%x +EOT + if ($] > 5.008 and $] < 5.011) { + my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; + printf(" cop_io %s\n", cstring($cop_io)); + } +} + +sub B::SVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_sv\t\t0x%x\n", ${$op->sv}; + $op->sv->debug; +} + +sub B::METHOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + if (${$op->first}) { + printf "\top_first\t0x%x\n", ${$op->first}; + $op->first->debug; + } else { + printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv}; + $op->meth_sv->debug; + } +} + +sub B::UNOP_AUX::debug { + my ($op) = @_; + $op->B::OP::debug(); + # string and perl5 aux_list needs the cv + # cperl has aux, Concise,-debug leaves it empty + if ($op->can('aux')) { + printf "\top_aux\t%s\n", cstring($op->aux); + } +} + +sub B::PVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_pv\t\t%s\n", cstring($op->pv); +} + +sub B::PADOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_padix\t%ld\n", $op->padix; +} + +sub B::NULL::debug { + my ($sv) = @_; + if ($$sv == ${sv_undef()}) { + print "&sv_undef\n"; + } else { + printf "NULL (0x%x)\n", $$sv; + } +} + +sub B::SV::debug { + my ($sv) = @_; + if (!$$sv) { + print B::class($sv), " = NULL\n"; + return; + } + printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT; +%s (0x%x) + REFCNT %d +EOT + printf "\tFLAGS\t\t0x%x", $sv->FLAGS; + if ($have_B_Flags) { + printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv; + } + print "\n"; +} + +sub B::RV::debug { + my ($rv) = @_; + B::SV::debug($rv); + printf <<'EOT', ${$rv->RV}; + RV 0x%x +EOT + $rv->RV->debug; +} + +sub B::PV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + my $pv = $sv->PV(); + printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN; + xpv_pv %s + xpv_cur %d + xpv_len %d +EOT +} + +sub B::IV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK; +} + +sub B::NV::debug { + my ($sv) = @_; + $sv->B::IV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK; +} + +sub B::PVIV::debug { + my ($sv) = @_; + $sv->B::PV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK; +} + +sub B::PVNV::debug { + my ($sv) = @_; + $sv->B::PVIV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK; +} + +sub B::PVLV::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txlv_targoff\t%d\n", $sv->TARGOFF; + printf "\txlv_targlen\t%u\n", $sv->TARGLEN; + printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); +} + +sub B::BM::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txbm_useful\t%d\n", $sv->USEFUL; + printf "\txbm_previous\t%u\n", $sv->PREVIOUS; + printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); +} + +sub B::CV::debug { + my ($cv) = @_; + $cv->B::PVNV::debug(); + my $stash = $cv->STASH; + my $start = $cv->START; + my $root = $cv->ROOT; + my $padlist = $cv->PADLIST; + my $file = $cv->FILE; + my $gv; + printf <<'EOT', $$stash, $$start, $$root; + STASH 0x%x + START 0x%x + ROOT 0x%x +EOT + if ($cv->can('NAME_HEK') && $cv->NAME_HEK) { + printf("\tNAME\t%%s\n", $cv->NAME_HEK); + } + elsif ( $]>5.017 && ($cv->FLAGS & 0x40000)) { #lexsub + printf("\tNAME\t%%s\n", $cv->NAME_HEK); + } else { + $gv = $cv->GV; + printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME); + } + printf <<'EOT', $file, $cv->DEPTH, $padlist, ${$cv->OUTSIDE}; + FILE %s + DEPTH %d + PADLIST 0x%x + OUTSIDE 0x%x +EOT + printf("\tOUTSIDE_SEQ\t%d\n", $cv->OUTSIDE_SEQ) if $] > 5.007; + if ($have_B_Flags) { + my $SVt_PVCV = $] < 5.010 ? 12 : 13; + printf("\tCvFLAGS\t0x%x\t%s\n", $cv->CvFLAGS, + $have_B_Flags_extra ? $cv->flagspv($SVt_PVCV) : $cv->flagspv); + } else { + printf("\tCvFLAGS\t0x%x\n", $cv->CvFLAGS); + } + printf("\tSIGOP\t0x%x\n", $cv->SIGOP) if $cv->can('SIGOP'); + $start->debug if $start; + $root->debug if $root; + $gv->debug if $gv; + $padlist->debug if $padlist; +} + +sub B::AV::debug { + my ($av) = @_; + $av->B::SV::debug; + _array_debug($av); +} + +sub _array_debug { + my ($av) = @_; + # tied arrays may leave out FETCHSIZE + my (@array) = eval { $av->ARRAY; }; + print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; + my $fill = eval { scalar(@array) }; + if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') { + printf <<'EOT', $fill, $av->MAX, $av->OFF; + FILL %d + MAX %d + OFF %d +EOT + } else { + printf <<'EOT', $fill, $av->MAX; + FILL %d + MAX %d +EOT + } + if ($] < 5.009) { + if ($have_B_Flags) { + printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS, + $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv); + } else { + printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS); + } + } +} + +sub B::GV::debug { + my ($gv) = @_; + if ($done_gv{$$gv}++) { + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; + return; + } + my $sv = $gv->SV; + my $av = $gv->AV; + my $cv = $gv->CV; + $gv->B::SV::debug; + printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; + NAME %s + STASH %s (0x%x) + SV 0x%x + GvREFCNT %d + FORM 0x%x + AV 0x%x + HV 0x%x + EGV 0x%x + CV 0x%x + CVGEN %d + LINE %d + FILE %s +EOT + if ($have_B_Flags) { + my $SVt_PVGV = $] < 5.010 ? 13 : 9; + printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS, + $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv); + } else { + printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS); + } + $sv->debug if $sv; + $av->debug if $av; + $cv->debug if $cv; +} + +sub B::SPECIAL::debug { + my $sv = shift; + my $i = ref $sv ? $$sv : 0; + print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n"; +} + +sub B::PADLIST::debug { + my ($padlist) = @_; + printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT; +%s (0x%x) + REFCNT %d +EOT + _array_debug($padlist); +} + +sub compile { + my $order = shift; + B::clearsym(); + $DB::single = 1 if defined &DB::DB; + if ($order && $order eq "exec") { + return sub { walkoptree_exec(main_start, "debug") } + } else { + return sub { walkoptree(main_root, "debug") } + } +} + +1; + +__END__ + + +# Net::SMTP.pm +# +# Copyright (C) 1995-2004 Graham Barr. All rights reserved. +# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::SMTP; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use IO::Socket; +use Net::Cmd; +use Net::Config; +use Socket; + +our $VERSION = "3.11"; + +# Code for detecting if we can use SSL +my $ssl_class = eval { + require IO::Socket::SSL; + # first version with default CA on most platforms + no warnings 'numeric'; + IO::Socket::SSL->VERSION(2.007); +} && 'IO::Socket::SSL'; + +my $nossl_warn = !$ssl_class && + 'To use SSL please install IO::Socket::SSL with version>=2.007'; + +# Code for detecting if we can use IPv6 +my $family_key = 'Domain'; +my $inet6_class = eval { + require IO::Socket::IP; + no warnings 'numeric'; + IO::Socket::IP->VERSION(0.25) || die; + $family_key = 'Family'; +} && 'IO::Socket::IP' || eval { + require IO::Socket::INET6; + no warnings 'numeric'; + IO::Socket::INET6->VERSION(2.62); +} && 'IO::Socket::INET6'; + +sub can_ssl { $ssl_class }; +sub can_inet6 { $inet6_class }; + +our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); + +sub new { + my $self = shift; + my $type = ref($self) || $self; + my ($host, %arg); + if (@_ % 2) { + $host = shift; + %arg = @_; + } + else { + %arg = @_; + $host = delete $arg{Host}; + } + + if ($arg{SSL}) { + # SSL from start + die $nossl_warn if !$ssl_class; + $arg{Port} ||= 465; + } + + my $hosts = defined $host ? $host : $NetConfig{smtp_hosts}; + my $obj; + + $arg{Timeout} = 120 if ! defined $arg{Timeout}; + + foreach my $h (@{ref($hosts) ? $hosts : [$hosts]}) { + $obj = $type->SUPER::new( + PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'smtp(25)', + LocalAddr => $arg{LocalAddr}, + LocalPort => $arg{LocalPort}, + $family_key => $arg{Domain} || $arg{Family}, + Proto => 'tcp', + Timeout => $arg{Timeout} + ) + and last; + } + + return + unless defined $obj; + + ${*$obj}{'net_smtp_arg'} = \%arg; + ${*$obj}{'net_smtp_host'} = $host; + + if ($arg{SSL}) { + Net::SMTP::_SSL->start_SSL($obj,%arg) + or return; + } + + $obj->autoflush(1); + + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($obj->response() == CMD_OK) { + my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; + $obj->close(); + $@ = $err; + return; + } + + ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses}; + + (${*$obj}{'net_smtp_banner'}) = $obj->message; + (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; + + if (!exists $arg{SendHello} || $arg{SendHello}) { + unless ($obj->hello($arg{Hello} || "")) { + my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; + $obj->close(); + $@ = $err; + return; + } + } + + $obj; +} + + +sub host { + my $me = shift; + ${*$me}{'net_smtp_host'}; +} + +## +## User interface methods +## + + +sub banner { + my $me = shift; + + return ${*$me}{'net_smtp_banner'} || undef; +} + + +sub domain { + my $me = shift; + + return ${*$me}{'net_smtp_domain'} || undef; +} + + +sub etrn { + my $self = shift; + defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"])) + && $self->_ETRN(@_); +} + + +sub auth { + my ($self, $username, $password) = @_; + + eval { + require MIME::Base64; + require Authen::SASL; + } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; + + my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]); + return unless defined $mechanisms; + + my $sasl; + + if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { + $sasl = $username; + my $requested_mechanisms = $sasl->mechanism(); + if (! defined($requested_mechanisms) || $requested_mechanisms eq '') { + $sasl->mechanism($mechanisms); + } + } + else { + die "auth(username, password)" if not length $username; + $sasl = Authen::SASL->new( + mechanism => $mechanisms, + callback => { + user => $username, + pass => $password, + authname => $username, + }, + debug => $self->debug + ); + } + + my $client; + my $str; + do { + if ($client) { + # $client mechanism failed, so we need to exclude this mechanism from list + my $failed_mechanism = $client->mechanism; + return unless defined $failed_mechanism; + $self->debug_text("Auth mechanism failed: $failed_mechanism") + if $self->debug; + $mechanisms =~ s/\b\Q$failed_mechanism\E\b//; + return unless $mechanisms =~ /\S/; + $sasl->mechanism($mechanisms); + } + + # We should probably allow the user to pass the host, but I don't + # currently know and SASL mechanisms that are used by smtp that need it + + $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0); + $str = $client->client_start; + } while (!defined $str); + + # We don't support sasl mechanisms that encrypt the socket traffic. + # todo that we would really need to change the ISA hierarchy + # so we don't inherit from IO::Socket, but instead hold it in an attribute + + my @cmd = ("AUTH", $client->mechanism); + my $code; + + push @cmd, MIME::Base64::encode_base64($str, '') + if defined $str and length $str; + + while (($code = $self->command(@cmd)->response()) == CMD_MORE) { + my $str2 = MIME::Base64::decode_base64(($self->message)[0]); + $self->debug_print(0, "(decoded) " . $str2 . "\n") if $self->debug; + + $str = $client->client_step($str2); + @cmd = ( + MIME::Base64::encode_base64($str, '') + ); + + $self->debug_print(1, "(decoded) " . $str . "\n") if $self->debug; + } + + $code == CMD_OK; +} + + +sub hello { + my $me = shift; + my $domain = shift || "localhost.localdomain"; + my $ok = $me->_EHLO($domain); + my @msg = $me->message; + + if ($ok) { + my $h = ${*$me}{'net_smtp_esmtp'} = {}; + foreach my $ln (@msg) { + $h->{uc $1} = $2 + if $ln =~ /([-\w]+)\b[= \t]*([^\n]*)/; + } + } + elsif ($me->status == CMD_ERROR) { + @msg = $me->message + if $ok = $me->_HELO($domain); + } + + return unless $ok; + ${*$me}{net_smtp_hello_domain} = $domain; + + $msg[0] =~ /\A\s*(\S+)/; + return ($1 || " "); +} + +sub starttls { + my $self = shift; + $ssl_class or die $nossl_warn; + $self->_STARTTLS or return; + Net::SMTP::_SSL->start_SSL($self, + %{ ${*$self}{'net_smtp_arg'} }, # (ssl) args given in new + @_ # more (ssl) args + ) or return; + + # another hello after starttls to read new ESMTP capabilities + return $self->hello(${*$self}{net_smtp_hello_domain}); +} + + +sub supports { + my $self = shift; + my $cmd = uc shift; + return ${*$self}{'net_smtp_esmtp'}->{$cmd} + if exists ${*$self}{'net_smtp_esmtp'}->{$cmd}; + $self->set_status(@_) + if @_; + return; +} + + +sub _addr { + my $self = shift; + my $addr = shift; + $addr = "" unless defined $addr; + + if (${*$self}{'net_smtp_exact_addr'}) { + return $1 if $addr =~ /^\s*(<.*>)\s*$/s; + } + else { + return $1 if $addr =~ /(<[^>]*>)/; + $addr =~ s/^\s+|\s+$//sg; + } + + "<$addr>"; +} + + +sub mail { + my $me = shift; + my $addr = _addr($me, shift); + my $opts = ""; + + if (@_) { + my %opt = @_; + my ($k, $v); + + if (exists ${*$me}{'net_smtp_esmtp'}) { + my $esmtp = ${*$me}{'net_smtp_esmtp'}; + + if (defined($v = delete $opt{Size})) { + if (exists $esmtp->{SIZE}) { + $opts .= sprintf " SIZE=%d", $v + 0; + } + else { + carp 'Net::SMTP::mail: SIZE option not supported by host'; + } + } + + if (defined($v = delete $opt{Return})) { + if (exists $esmtp->{DSN}) { + $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS"); + } + else { + carp 'Net::SMTP::mail: DSN option not supported by host'; + } + } + + if (defined($v = delete $opt{Bits})) { + if ($v eq "8") { + if (exists $esmtp->{'8BITMIME'}) { + $opts .= " BODY=8BITMIME"; + } + else { + carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; + } + } + elsif ($v eq "binary") { + if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) { + $opts .= " BODY=BINARYMIME"; + ${*$me}{'net_smtp_chunking'} = 1; + } + else { + carp 'Net::SMTP::mail: BINARYMIME option not supported by host'; + } + } + elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) { + $opts .= " BODY=7BIT"; + } + else { + carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host'; + } + } + + if (defined($v = delete $opt{Transaction})) { + if (exists $esmtp->{CHECKPOINT}) { + $opts .= " TRANSID=" . _addr($me, $v); + } + else { + carp 'Net::SMTP::mail: CHECKPOINT option not supported by host'; + } + } + + if (defined($v = delete $opt{Envelope})) { + if (exists $esmtp->{DSN}) { + $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02X", ord($1)/sge; + $opts .= " ENVID=$v"; + } + else { + carp 'Net::SMTP::mail: DSN option not supported by host'; + } + } + + if (defined($v = delete $opt{ENVID})) { + + # expected to be in a format as required by RFC 3461, xtext-encoded + if (exists $esmtp->{DSN}) { + $opts .= " ENVID=$v"; + } + else { + carp 'Net::SMTP::mail: DSN option not supported by host'; + } + } + + if (defined($v = delete $opt{AUTH})) { + + # expected to be in a format as required by RFC 2554, + # rfc2821-quoted and xtext-encoded, or <> + if (exists $esmtp->{AUTH}) { + $v = '<>' if !defined($v) || $v eq ''; + $opts .= " AUTH=$v"; + } + else { + carp 'Net::SMTP::mail: AUTH option not supported by host'; + } + } + + if (defined($v = delete $opt{XVERP})) { + if (exists $esmtp->{'XVERP'}) { + $opts .= " XVERP"; + } + else { + carp 'Net::SMTP::mail: XVERP option not supported by host'; + } + } + + carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' + if scalar keys %opt; + } + else { + carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-('; + } + } + + $me->_MAIL("FROM:" . $addr . $opts); +} + + +sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) } +sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) } +sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) } + + +sub reset { + my $me = shift; + + $me->dataend() + if (exists ${*$me}{'net_smtp_lastch'}); + + $me->_RSET(); +} + + +sub recipient { + my $smtp = shift; + my $opts = ""; + my $skip_bad = 0; + + if (@_ && ref($_[-1])) { + my %opt = %{pop(@_)}; + my $v; + + $skip_bad = delete $opt{'SkipBad'}; + + if (exists ${*$smtp}{'net_smtp_esmtp'}) { + my $esmtp = ${*$smtp}{'net_smtp_esmtp'}; + + if (defined($v = delete $opt{Notify})) { + if (exists $esmtp->{DSN}) { + $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v); + } + else { + carp 'Net::SMTP::recipient: DSN option not supported by host'; + } + } + + if (defined($v = delete $opt{ORcpt})) { + if (exists $esmtp->{DSN}) { + $opts .= " ORCPT=" . $v; + } + else { + carp 'Net::SMTP::recipient: DSN option not supported by host'; + } + } + + carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' + if scalar keys %opt; + } + elsif (%opt) { + carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-('; + } + } + + my @ok; + foreach my $addr (@_) { + if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) { + push(@ok, $addr) if $skip_bad; + } + elsif (!$skip_bad) { + return 0; + } + } + + return $skip_bad ? @ok : 1; +} + +BEGIN { + *to = \&recipient; + *cc = \&recipient; + *bcc = \&recipient; +} + + +sub data { + my $me = shift; + + if (exists ${*$me}{'net_smtp_chunking'}) { + carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead'; + } + else { + my $ok = $me->_DATA() && $me->datasend(@_); + + $ok && @_ + ? $me->dataend + : $ok; + } +} + + +sub bdat { + my $me = shift; + + if (exists ${*$me}{'net_smtp_chunking'}) { + my $data = shift; + + $me->_BDAT(length $data) + && $me->rawdatasend($data) + && $me->response() == CMD_OK; + } + else { + carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; + } +} + + +sub bdatlast { + my $me = shift; + + if (exists ${*$me}{'net_smtp_chunking'}) { + my $data = shift; + + $me->_BDAT(length $data, "LAST") + && $me->rawdatasend($data) + && $me->response() == CMD_OK; + } + else { + carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; + } +} + + +sub datafh { + my $me = shift; + return unless $me->_DATA(); + return $me->tied_fh; +} + + +sub expand { + my $me = shift; + + $me->_EXPN(@_) + ? ($me->message) + : (); +} + + +sub verify { shift->_VRFY(@_) } + + +sub help { + my $me = shift; + + $me->_HELP(@_) + ? scalar $me->message + : undef; +} + + +sub quit { + my $me = shift; + + $me->_QUIT; + $me->close; +} + + +sub DESTROY { + + # ignore +} + +## +## RFC821 commands +## + + +sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK } +sub _HELO { shift->command("HELO", @_)->response() == CMD_OK } +sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK } +sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK } +sub _SEND { shift->command("SEND", @_)->response() == CMD_OK } +sub _SAML { shift->command("SAML", @_)->response() == CMD_OK } +sub _SOML { shift->command("SOML", @_)->response() == CMD_OK } +sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK } +sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK } +sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } +sub _RSET { shift->command("RSET")->response() == CMD_OK } +sub _NOOP { shift->command("NOOP")->response() == CMD_OK } +sub _QUIT { shift->command("QUIT")->response() == CMD_OK } +sub _DATA { shift->command("DATA")->response() == CMD_MORE } +sub _BDAT { shift->command("BDAT", @_) } +sub _TURN { shift->unsupported(@_); } +sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK } +sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK } +sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK } + + +{ + package Net::SMTP::_SSL; + our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::SMTP' ); + sub starttls { die "SMTP connection is already in SSL mode" } + sub start_SSL { + my ($class,$smtp,%arg) = @_; + delete @arg{ grep { !m{^SSL_} } keys %arg }; + ( $arg{SSL_verifycn_name} ||= $smtp->host ) + =~s{(?can_client_sni; + $arg{SSL_verifycn_scheme} ||= 'smtp'; + my $ok = $class->SUPER::start_SSL($smtp,%arg); + $@ = $ssl_class->errstr if !$ok; + return $ok; + } +} + + + +1; + +__END__ + +package Net::hostent; +use strict; + +use 5.006_001; +our $VERSION = '1.02'; +our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ( + $h_name, @h_aliases, + $h_addrtype, $h_length, + @h_addr_list, $h_addr +); + +BEGIN { + use Exporter (); + @EXPORT = qw(gethostbyname gethostbyaddr gethost); + @EXPORT_OK = qw( + $h_name @h_aliases + $h_addrtype $h_length + @h_addr_list $h_addr + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::hostent' => [ + name => '$', + aliases => '@', + addrtype => '$', + 'length' => '$', + addr_list => '@', +]; + +sub addr { shift->addr_list->[0] } + +sub populate (@) { + return unless @_; + my $hob = new(); + $h_name = $hob->[0] = $_[0]; + @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; + $h_addrtype = $hob->[2] = $_[2]; + $h_length = $hob->[3] = $_[3]; + $h_addr = $_[4]; + @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; + return $hob; +} + +sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } + +sub gethostbyaddr ($;$) { + my ($addr, $addrtype); + $addr = shift; + require Socket unless @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::gethostbyaddr($addr, $addrtype)) +} + +sub gethost($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &gethostbyaddr(Socket::inet_aton(shift)); + } else { + &gethostbyname; + } +} + +1; +__END__ + +# Net::Domain.pm +# +# Copyright (C) 1995-1998 Graham Barr. All rights reserved. +# Copyright (C) 2013-2014 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::Domain; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Exporter; +use Net::Config; + +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); +our $VERSION = "3.11"; + +my ($host, $domain, $fqdn) = (undef, undef, undef); + +# Try every conceivable way to get hostname. + + +sub _hostname { + + # we already know it + return $host + if (defined $host); + + if ($^O eq 'MSWin32') { + require Socket; + my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost'); + while (@addr) { + my $a = shift(@addr); + $host = gethostbyaddr($a, Socket::AF_INET()); + last if defined $host; + } + if (defined($host) && index($host, '.') > 0) { + $fqdn = $host; + ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; + } + return $host; + } + elsif ($^O eq 'MacOS') { + chomp($host = `hostname`); + } + elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard + $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); + $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); + if (index($host, '.') > 0) { + $fqdn = $host; + ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; + } + return $host; + } + else { + local $SIG{'__DIE__'}; + + # syscall is preferred since it avoids tainting problems + eval { + my $tmp = "\0" x 256; ## preload scalar + eval { + package main; + require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) + defined(&main::SYS_gethostname); + } + || eval { + package main; + require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) + defined(&main::SYS_gethostname); + } + and $host = + (syscall(&main::SYS_gethostname, $tmp, 256) == 0) + ? $tmp + : undef; + } + + # POSIX + || eval { + require POSIX; + $host = (POSIX::uname())[1]; + } + + # trusty old hostname command + || eval { + chop($host = `(hostname) 2>/dev/null`); # BSD'ish + } + + # sysV/POSIX uname command (may truncate) + || eval { + chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish + } + + # Apollo pre-SR10 + || eval { $host = (split(/[:. ]/, `/com/host`, 6))[0]; } + + || eval { $host = ""; }; + } + + # remove garbage + $host =~ s/[\0\r\n]+//go; + $host =~ s/(\A\.+|\.+\Z)//go; + $host =~ s/\.\.+/\./go; + + $host; +} + + +sub _hostdomain { + + # we already know it + return $domain + if (defined $domain); + + local $SIG{'__DIE__'}; + + return $domain = $NetConfig{'inet_domain'} + if defined $NetConfig{'inet_domain'}; + + # try looking in /etc/resolv.conf + # putting this here and assuming that it is correct, eliminates + # calls to gethostbyname, and therefore DNS lookups. This helps + # those on dialup systems. + + local ($_); + + if (open(my $res, '<', "/etc/resolv.conf")) { + while (<$res>) { + $domain = $1 + if (/\A\s*(?:domain|search)\s+(\S+)/); + } + close($res); + + return $domain + if (defined $domain); + } + + # just try hostname and system calls + + my $host = _hostname(); + my (@hosts); + + @hosts = ($host, "localhost"); + + unless (defined($host) && $host =~ /\./) { + my $dom = undef; + eval { + my $tmp = "\0" x 256; ## preload scalar + eval { + package main; + require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) + } + || eval { + package main; + require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) + } + and $dom = + (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) + ? $tmp + : undef; + }; + + if ($^O eq 'VMS') { + $dom ||= $ENV{'TCPIP$INET_DOMAIN'} + || $ENV{'UCX$INET_DOMAIN'}; + } + + chop($dom = `domainname 2>/dev/null`) + unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/); + + if (defined $dom) { + my @h = (); + $dom =~ s/^\.+//; + while (length($dom)) { + push(@h, "$host.$dom"); + $dom =~ s/^[^.]+.+// or last; + } + unshift(@hosts, @h); + } + } + + # Attempt to locate FQDN + + foreach (grep { defined $_ } @hosts) { + my @info = gethostbyname($_); + + next unless @info; + + # look at real name & aliases + foreach my $site ($info[0], split(/ /, $info[1])) { + if (rindex($site, ".") > 0) { + + # Extract domain from FQDN + + ($domain = $site) =~ s/\A[^.]+\.//; + return $domain; + } + } + } + + # Look for environment variable + + $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; + + if (defined $domain) { + $domain =~ s/[\r\n\0]+//g; + $domain =~ s/(\A\.+|\.+\Z)//g; + $domain =~ s/\.\.+/\./g; + } + + $domain; +} + + +sub domainname { + + return $fqdn + if (defined $fqdn); + + _hostname(); + + # *.local names are special on darwin. If we call gethostbyname below, it + # may hang while waiting for another, non-existent computer to respond. + if($^O eq 'darwin' && $host =~ /\.local$/) { + return $host; + } + + _hostdomain(); + + # Assumption: If the host name does not contain a period + # and the domain name does, then assume that they are correct + # this helps to eliminate calls to gethostbyname, and therefore + # eliminate DNS lookups + + return $fqdn = $host . "." . $domain + if (defined $host + and defined $domain + and $host !~ /\./ + and $domain =~ /\./); + + # For hosts that have no name, just an IP address + return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; + + my @host = defined $host ? split(/\./, $host) : ('localhost'); + my @domain = defined $domain ? split(/\./, $domain) : (); + my @fqdn = (); + + # Determine from @host & @domain the FQDN + + my @d = @domain; + +LOOP: + while (1) { + my @h = @host; + while (@h) { + my $tmp = join(".", @h, @d); + if ((gethostbyname($tmp))[0]) { + @fqdn = (@h, @d); + $fqdn = $tmp; + last LOOP; + } + pop @h; + } + last unless shift @d; + } + + if (@fqdn) { + $host = shift @fqdn; + until ((gethostbyname($host))[0]) { + $host .= "." . shift @fqdn; + } + $domain = join(".", @fqdn); + } + else { + undef $host; + undef $domain; + undef $fqdn; + } + + $fqdn; +} + + +sub hostfqdn { domainname() } + + +sub hostname { + domainname() + unless (defined $host); + return $host; +} + + +sub hostdomain { + domainname() + unless (defined $domain); + return $domain; +} + +1; # Keep require happy + +__END__ + +package Net::protoent; +use strict; + +use 5.006_001; +our $VERSION = '1.01'; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ( $p_name, @p_aliases, $p_proto ); +BEGIN { + use Exporter (); + @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto); + @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::protoent' => [ + name => '$', + aliases => '@', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $pob = new(); + $p_name = $pob->[0] = $_[0]; + @p_aliases = @{ $pob->[1] } = split ' ', $_[1]; + $p_proto = $pob->[2] = $_[2]; + return $pob; +} + +sub getprotoent ( ) { populate(CORE::getprotoent()) } +sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) } +sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) } + +sub getproto ($;$) { + no strict 'refs'; + return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_); +} + +1; + +__END__ + +# Net::Time.pm +# +# Copyright (C) 1995-2004 Graham Barr. All rights reserved. +# Copyright (C) 2014 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::Time; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Exporter; +use IO::Select; +use IO::Socket; +use Net::Config; + +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(inet_time inet_daytime); + +our $VERSION = "3.11"; + +our $TIMEOUT = 120; + +sub _socket { + my ($pname, $pnum, $host, $proto, $timeout) = @_; + + $proto ||= 'udp'; + + my $port = (getservbyname($pname, $proto))[2] || $pnum; + + my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'}; + + my $me; + + foreach my $addr (@$hosts) { + $me = IO::Socket::INET->new( + PeerAddr => $addr, + PeerPort => $port, + Proto => $proto + ) + and last; + } + + return unless $me; + + $me->send("\n") + if $proto eq 'udp'; + + $timeout = $TIMEOUT + unless defined $timeout; + + IO::Select->new($me)->can_read($timeout) + ? $me + : undef; +} + + +sub inet_time { + my $s = _socket('time', 37, @_) || return; + my $buf = ''; + my $offset = 0 | 0; + + return + unless defined $s->recv($buf, length(pack("N", 0))); + + # unpack, we | 0 to ensure we have an unsigned + my $time = (unpack("N", $buf))[0] | 0; + + # the time protocol return time in seconds since 1900, convert + # it to a the required format + + if ($^O eq "MacOS") { + + # MacOS return seconds since 1904, 1900 was not a leap year. + $offset = (4 * 31536000) | 0; + } + else { + + # otherwise return seconds since 1972, there were 17 leap years between + # 1900 and 1972 + $offset = (70 * 31536000 + 17 * 86400) | 0; + } + + $time - $offset; +} + + +sub inet_daytime { + my $s = _socket('daytime', 13, @_) || return; + my $buf = ''; + + defined($s->recv($buf, 1024)) + ? $buf + : undef; +} + +1; + +__END__ + +package Net::servent; +use strict; + +use 5.006_001; +our $VERSION = '1.02'; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ( $s_name, @s_aliases, $s_port, $s_proto ); +BEGIN { + use Exporter (); + @EXPORT = qw(getservbyname getservbyport getservent getserv); + @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::servent' => [ + name => '$', + aliases => '@', + port => '$', + proto => '$', +]; + +sub populate (@) { + return unless @_; + my $sob = new(); + $s_name = $sob->[0] = $_[0]; + @s_aliases = @{ $sob->[1] } = split ' ', $_[1]; + $s_port = $sob->[2] = $_[2]; + $s_proto = $sob->[3] = $_[3]; + return $sob; +} + +sub getservent ( ) { populate(CORE::getservent()) } +sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) } +sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) } + +sub getserv ($;$) { + no strict 'refs'; + return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_); +} + +1; + +__END__ + +package Net::Ping; + +require 5.002; +require Exporter; + +use strict; +our $hires; +use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); +use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP + SOL_SOCKET SO_ERROR SO_BROADCAST + IPPROTO_IP IP_TOS IP_TTL + inet_ntoa inet_aton getnameinfo sockaddr_in ); +use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN + WNOHANG ); +use FileHandle; +use Carp; +use Time::HiRes; + +our @ISA = qw(Exporter); +our @EXPORT = qw(pingecho); +our @EXPORT_OK = qw(wakeonlan); +our $VERSION = "2.62"; + +# Globals + +our $def_timeout = 5; # Default timeout to wait for a reply +our $def_proto = "tcp"; # Default protocol to use for pinging +our $def_factor = 1.2; # Default exponential backoff rate. +our $def_family = AF_INET; # Default family. +our $max_datasize = 1024; # Maximum data bytes in a packet +# The data we exchange with the server for the stream protocol +our $pingstring = "pingschwingping!\n"; +our $source_verify = 1; # Default is to verify source endpoint +our $syn_forking = 0; + +# Constants + +my $AF_INET6 = eval { Socket::AF_INET6() } || 30; +my $AF_UNSPEC = eval { Socket::AF_UNSPEC() }; +my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() } || 4; +my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() } || 2; +my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() } || 41; +#my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255 +my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; +my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; + +if ($^O =~ /Win32/i) { + # Hack to avoid this Win32 spewage: + # Your vendor has not defined POSIX macro ECONNREFUSED + my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response? + ENOTCONN => 10057, + ECONNRESET => 10054, + EINPROGRESS => 10036, + EWOULDBLOCK => 10035, + ); + while (my $name = shift @pairs) { + my $value = shift @pairs; + # When defined, these all are non-zero + unless (eval $name) { + no strict 'refs'; + *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value}; + } + } +# $syn_forking = 1; # XXX possibly useful in < Win2K ? +}; + +# Description: The pingecho() subroutine is provided for backward +# compatibility with the original Net::Ping. It accepts a host +# name/IP and an optional timeout in seconds. Create a tcp ping +# object and try pinging the host. The result of the ping is returned. + +sub pingecho +{ + my ($host, # Name or IP number of host to ping + $timeout # Optional timeout in seconds + ) = @_; + my ($p); # A ping object + + $p = Net::Ping->new("tcp", $timeout); + $p->ping($host); # Going out of scope closes the connection +} + +# Description: The new() method creates a new ping object. Optional +# parameters may be specified for the protocol to use, the timeout in +# seconds and the size in bytes of additional data which should be +# included in the packet. +# After the optional parameters are checked, the data is constructed +# and a socket is opened if appropriate. The object is returned. + +sub new +{ + my ($this, + $proto, # Optional protocol to use for pinging + $timeout, # Optional timeout in seconds + $data_size, # Optional additional bytes of data + $device, # Optional device to use + $tos, # Optional ToS to set + $ttl, # Optional TTL to set + $family, # Optional address family (AF_INET) + ) = @_; + my $class = ref($this) || $this; + my $self = {}; + my ($cnt, # Count through data bytes + $min_datasize # Minimum data bytes required + ); + + bless($self, $class); + if (ref $proto eq 'HASH') { # support named args + for my $k (qw(proto timeout data_size device tos ttl family + gateway host port bind retrans pingstring source_verify + econnrefused dontfrag + IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT)) + { + if (exists $proto->{$k}) { + $self->{$k} = $proto->{$k}; + # some are still globals + if ($k eq 'pingstring') { $pingstring = $proto->{$k} } + if ($k eq 'source_verify') { $source_verify = $proto->{$k} } + delete $proto->{$k}; + } + } + if (%$proto) { + croak("Invalid named argument: ",join(" ",keys (%$proto))); + } + $proto = $self->{'proto'}; + } + + $proto = $def_proto unless $proto; # Determine the protocol + croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"') + unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/; + $self->{proto} = $proto; + + $timeout = $def_timeout unless $timeout; # Determine the timeout + croak("Default timeout for ping must be greater than 0 seconds") + if $timeout <= 0; + $self->{timeout} = $timeout; + + $self->{device} = $device; + + $self->{tos} = $tos; + + if ($self->{'host'}) { + my $host = $self->{'host'}; + my $ip = _resolv($host) + or croak("could not resolve host $host"); + $self->{host} = $ip; + $self->{family} = $ip->{family}; + } + + if ($self->{bind}) { + my $addr = $self->{bind}; + my $ip = _resolv($addr) + or croak("could not resolve local addr $addr"); + $self->{local_addr} = $ip; + } else { + $self->{local_addr} = undef; # Don't bind by default + } + + if ($self->{proto} eq 'icmp') { + croak('TTL must be from 0 to 255') + if ($ttl && ($ttl < 0 || $ttl > 255)); + $self->{ttl} = $ttl; + } + + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family} = AF_INET; + } else { + $self->{family} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family} = $def_family; + } + + $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size + $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; + croak("Data for ping must be from $min_datasize to $max_datasize bytes") + if ($data_size < $min_datasize) || ($data_size > $max_datasize); + $data_size-- if $self->{proto} eq "udp"; # We provide the first byte + $self->{data_size} = $data_size; + + $self->{data} = ""; # Construct data bytes + for ($cnt = 0; $cnt < $self->{data_size}; $cnt++) + { + $self->{data} .= chr($cnt % 256); + } + + # Default exponential backoff rate + $self->{retrans} = $def_factor unless exists $self->{retrans}; + # Default Connection refused behavior + $self->{econnrefused} = undef unless exists $self->{econnrefused}; + + $self->{seq} = 0; # For counting packets + if ($self->{proto} eq "udp") # Open a socket + { + $self->{proto_num} = eval { (getprotobyname('udp'))[2] } || + croak("Can't udp protocol by name"); + $self->{port_num} = $self->{port} + || (getservbyname('echo', 'udp'))[2] + || croak("Can't get udp echo port by name"); + $self->{fh} = FileHandle->new(); + socket($self->{fh}, PF_INET, SOCK_DGRAM, + $self->{proto_num}) || + croak("udp socket error - $!"); + $self->_setopts(); + } + elsif ($self->{proto} eq "icmp") + { + croak("icmp ping requires root privilege") if !_isroot(); + $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } || + croak("Can't get icmp protocol by name"); + $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{fh} = FileHandle->new(); + socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) || + croak("icmp socket error - $!"); + $self->_setopts(); + if ($self->{'ttl'}) { + setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) + or croak "error configuring ttl to $self->{'ttl'} $!"; + } + } + elsif ($self->{proto} eq "icmpv6") + { + croak("icmpv6 ping requires root privilege") if !_isroot(); + croak("Wrong family $self->{family} for icmpv6 protocol") + if $self->{family} and $self->{family} != $AF_INET6; + $self->{family} = $AF_INET6; + $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } || + croak("Can't get ipv6-icmp protocol by name"); # 58 + $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid + $self->{fh} = FileHandle->new(); + socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) || + croak("icmp socket error - $!"); + $self->_setopts(); + if ($self->{'gateway'}) { + my $g = $self->{gateway}; + my $ip = _resolv($g) + or croak("nonexistent gateway $g"); + $self->{family} eq $AF_INET6 + or croak("gateway requires the AF_INET6 family"); + $ip->{family} eq $AF_INET6 + or croak("gateway address needs to be IPv6"); + my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21 + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip)) + or croak "error configuring gateway to $g NEXTHOP $!"; + } + if (exists $self->{IPV6_USE_MIN_MTU}) { + my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, + pack("I*", $self->{'IPV6_USE_MIN_MT'})) + or croak "error configuring IPV6_USE_MIN_MT} $!"; + } + if (exists $self->{IPV6_RECVPATHMTU}) { + my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, + pack("I*", $self->{'RECVPATHMTU'})) + or croak "error configuring IPV6_RECVPATHMTU $!"; + } + if ($self->{'tos'}) { + my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; + setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'})) + or croak "error configuring tos to $self->{'tos'} $!"; + } + if ($self->{'ttl'}) { + my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; + setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'})) + or croak "error configuring ttl to $self->{'ttl'} $!"; + } + } + elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream") + { + $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || + croak("Can't get tcp protocol by name"); + $self->{port_num} = $self->{port} + || (getservbyname('echo', 'tcp'))[2] + || croak("Can't get tcp echo port by name"); + $self->{fh} = FileHandle->new(); + } + elsif ($self->{proto} eq "syn") + { + $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || + croak("Can't get tcp protocol by name"); + $self->{port_num} = (getservbyname('echo', 'tcp'))[2] || + croak("Can't get tcp echo port by name"); + if ($syn_forking) { + $self->{fork_rd} = FileHandle->new(); + $self->{fork_wr} = FileHandle->new(); + pipe($self->{fork_rd}, $self->{fork_wr}); + $self->{fh} = FileHandle->new(); + $self->{good} = {}; + $self->{bad} = {}; + } else { + $self->{wbits} = ""; + $self->{bad} = {}; + } + $self->{syn} = {}; + $self->{stop_time} = 0; + } + + return($self); +} + +# Description: Set the local IP address from which pings will be sent. +# For ICMP, UDP and TCP pings, just saves the address to be used when +# the socket is opened. Returns non-zero if successful; croaks on error. +sub bind +{ + my ($self, + $local_addr # Name or IP number of local interface + ) = @_; + my ($ip, # Hash of addr (string), addr_in (packed), family + $h # resolved hash + ); + + croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; + croak("already bound") if defined($self->{local_addr}) && + ($self->{proto} eq "udp" || $self->{proto} eq "icmp"); + + $ip = $self->_resolv($local_addr); + croak("nonexistent local address $local_addr") unless defined($ip); + $self->{local_addr} = $ip; + + if (($self->{proto} ne "udp") && + ($self->{proto} ne "icmp") && + ($self->{proto} ne "tcp") && + ($self->{proto} ne "syn")) + { + croak("Unknown protocol \"$self->{proto}\" in bind()"); + } + + return 1; +} + +# Description: A select() wrapper that compensates for platform +# peculiarities. +sub mselect +{ + if ($_[3] > 0 and $^O eq 'MSWin32') { + # On windows, select() doesn't process the message loop, + # but sleep() will, allowing alarm() to interrupt the latter. + # So we chop up the timeout into smaller pieces and interleave + # select() and sleep() calls. + my $t = $_[3]; + my $gran = 0.5; # polling granularity in seconds + my @args = @_; + while (1) { + $gran = $t if $gran > $t; + my $nfound = select($_[0], $_[1], $_[2], $gran); + undef $nfound if $nfound == -1; + $t -= $gran; + return $nfound if $nfound or !defined($nfound) or $t <= 0; + + sleep(0); + ($_[0], $_[1], $_[2]) = @args; + } + } + else { + my $nfound = select($_[0], $_[1], $_[2], $_[3]); + undef $nfound if $nfound == -1; + return $nfound; + } +} + +# Description: Allow UDP source endpoint comparison to be +# skipped for those remote interfaces that do +# not response from the same endpoint. + +sub source_verify +{ + my $self = shift; + $source_verify = 1 unless defined + ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self); +} + +# Description: Set whether or not the connect +# behavior should enforce remote service +# availability as well as reachability. + +sub service_check +{ + my $self = shift; + $self->{econnrefused} = 1 unless defined + ($self->{econnrefused} = shift()); +} + +sub tcp_service_check +{ + service_check(@_); +} + +# Description: Set exponential backoff for retransmission. +# Should be > 1 to retain exponential properties. +# If set to 0, retransmissions are disabled. + +sub retrans +{ + my $self = shift; + $self->{retrans} = shift; +} + +sub _IsAdminUser { + return unless $^O eq 'MSWin32' or $^O eq "cygwin"; + return unless eval { require Win32 }; + return unless defined &Win32::IsAdminUser; + return Win32::IsAdminUser(); +} + +sub _isroot { + if (($> and $^O ne 'VMS' and $^O ne 'cygwin') + or (($^O eq 'MSWin32' or $^O eq 'cygwin') + and !_IsAdminUser()) + or ($^O eq 'VMS' + and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) { + return 0; + } + else { + return 1; + } +} + +# Description: Sets ipv6 reachability +# REACHCONF was removed in RFC3542, ping6 -R supports it. requires root. + +sub IPV6_REACHCONF +{ + my $self = shift; + my $on = shift; + if ($on) { + my $reachconf = eval { Socket::IPV6_REACHCONF() }; + if (!$reachconf) { + carp "IPV6_REACHCONF not supported on this platform"; + return 0; + } + if (!_isroot()) { + carp "IPV6_REACHCONF requires root permissions"; + return 0; + } + $self->{IPV6_REACHCONF} = 1; + } + else { + return $self->{IPV6_REACHCONF}; + } +} + +# Description: set it on or off. + +sub IPV6_USE_MIN_MTU +{ + my $self = shift; + my $on = shift; + if (defined $on) { + my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43; + #if (!$IPV6_USE_MIN_MTU) { + # carp "IPV6_USE_MIN_MTU not supported on this platform"; + # return 0; + #} + $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, + pack("I*", $self->{'IPV6_USE_MIN_MT'})) + or croak "error configuring IPV6_USE_MIN_MT} $!"; + } + else { + return $self->{IPV6_USE_MIN_MTU}; + } +} + +# Description: notify an according MTU + +sub IPV6_RECVPATHMTU +{ + my $self = shift; + my $on = shift; + if ($on) { + my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; + #if (!$RECVPATHMTU) { + # carp "IPV6_RECVPATHMTU not supported on this platform"; + # return 0; + #} + $self->{IPV6_RECVPATHMTU} = 1; + setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, + pack("I*", $self->{'IPV6_RECVPATHMTU'})) + or croak "error configuring IPV6_RECVPATHMTU} $!"; + } + else { + return $self->{IPV6_RECVPATHMTU}; + } +} + +# Description: allows the module to use milliseconds as returned by +# the Time::HiRes module + +$hires = 1; +sub hires +{ + my $self = shift; + $hires = 1 unless defined + ($hires = ((defined $self) && (ref $self)) ? shift() : $self); +} + +sub time +{ + return $hires ? Time::HiRes::time() : CORE::time(); +} + +# Description: Sets or clears the O_NONBLOCK flag on a file handle. +sub socket_blocking_mode +{ + my ($self, + $fh, # the file handle whose flags are to be modified + $block) = @_; # if true then set the blocking + # mode (clear O_NONBLOCK), otherwise + # set the non-blocking mode (set O_NONBLOCK) + + my $flags; + if ($^O eq 'MSWin32' || $^O eq 'VMS') { + # FIONBIO enables non-blocking sockets on windows and vms. + # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h + my $f = 0x8004667e; + my $v = pack("L", $block ? 0 : 1); + ioctl($fh, $f, $v) or croak("ioctl failed: $!"); + return; + } + if ($flags = fcntl($fh, F_GETFL, 0)) { + $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK); + if (!fcntl($fh, F_SETFL, $flags)) { + croak("fcntl F_SETFL: $!"); + } + } else { + croak("fcntl F_GETFL: $!"); + } +} + +# Description: Ping a host name or IP number with an optional timeout. +# First lookup the host, and return undef if it is not found. Otherwise +# perform the specific ping method based on the protocol. Return the +# result of the ping. + +sub ping +{ + my ($self, + $host, # Name or IP number of host to ping + $timeout, # Seconds after which ping times out + $family, # Address family + ) = @_; + my ($ip, # Hash of addr (string), addr_in (packed), family + $ret, # The return value + $ping_time, # When ping began + ); + + $host = $self->{host} if !defined $host and $self->{host}; + croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host; + $timeout = $self->{timeout} unless $timeout; + croak("Timeout must be greater than 0 seconds") if $timeout <= 0; + + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family_local} = AF_INET; + } else { + $self->{family_local} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family_local} = $self->{family}; + } + + $ip = $self->_resolv($host); + return () unless defined($ip); # Does host exist? + + # Dispatch to the appropriate routine. + $ping_time = &time(); + if ($self->{proto} eq "external") { + $ret = $self->ping_external($ip, $timeout); + } + elsif ($self->{proto} eq "udp") { + $ret = $self->ping_udp($ip, $timeout); + } + elsif ($self->{proto} eq "icmp") { + $ret = $self->ping_icmp($ip, $timeout); + } + elsif ($self->{proto} eq "icmpv6") { + $ret = $self->ping_icmpv6($ip, $timeout); + } + elsif ($self->{proto} eq "tcp") { + $ret = $self->ping_tcp($ip, $timeout); + } + elsif ($self->{proto} eq "stream") { + $ret = $self->ping_stream($ip, $timeout); + } + elsif ($self->{proto} eq "syn") { + $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout); + } else { + croak("Unknown protocol \"$self->{proto}\" in ping()"); + } + + return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret; +} + +# Uses Net::Ping::External to do an external ping. +sub ping_external { + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout, # Seconds after which ping times out + $family + ) = @_; + + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + my @addr = exists $ip->{addr_in} + ? ('ip' => $ip->{addr_in}) + : ('host' => $ip->{host}); + + eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + require Net::Ping::External; + } or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); + return Net::Ping::External::ping(@addr, timeout => $timeout, + family => $family); +} + +# h2ph "asm/socket.h" +# require "asm/socket.ph"; +use constant SO_BINDTODEVICE => 25; +use constant ICMP_ECHOREPLY => 0; # ICMP packet types +use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types +use constant ICMP_UNREACHABLE => 3; # ICMP packet types +use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types +use constant ICMP_ECHO => 8; +use constant ICMPv6_ECHO => 128; +use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types +use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types +use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet +use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY +use constant ICMP_FLAGS => 0; # No special flags for send or recv +use constant ICMP_PORT => 0; # No port with ICMP +use constant IP_MTU_DISCOVER => 10; # linux only + +sub ping_icmp +{ + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout # Seconds after which ping times out + ) = @_; + + my ($saddr, # sockaddr_in with port and ip + $checksum, # Checksum of ICMP packet + $msg, # ICMP packet to send + $len_msg, # Length of $msg + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $finish_time, # Time ping should be finished + $done, # set to 1 when we are done + $ret, # Return value + $recv_msg, # Received message including IP header + $from_saddr, # sockaddr_in of sender + $from_port, # Port packet was sent from + $from_ip, # Packed IP of sender + $from_type, # ICMP type + $from_subcode, # ICMP subcode + $from_chk, # ICMP packet checksum + $from_pid, # ICMP packet id + $from_seq, # ICMP packet sequence + $from_msg # ICMP message + ); + + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + + socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) || + croak("icmp socket error - $!"); + + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("icmp bind error - $!"); + } + $self->_setopts(); + + $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence + $checksum = 0; # No checksum for starters + if ($ip->{family} == AF_INET) { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } else { + # how to get SRC + my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), "\0", 0x003a); + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + $msg = $pseudo_header.$msg + } + $checksum = Net::Ping->checksum($msg); + if ($ip->{family} == AF_INET) { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } else { + $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, + $checksum, $self->{pid}, $self->{seq}, $self->{data}); + } + $len_msg = length($msg); + $saddr = _pack_sockaddr_in(ICMP_PORT, $ip); + $self->{from_ip} = undef; + $self->{from_type} = undef; + $self->{from_subcode} = undef; + send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message + + $rbits = ""; + vec($rbits, $self->{fh}->fileno(), 1) = 1; + $ret = 0; + $done = 0; + $finish_time = &time() + $timeout; # Must be done by this time + while (!$done && $timeout > 0) # Keep trying if we have time + { + $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet + $timeout = $finish_time - &time(); # Get remaining time + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # Got a packet from somewhere + { + $recv_msg = ""; + $from_pid = -1; + $from_seq = -1; + $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS); + ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); + ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2)); + if ($from_type == ICMP_ECHOREPLY) { + ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) + if length $recv_msg >= 28; + } elsif ($from_type == ICMPv6_ECHOREPLY) { + ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) + if length $recv_msg >= 28; + } else { + ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4)) + if length $recv_msg >= 56; + } + $self->{from_ip} = $from_ip; + $self->{from_type} = $from_type; + $self->{from_subcode} = $from_subcode; + next if ($from_pid != $self->{pid}); + next if ($from_seq != $self->{seq}); + if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out? + if (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY)) { + $ret = 1; + $done = 1; + } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) { + $done = 1; + } elsif ($from_type == ICMP_TIME_EXCEEDED) { + $ret = 0; + $done = 1; + } + } + } else { # Oops, timed out + $done = 1; + } + } + return $ret; +} + +sub ping_icmpv6 +{ + shift->ping_icmp(@_); +} + +sub icmp_result { + my ($self) = @_; + my $addr = $self->{from_ip} || ""; + $addr = "\0\0\0\0" unless 4 == length $addr; + return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0)); +} + +# Description: Do a checksum on the message. Basically sum all of +# the short words and fold the high order bits into the low order bits. + +sub checksum +{ + my ($class, + $msg # The message to checksum + ) = @_; + my ($len_msg, # Length of the message + $num_short, # The number of short words in the message + $short, # One short word + $chk # The checksum + ); + + $len_msg = length($msg); + $num_short = int($len_msg / 2); + $chk = 0; + foreach $short (unpack("n$num_short", $msg)) + { + $chk += $short; + } # Add the odd byte in + $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; + $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low + return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement +} + + +# Description: Perform a tcp echo ping. Since a tcp connection is +# host specific, we have to open and close each connection here. We +# can't just leave a socket open. Because of the robust nature of +# tcp, it will take a while before it gives up trying to establish a +# connection. Therefore, we use select() on a non-blocking socket to +# check against our timeout. No data bytes are actually +# sent since the successful establishment of a connection is proof +# enough of the reachability of the remote host. Also, tcp is +# expensive and doesn't need our help to add to the overhead. + +sub ping_tcp +{ + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout # Seconds after which ping times out + ) = @_; + my ($ret # The return value + ); + + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + + $! = 0; + $ret = $self -> tcp_connect( $ip, $timeout); + if (!$self->{econnrefused} && + $! == ECONNREFUSED) { + $ret = 1; # "Connection refused" means reachable + } + $self->{fh}->close(); + return $ret; +} + +sub tcp_connect +{ + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout # Seconds after which connect times out + ) = @_; + my ($saddr); # Packed IP and Port + + $ip = $self->{host} if !defined $ip and $self->{host}; + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + + $saddr = _pack_sockaddr_in($self->{port_num}, $ip); + + my $ret = 0; # Default to unreachable + + my $do_socket = sub { + socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) || + croak("tcp socket error - $!"); + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("tcp bind error - $!"); + } + $self->_setopts(); + }; + my $do_connect = sub { + $self->{ip} = $ip->{addr_in}; + # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?, + # we'll get (10061 & 255) = 77, so we cannot check it in the parent process. + return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused})); + }; + my $do_connect_nb = sub { + # Set O_NONBLOCK property on filehandle + $self->socket_blocking_mode($self->{fh}, 0); + + # start the connection attempt + if (!connect($self->{fh}, $saddr)) { + if ($! == ECONNREFUSED) { + $ret = 1 unless $self->{econnrefused}; + } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) { + # EINPROGRESS is the expected error code after a connect() + # on a non-blocking socket. But if the kernel immediately + # determined that this connect() will never work, + # Simply respond with "unreachable" status. + # (This can occur on some platforms with errno + # EHOSTUNREACH or ENETUNREACH.) + return 0; + } else { + # Got the expected EINPROGRESS. + # Just wait for connection completion... + my ($wbits, $wout, $wexc); + $wout = $wexc = $wbits = ""; + vec($wbits, $self->{fh}->fileno, 1) = 1; + + my $nfound = mselect(undef, + ($wout = $wbits), + ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef), + $timeout); + warn("select: $!") unless defined $nfound; + + if ($nfound && vec($wout, $self->{fh}->fileno, 1)) { + # the socket is ready for writing so the connection + # attempt completed. test whether the connection + # attempt was successful or not + + if (getpeername($self->{fh})) { + # Connection established to remote host + $ret = 1; + } else { + # TCP ACK will never come from this host + # because there was an error connecting. + + # This should set $! to the correct error. + my $char; + sysread($self->{fh},$char,1); + $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i); + + $ret = 1 if (!$self->{econnrefused} + && $! == ECONNREFUSED); + } + } else { + # the connection attempt timed out (or there were connect + # errors on Windows) + if ($^O =~ 'MSWin32') { + # If the connect will fail on a non-blocking socket, + # winsock reports ECONNREFUSED as an exception, and we + # need to fetch the socket-level error code via getsockopt() + # instead of using the thread-level error code that is in $!. + if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) { + $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET, + SO_ERROR)); + } + } + } + } + } else { + # Connection established to remote host + $ret = 1; + } + + # Unset O_NONBLOCK property on filehandle + $self->socket_blocking_mode($self->{fh}, 1); + $self->{ip} = $ip->{addr_in}; + return $ret; + }; + + if ($syn_forking) { + # Buggy Winsock API doesn't allow nonblocking connect. + # Hence, if our OS is Windows, we need to create a separate + # process to do the blocking connect attempt. + # XXX Above comments are not true at least for Win2K, where + # nonblocking connect works. + + $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. + $self->{'tcp_chld'} = fork; + if (!$self->{'tcp_chld'}) { + if (!defined $self->{'tcp_chld'}) { + # Fork did not work + warn "Fork error: $!"; + return 0; + } + &{ $do_socket }(); + + # Try a slow blocking connect() call + # and report the status to the parent. + if ( &{ $do_connect }() ) { + $self->{fh}->close(); + # No error + exit 0; + } else { + # Pass the error status to the parent + # Make sure that $! <= 255 + exit($! <= 255 ? $! : 255); + } + } + + &{ $do_socket }(); + + my $patience = &time() + $timeout; + + my ($child, $child_errno); + $? = 0; $child_errno = 0; + # Wait up to the timeout + # And clean off the zombie + do { + $child = waitpid($self->{'tcp_chld'}, &WNOHANG()); + $child_errno = $? >> 8; + select(undef, undef, undef, 0.1); + } while &time() < $patience && $child != $self->{'tcp_chld'}; + + if ($child == $self->{'tcp_chld'}) { + if ($self->{proto} eq "stream") { + # We need the socket connected here, in parent + # Should be safe to connect because the child finished + # within the timeout + &{ $do_connect }(); + } + # $ret cannot be set by the child process + $ret = !$child_errno; + } else { + # Time must have run out. + # Put that choking client out of its misery + kill "KILL", $self->{'tcp_chld'}; + # Clean off the zombie + waitpid($self->{'tcp_chld'}, 0); + $ret = 0; + } + delete $self->{'tcp_chld'}; + $! = $child_errno; + } else { + # Otherwise don't waste the resources to fork + + &{ $do_socket }(); + + &{ $do_connect_nb }(); + } + + return $ret; +} + +sub DESTROY { + my $self = shift; + if ($self->{'proto'} eq 'tcp' && + $self->{'tcp_chld'}) { + # Put that choking client out of its misery + kill "KILL", $self->{'tcp_chld'}; + # Clean off the zombie + waitpid($self->{'tcp_chld'}, 0); + } +} + +# This writes the given string to the socket and then reads it +# back. It returns 1 on success, 0 on failure. +sub tcp_echo +{ + my ($self, $timeout, $pingstring) = @_; + + $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; + $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring}; + + my $ret = undef; + my $time = &time(); + my $wrstr = $pingstring; + my $rdstr = ""; + + eval <<'EOM'; + do { + my $rin = ""; + vec($rin, $self->{fh}->fileno(), 1) = 1; + + my $rout = undef; + if($wrstr) { + $rout = ""; + vec($rout, $self->{fh}->fileno(), 1) = 1; + } + + if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) { + + if($rout && vec($rout,$self->{fh}->fileno(),1)) { + my $num = syswrite($self->{fh}, $wrstr, length $wrstr); + if($num) { + # If it was a partial write, update and try again. + $wrstr = substr($wrstr,$num); + } else { + # There was an error. + $ret = 0; + } + } + + if(vec($rin,$self->{fh}->fileno(),1)) { + my $reply; + if(sysread($self->{fh},$reply,length($pingstring)-length($rdstr))) { + $rdstr .= $reply; + $ret = 1 if $rdstr eq $pingstring; + } else { + # There was an error. + $ret = 0; + } + } + + } + } until &time() > ($time + $timeout) || defined($ret); +EOM + + return $ret; +} + +# Description: Perform a stream ping. If the tcp connection isn't +# already open, it opens it. It then sends some data and waits for +# a reply. It leaves the stream open on exit. + +sub ping_stream +{ + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout # Seconds after which ping times out + ) = @_; + + # Open the stream if it's not already open + if(!defined $self->{fh}->fileno()) { + $self->tcp_connect($ip, $timeout) or return 0; + } + + croak "tried to switch servers while stream pinging" + if $self->{ip} ne $ip->{addr_in}; + + return $self->tcp_echo($timeout, $pingstring); +} + +# Description: opens the stream. You would do this if you want to +# separate the overhead of opening the stream from the first ping. + +sub open +{ + my ($self, + $host, # Host or IP address + $timeout, # Seconds after which open times out + $family + ) = @_; + my $ip; # Hash of addr (string), addr_in (packed), family + $host = $self->{host} unless defined $host; + + if ($family) { + if ($family =~ $qr_family) { + if ($family =~ $qr_family4) { + $self->{family_local} = AF_INET; + } else { + $self->{family_local} = $AF_INET6; + } + } else { + croak('Family must be "ipv4" or "ipv6"') + } + } else { + $self->{family_local} = $self->{family}; + } + + $ip = $self->_resolv($host); + $timeout = $self->{timeout} unless $timeout; + + if($self->{proto} eq "stream") { + if(defined($self->{fh}->fileno())) { + croak("socket is already open"); + } else { + $self->tcp_connect($ip, $timeout); + } + } +} + +sub _dontfrag { + my $self = shift; + # bsd solaris + my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() }; + if ($IP_DONTFRAG) { + my $i = 1; + setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i)) + or croak "error configuring IP_DONTFRAG $!"; + # Linux needs more: Path MTU Discovery as defined in RFC 1191 + # For non SOCK_STREAM sockets it is the user's responsibility to packetize + # the data in MTU sized chunks and to do the retransmits if necessary. + # The kernel will reject packets that are bigger than the known path + # MTU if this flag is set (with EMSGSIZE). + if ($^O eq 'linux') { + my $i = 2; # IP_PMTUDISC_DO + setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i)) + or croak "error configuring IP_MTU_DISCOVER $!"; + } + } +} + +# SO_BINDTODEVICE + IP_TOS +sub _setopts { + my $self = shift; + if ($self->{'device'}) { + setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'})) + or croak "error binding to device $self->{'device'} $!"; + } + if ($self->{'tos'}) { # need to re-apply ToS (RT #6706) + setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) + or croak "error applying tos to $self->{'tos'} $!"; + } + if ($self->{'dontfrag'}) { + $self->_dontfrag; + } +} + + +# Description: Perform a udp echo ping. Construct a message of +# at least the one-byte sequence number and any additional data bytes. +# Send the message out and wait for a message to come back. If we +# get a message, make sure all of its parts match. If they do, we are +# done. Otherwise go back and wait for the message until we run out +# of time. Return the result of our efforts. + +use constant UDP_FLAGS => 0; # Nothing special on send or recv +sub ping_udp +{ + my ($self, + $ip, # Hash of addr (string), addr_in (packed), family + $timeout # Seconds after which ping times out + ) = @_; + + my ($saddr, # sockaddr_in with port and ip + $ret, # The return value + $msg, # Message to be echoed + $finish_time, # Time ping should be finished + $flush, # Whether socket needs to be disconnected + $connect, # Whether socket needs to be connected + $done, # Set to 1 when we are done pinging + $rbits, # Read bits, filehandles for reading + $nfound, # Number of ready filehandles found + $from_saddr, # sockaddr_in of sender + $from_msg, # Characters echoed by $host + $from_port, # Port message was echoed from + $from_ip # Packed IP number of sender + ); + + $saddr = _pack_sockaddr_in($self->{port_num}, $ip); + $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence + $msg = chr($self->{seq}) . $self->{data}; # Add data if any + + socket($self->{fh}, $ip->{family}, SOCK_DGRAM, + $self->{proto_num}) || + croak("udp socket error - $!"); + + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("udp bind error - $!"); + } + + $self->_setopts(); + + if ($self->{connected}) { + if ($self->{connected} ne $saddr) { + # Still connected to wrong destination. + # Need to flush out the old one. + $flush = 1; + } + } else { + # Not connected yet. + # Need to connect() before send() + $connect = 1; + } + + # Have to connect() and send() instead of sendto() + # in order to pick up on the ECONNREFUSED setting + # from recv() or double send() errno as utilized in + # the concept by rdw @ perlmonks. See: + # http://perlmonks.thepen.com/42898.html + if ($flush) { + # Need to socket() again to flush the descriptor + # This will disconnect from the old saddr. + socket($self->{fh}, $ip->{family}, SOCK_DGRAM, + $self->{proto_num}); + $self->_setopts(); + } + # Connect the socket if it isn't already connected + # to the right destination. + if ($flush || $connect) { + connect($self->{fh}, $saddr); # Tie destination to socket + $self->{connected} = $saddr; + } + send($self->{fh}, $msg, UDP_FLAGS); # Send it + + $rbits = ""; + vec($rbits, $self->{fh}->fileno(), 1) = 1; + $ret = 0; # Default to unreachable + $done = 0; + my $retrans = 0.01; + my $factor = $self->{retrans}; + $finish_time = &time() + $timeout; # Ping needs to be done by then + while (!$done && $timeout > 0) + { + if ($factor > 1) + { + $timeout = $retrans if $timeout > $retrans; + $retrans*= $factor; # Exponential backoff + } + $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response + my $why = $!; + $timeout = $finish_time - &time(); # Get remaining time + + if (!defined($nfound)) # Hmm, a strange error + { + $ret = undef; + $done = 1; + } + elsif ($nfound) # A packet is waiting + { + $from_msg = ""; + $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS); + if (!$from_saddr) { + # For example an unreachable host will make recv() fail. + if (!$self->{econnrefused} && + ($! == ECONNREFUSED || + $! == ECONNRESET)) { + # "Connection refused" means reachable + # Good, continue + $ret = 1; + } + $done = 1; + } else { + ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); + my $addr_in = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; + if (!$source_verify || + (($from_ip eq $addr_in) && # Does the packet check out? + ($from_port == $self->{port_num}) && + ($from_msg eq $msg))) + { + $ret = 1; # It's a winner + $done = 1; + } + } + } + elsif ($timeout <= 0) # Oops, timed out + { + $done = 1; + } + else + { + # Send another in case the last one dropped + if (send($self->{fh}, $msg, UDP_FLAGS)) { + # Another send worked? The previous udp packet + # must have gotten lost or is still in transit. + # Hopefully this new packet will arrive safely. + } else { + if (!$self->{econnrefused} && + $! == ECONNREFUSED) { + # "Connection refused" means reachable + # Good, continue + $ret = 1; + } + $done = 1; + } + } + } + return $ret; +} + +# Description: Send a TCP SYN packet to host specified. +sub ping_syn +{ + my $self = shift; + my $host = shift; + my $ip = shift; + my $start_time = shift; + my $stop_time = shift; + + if ($syn_forking) { + return $self->ping_syn_fork($host, $ip, $start_time, $stop_time); + } + + my $fh = FileHandle->new(); + my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); + + # Create TCP socket + if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { + croak("tcp socket error - $!"); + } + + if (defined $self->{local_addr} && + !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("tcp bind error - $!"); + } + + $self->_setopts(); + # Set O_NONBLOCK property on filehandle + $self->socket_blocking_mode($fh, 0); + + # Attempt the non-blocking connect + # by just sending the TCP SYN packet + if (connect($fh, $saddr)) { + # Non-blocking, yet still connected? + # Must have connected very quickly, + # or else it wasn't very non-blocking. + #warn "WARNING: Nonblocking connect connected anyway? ($^O)"; + } else { + # Error occurred connecting. + if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) { + # The connection is just still in progress. + # This is the expected condition. + } else { + # Just save the error and continue on. + # The ack() can check the status later. + $self->{bad}->{$host} = $!; + } + } + + my $entry = [ $host, $ip, $fh, $start_time, $stop_time, $self->{port_num} ]; + $self->{syn}->{$fh->fileno} = $entry; + if ($self->{stop_time} < $stop_time) { + $self->{stop_time} = $stop_time; + } + vec($self->{wbits}, $fh->fileno, 1) = 1; + + return 1; +} + +sub ping_syn_fork { + my ($self, $host, $ip, $start_time, $stop_time) = @_; + + # Buggy Winsock API doesn't allow nonblocking connect. + # Hence, if our OS is Windows, we need to create a separate + # process to do the blocking connect attempt. + my $pid = fork(); + if (defined $pid) { + if ($pid) { + # Parent process + my $entry = [ $host, $ip, $pid, $start_time, $stop_time ]; + $self->{syn}->{$pid} = $entry; + if ($self->{stop_time} < $stop_time) { + $self->{stop_time} = $stop_time; + } + } else { + # Child process + my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); + + # Create TCP socket + if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { + croak("tcp socket error - $!"); + } + + if (defined $self->{local_addr} && + !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { + croak("tcp bind error - $!"); + } + + $self->_setopts(); + + $!=0; + # Try to connect (could take a long time) + connect($self->{fh}, $saddr); + # Notify parent of connect error status + my $err = $!+0; + my $wrstr = "$$ $err"; + # Force to 16 chars including \n + $wrstr .= " "x(15 - length $wrstr). "\n"; + syswrite($self->{fork_wr}, $wrstr, length $wrstr); + exit; + } + } else { + # fork() failed? + die "fork: $!"; + } + return 1; +} + +# Description: Wait for TCP ACK from host specified +# from ping_syn above. If no host is specified, wait +# for TCP ACK from any of the hosts in the SYN queue. +sub ack +{ + my $self = shift; + + if ($self->{proto} eq "syn") { + if ($syn_forking) { + my @answer = $self->ack_unfork(shift); + return wantarray ? @answer : $answer[0]; + } + my $wbits = ""; + my $stop_time = 0; + if (my $host = shift or $self->{host}) { + # Host passed as arg or as option to new + $host = $self->{host} unless defined $host; + if (exists $self->{bad}->{$host}) { + if (!$self->{econnrefused} && + $self->{bad}->{ $host } && + (($! = ECONNREFUSED)>0) && + $self->{bad}->{ $host } eq "$!") { + # "Connection refused" means reachable + # Good, continue + } else { + # ECONNREFUSED means no good + return (); + } + } + my $host_fd = undef; + foreach my $fd (keys %{ $self->{syn} }) { + my $entry = $self->{syn}->{$fd}; + if ($entry->[0] eq $host) { + $host_fd = $fd; + $stop_time = $entry->[4] + || croak("Corrupted SYN entry for [$host]"); + last; + } + } + croak("ack called on [$host] without calling ping first!") + unless defined $host_fd; + vec($wbits, $host_fd, 1) = 1; + } else { + # No $host passed so scan all hosts + # Use the latest stop_time + $stop_time = $self->{stop_time}; + # Use all the bits + $wbits = $self->{wbits}; + } + + while ($wbits !~ /^\0*\z/) { + my $timeout = $stop_time - &time(); + # Force a minimum of 10 ms timeout. + $timeout = 0.01 if $timeout <= 0.01; + + my $winner_fd = undef; + my $wout = $wbits; + my $fd = 0; + # Do "bad" fds from $wbits first + while ($wout !~ /^\0*\z/) { + if (vec($wout, $fd, 1)) { + # Wipe it from future scanning. + vec($wout, $fd, 1) = 0; + if (my $entry = $self->{syn}->{$fd}) { + if ($self->{bad}->{ $entry->[0] }) { + $winner_fd = $fd; + last; + } + } + } + $fd++; + } + + if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) { + if (defined $winner_fd) { + $fd = $winner_fd; + } else { + # Done waiting for one of the ACKs + $fd = 0; + # Determine which one + while ($wout !~ /^\0*\z/ && + !vec($wout, $fd, 1)) { + $fd++; + } + } + if (my $entry = $self->{syn}->{$fd}) { + # Wipe it from future scanning. + delete $self->{syn}->{$fd}; + vec($self->{wbits}, $fd, 1) = 0; + vec($wbits, $fd, 1) = 0; + if (!$self->{econnrefused} && + $self->{bad}->{ $entry->[0] } && + (($! = ECONNREFUSED)>0) && + $self->{bad}->{ $entry->[0] } eq "$!") { + # "Connection refused" means reachable + # Good, continue + } elsif (getpeername($entry->[2])) { + # Connection established to remote host + # Good, continue + } else { + # TCP ACK will never come from this host + # because there was an error connecting. + + # This should set $! to the correct error. + my $char; + sysread($entry->[2],$char,1); + # Store the excuse why the connection failed. + $self->{bad}->{$entry->[0]} = $!; + if (!$self->{econnrefused} && + (($! == ECONNREFUSED) || + ($! == EAGAIN && $^O =~ /cygwin/i))) { + # "Connection refused" means reachable + # Good, continue + } else { + # No good, try the next socket... + next; + } + } + # Everything passed okay, return the answer + return wantarray ? + ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1]), $entry->[5]) + : $entry->[0]; + } else { + warn "Corrupted SYN entry: unknown fd [$fd] ready!"; + vec($wbits, $fd, 1) = 0; + vec($self->{wbits}, $fd, 1) = 0; + } + } elsif (defined $nfound) { + # Timed out waiting for ACK + foreach my $fd (keys %{ $self->{syn} }) { + if (vec($wbits, $fd, 1)) { + my $entry = $self->{syn}->{$fd}; + $self->{bad}->{$entry->[0]} = "Timed out"; + vec($wbits, $fd, 1) = 0; + vec($self->{wbits}, $fd, 1) = 0; + delete $self->{syn}->{$fd}; + } + } + } else { + # Weird error occurred with select() + warn("select: $!"); + $self->{syn} = {}; + $wbits = ""; + } + } + } + return (); +} + +sub ack_unfork { + my ($self,$host) = @_; + my $stop_time = $self->{stop_time}; + if ($host) { + # Host passed as arg + if (my $entry = $self->{good}->{$host}) { + delete $self->{good}->{$host}; + return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); + } + } + + my $rbits = ""; + my $timeout; + + if (keys %{ $self->{syn} }) { + # Scan all hosts that are left + vec($rbits, fileno($self->{fork_rd}), 1) = 1; + $timeout = $stop_time - &time(); + # Force a minimum of 10 ms timeout. + $timeout = 0.01 if $timeout < 0.01; + } else { + # No hosts left to wait for + $timeout = 0; + } + + if ($timeout > 0) { + my $nfound; + while ( keys %{ $self->{syn} } and + $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) { + # Done waiting for one of the ACKs + if (!sysread($self->{fork_rd}, $_, 16)) { + # Socket closed, which means all children are done. + return (); + } + my ($pid, $how) = split; + if ($pid) { + # Flush the zombie + waitpid($pid, 0); + if (my $entry = $self->{syn}->{$pid}) { + # Connection attempt to remote host is done + delete $self->{syn}->{$pid}; + if (!$how || # If there was no error connecting + (!$self->{econnrefused} && + $how == ECONNREFUSED)) { # "Connection refused" means reachable + if ($host && $entry->[0] ne $host) { + # A good connection, but not the host we need. + # Move it from the "syn" hash to the "good" hash. + $self->{good}->{$entry->[0]} = $entry; + # And wait for the next winner + next; + } + return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); + } + } else { + # Should never happen + die "Unknown ping from pid [$pid]"; + } + } else { + die "Empty response from status socket?"; + } + } + if (defined $nfound) { + # Timed out waiting for ACK status + } else { + # Weird error occurred with select() + warn("select: $!"); + } + } + if (my @synners = keys %{ $self->{syn} }) { + # Kill all the synners + kill 9, @synners; + foreach my $pid (@synners) { + # Wait for the deaths to finish + # Then flush off the zombie + waitpid($pid, 0); + } + } + $self->{syn} = {}; + return (); +} + +# Description: Tell why the ack() failed +sub nack { + my $self = shift; + my $host = shift || croak('Usage> nack($failed_ack_host)'); + return $self->{bad}->{$host} || undef; +} + +# Description: Close the connection. + +sub close +{ + my ($self) = @_; + + if ($self->{proto} eq "syn") { + delete $self->{syn}; + } elsif ($self->{proto} eq "tcp") { + # The connection will already be closed + } elsif ($self->{proto} eq "external") { + # Nothing to close + } else { + $self->{fh}->close(); + } +} + +sub port_number { + my $self = shift; + if(@_) { + $self->{port_num} = shift @_; + $self->service_check(1); + } + return $self->{port_num}; +} + +sub ntop { + my($self, $ip) = @_; + + # Vista doesn't define a inet_ntop. It has InetNtop instead. + # Not following ANSI... priceless. getnameinfo() is defined + # for Windows 2000 and later, so that may be the choice. + + # Any port will work, even undef, but this will work for now. + # Socket warns when undef is passed in, but it still works. + my $port = getservbyname('echo', 'udp'); + my $sockaddr = _pack_sockaddr_in($port, $ip); + my ($error, $address) = getnameinfo($sockaddr, $NI_NUMERICHOST); + croak $error if $error; + return $address; +} + +sub wakeonlan { + my ($mac_addr, $host, $port) = @_; + + # use the discard service if $port not passed in + if (! defined $host) { $host = '255.255.255.255' } + if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 } + + require IO::Socket::INET; + my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef; + + my $ip_addr = inet_aton($host); + my $sock_addr = sockaddr_in($port, $ip_addr); + $mac_addr =~ s/://g; + my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16); + + setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1); + send($sock, $packet, 0, $sock_addr); + $sock->close; + + return 1; +} + +######################################################## +# DNS hostname resolution +# return: +# $h->{name} = host - as passed in +# $h->{host} = host - as passed in without :port +# $h->{port} = OPTIONAL - if :port, then value of port +# $h->{addr} = resolved numeric address +# $h->{addr_in} = aton/pton result +# $h->{family} = AF_INET/6 +############################ +sub _resolv { + my ($self, + $name, + ) = @_; + + my %h; + $h{name} = $name; + my $family = $self->{family}; + + if (defined($self->{family_local})) { + $family = $self->{family_local} + } + +# START - host:port + my $cnt = 0; + + # Count ":" + $cnt++ while ($name =~ m/:/g); + + # 0 = hostname or IPv4 address + if ($cnt == 0) { + $h{host} = $name + # 1 = IPv4 address with port + } elsif ($cnt == 1) { + ($h{host}, $h{port}) = split /:/, $name + # >=2 = IPv6 address + } elsif ($cnt >= 2) { + #IPv6 with port - [2001::1]:port + if ($name =~ /^\[.*\]:\d{1,5}$/) { + ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last : + # IPv6 without port + } else { + $h{host} = $name + } + } + + # Clean up host + $h{host} =~ s/\[//g; + $h{host} =~ s/\]//g; + # Clean up port + if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) { + croak("Invalid port `$h{port}' in `$name'"); + } +# END - host:port + + # address check + # new way + if ($Socket::VERSION >= 1.94) { + my %hints = ( + family => $AF_UNSPEC, + protocol => IPPROTO_TCP, + flags => $AI_NUMERICHOST + ); + + # numeric address, return + my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); + if (defined($getaddr[0])) { + $h{addr} = $h{host}; + $h{family} = $getaddr[0]->{family}; + if ($h{family} == AF_INET) { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; + } else { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; + } + return \%h + } + # old way + } else { + # numeric address, return + my $ret = gethostbyname($h{host}); + if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) { + $h{addr} = $h{host}; + $h{addr_in} = $ret; + $h{family} = AF_INET; + return \%h + } + } + + # resolve + # new way + if ($Socket::VERSION >= 1.94) { + my %hints = ( + family => $family, + protocol => IPPROTO_TCP + ); + + my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); + if (defined($getaddr[0])) { + my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST); + if (defined($address)) { + $h{addr} = $address; + $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6 + $h{family} = $getaddr[0]->{family}; + if ($h{family} == AF_INET) { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; + } else { + (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; + } + return \%h + } else { + croak("getnameinfo($getaddr[0]->{addr}) failed - $err"); + } + } else { + croak(sprintf("getaddrinfo($h{host},,%s) failed - $err", + $family == AF_INET ? "AF_INET" : "AF_INET6")); + } + # old way + } else { + if ($family == $AF_INET6) { + croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION"); + } + + my @gethost = gethostbyname($h{host}); + if (defined($gethost[4])) { + $h{addr} = inet_ntoa($gethost[4]); + $h{addr_in} = $gethost[4]; + $h{family} = AF_INET; + return \%h + } else { + croak("gethostbyname($h{host}) failed - $^E"); + } + } +} + +sub _pack_sockaddr_in($$) { + my ($port, + $ip, + ) = @_; + + my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; + if (length($addr) <= 4 ) { + return Socket::pack_sockaddr_in($port, $addr); + } else { + return Socket::pack_sockaddr_in6($port, $addr); + } +} + +sub _unpack_sockaddr_in($;$) { + my ($addr, + $family, + ) = @_; + + my ($port, $host); + if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) { + ($port, $host) = Socket::unpack_sockaddr_in($addr); + } else { + ($port, $host) = Socket::unpack_sockaddr_in6($addr); + } + return $port, $host +} + +sub _inet_ntoa { + my ($addr + ) = @_; + + my $ret; + if ($Socket::VERSION >= 1.94) { + my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST); + if (defined($address)) { + $ret = $address; + } else { + croak("getnameinfo($addr) failed - $err"); + } + } else { + $ret = inet_ntoa($addr) + } + + return $ret +} + +1; +__END__ + +# Net::NNTP.pm +# +# Copyright (C) 1995-1997 Graham Barr. All rights reserved. +# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::NNTP; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use IO::Socket; +use Net::Cmd; +use Net::Config; +use Time::Local; + +our $VERSION = "3.11"; + +# Code for detecting if we can use SSL +my $ssl_class = eval { + require IO::Socket::SSL; + # first version with default CA on most platforms + no warnings 'numeric'; + IO::Socket::SSL->VERSION(2.007); +} && 'IO::Socket::SSL'; + +my $nossl_warn = !$ssl_class && + 'To use SSL please install IO::Socket::SSL with version>=2.007'; + +# Code for detecting if we can use IPv6 +my $family_key = 'Domain'; +my $inet6_class = eval { + require IO::Socket::IP; + no warnings 'numeric'; + IO::Socket::IP->VERSION(0.25) || die; + $family_key = 'Family'; +} && 'IO::Socket::IP' || eval { + require IO::Socket::INET6; + no warnings 'numeric'; + IO::Socket::INET6->VERSION(2.62); +} && 'IO::Socket::INET6'; + + +sub can_ssl { $ssl_class }; +sub can_inet6 { $inet6_class }; + +our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); + + +sub new { + my $self = shift; + my $type = ref($self) || $self; + my ($host, %arg); + if (@_ % 2) { + $host = shift; + %arg = @_; + } + else { + %arg = @_; + $host = delete $arg{Host}; + } + my $obj; + + $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST}; + + my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts}; + + @{$hosts} = qw(news) + unless @{$hosts}; + + my %connect = ( Proto => 'tcp'); + + if ($arg{SSL}) { + # SSL from start + die $nossl_warn if ! $ssl_class; + $arg{Port} ||= 563; + $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); + } + + foreach my $o (qw(LocalAddr LocalPort Timeout)) { + $connect{$o} = $arg{$o} if exists $arg{$o}; + } + $connect{$family_key} = $arg{Domain} || $arg{Family}; + $connect{Timeout} = 120 unless defined $connect{Timeout}; + $connect{PeerPort} = $arg{Port} || 'nntp(119)'; + foreach my $h (@{$hosts}) { + $connect{PeerAddr} = $h; + $obj = $type->SUPER::new(%connect) or next; + ${*$obj}{'net_nntp_host'} = $h; + ${*$obj}{'net_nntp_arg'} = \%arg; + if ($arg{SSL}) { + Net::NNTP::_SSL->start_SSL($obj,%arg) or next; + } + last: + } + + return + unless defined $obj; + + $obj->autoflush(1); + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($obj->response() == CMD_OK) { + $obj->close; + return; + } + + my $c = $obj->code; + my @m = $obj->message; + + unless (exists $arg{Reader} && $arg{Reader} == 0) { + + # if server is INN and we have transfer rights the we are currently + # talking to innd not nnrpd + if ($obj->reader) { + + # If reader succeeds the we need to consider this code to determine postok + $c = $obj->code; + } + else { + + # I want to ignore this failure, so restore the previous status. + $obj->set_status($c, \@m); + } + } + + ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0; + + $obj; +} + + +sub host { + my $me = shift; + ${*$me}{'net_nntp_host'}; +} + + +sub debug_text { + my $nntp = shift; + my $inout = shift; + my $text = shift; + + if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/) + || ($text =~ /^(authinfo\s+pass)/io)) + { + $text = "$1 ....\n"; + } + + $text; +} + + +sub postok { + @_ == 1 or croak 'usage: $nntp->postok()'; + my $nntp = shift; + ${*$nntp}{'net_nntp_post'} || 0; +} + + +sub starttls { + my $self = shift; + $ssl_class or die $nossl_warn; + $self->_STARTTLS or return; + Net::NNTP::_SSL->start_SSL($self, + %{ ${*$self}{'net_nntp_arg'} }, # (ssl) args given in new + @_ # more (ssl) args + ) or return; + return 1; +} + + +sub article { + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB')); + + $nntp->_ARTICLE(@_) + ? $nntp->read_until_dot(@fh) + : undef; +} + + +sub articlefh { + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )'; + my $nntp = shift; + + return unless $nntp->_ARTICLE(@_); + return $nntp->tied_fh; +} + + +sub authinfo { + @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; + my ($nntp, $user, $pass) = @_; + + $nntp->_AUTHINFO("USER", $user) == CMD_MORE + && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK; +} + + +sub authinfo_simple { + @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; + my ($nntp, $user, $pass) = @_; + + $nntp->_AUTHINFO('SIMPLE') == CMD_MORE + && $nntp->command($user, $pass)->response == CMD_OK; +} + + +sub body { + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); + + $nntp->_BODY(@_) + ? $nntp->read_until_dot(@fh) + : undef; +} + + +sub bodyfh { + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )'; + my $nntp = shift; + return unless $nntp->_BODY(@_); + return $nntp->tied_fh; +} + + +sub head { + @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )'; + my $nntp = shift; + my @fh; + + @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); + + $nntp->_HEAD(@_) + ? $nntp->read_until_dot(@fh) + : undef; +} + + +sub headfh { + @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )'; + my $nntp = shift; + return unless $nntp->_HEAD(@_); + return $nntp->tied_fh; +} + + +sub nntpstat { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )'; + my $nntp = shift; + + $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o + ? $1 + : undef; +} + + +sub group { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )'; + my $nntp = shift; + my $grp = ${*$nntp}{'net_nntp_group'}; + + return $grp + unless (@_ || wantarray); + + my $newgrp = shift; + + $newgrp = (defined($grp) and length($grp)) ? $grp : "" + unless defined($newgrp) and length($newgrp); + + return + unless $nntp->_GROUP($newgrp) and $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/; + + my ($count, $first, $last, $group) = ($1, $2, $3, $4); + + # group may be replied as '(current group)' + $group = ${*$nntp}{'net_nntp_group'} + if $group =~ /\(/; + + ${*$nntp}{'net_nntp_group'} = $group; + + wantarray + ? ($count, $first, $last, $group) + : $group; +} + + +sub help { + @_ == 1 or croak 'usage: $nntp->help()'; + my $nntp = shift; + + $nntp->_HELP + ? $nntp->read_until_dot + : undef; +} + + +sub ihave { + @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])'; + my $nntp = shift; + my $mid = shift; + + $nntp->_IHAVE($mid) && $nntp->datasend(@_) + ? @_ == 0 || $nntp->dataend + : undef; +} + + +sub last { + @_ == 1 or croak 'usage: $nntp->last()'; + my $nntp = shift; + + $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o + ? $1 + : undef; +} + + +sub list { + @_ == 1 or croak 'usage: $nntp->list()'; + my $nntp = shift; + + $nntp->_LIST + ? $nntp->_grouplist + : undef; +} + + +sub newgroups { + @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])'; + my $nntp = shift; + my $time = _timestr(shift); + my $dist = shift || ""; + + $dist = join(",", @{$dist}) + if ref($dist); + + $nntp->_NEWGROUPS($time, $dist) + ? $nntp->_grouplist + : undef; +} + + +sub newnews { + @_ >= 2 && @_ <= 4 + or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])'; + my $nntp = shift; + my $time = _timestr(shift); + my $grp = @_ ? shift: $nntp->group; + my $dist = shift || ""; + + $grp ||= "*"; + $grp = join(",", @{$grp}) + if ref($grp); + + $dist = join(",", @{$dist}) + if ref($dist); + + $nntp->_NEWNEWS($grp, $time, $dist) + ? $nntp->_articlelist + : undef; +} + + +sub next { + @_ == 1 or croak 'usage: $nntp->next()'; + my $nntp = shift; + + $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o + ? $1 + : undef; +} + + +sub post { + @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )'; + my $nntp = shift; + + $nntp->_POST() && $nntp->datasend(@_) + ? @_ == 0 || $nntp->dataend + : undef; +} + + +sub postfh { + my $nntp = shift; + return unless $nntp->_POST(); + return $nntp->tied_fh; +} + + +sub quit { + @_ == 1 or croak 'usage: $nntp->quit()'; + my $nntp = shift; + + $nntp->_QUIT; + $nntp->close; +} + + +sub slave { + @_ == 1 or croak 'usage: $nntp->slave()'; + my $nntp = shift; + + $nntp->_SLAVE; +} + +## +## The following methods are not implemented by all servers +## + + +sub active { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )'; + my $nntp = shift; + + $nntp->_LIST('ACTIVE', @_) + ? $nntp->_grouplist + : undef; +} + + +sub active_times { + @_ == 1 or croak 'usage: $nntp->active_times()'; + my $nntp = shift; + + $nntp->_LIST('ACTIVE.TIMES') + ? $nntp->_grouplist + : undef; +} + + +sub distributions { + @_ == 1 or croak 'usage: $nntp->distributions()'; + my $nntp = shift; + + $nntp->_LIST('DISTRIBUTIONS') + ? $nntp->_description + : undef; +} + + +sub distribution_patterns { + @_ == 1 or croak 'usage: $nntp->distributions()'; + my $nntp = shift; + + my $arr; + local $_; + + ## no critic (ControlStructures::ProhibitMutatingListFunctions) + $nntp->_LIST('DISTRIB.PATS') + && ($arr = $nntp->read_until_dot) + ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr] + : undef; +} + + +sub newsgroups { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )'; + my $nntp = shift; + + $nntp->_LIST('NEWSGROUPS', @_) + ? $nntp->_description + : undef; +} + + +sub overview_fmt { + @_ == 1 or croak 'usage: $nntp->overview_fmt()'; + my $nntp = shift; + + $nntp->_LIST('OVERVIEW.FMT') + ? $nntp->_articlelist + : undef; +} + + +sub subscriptions { + @_ == 1 or croak 'usage: $nntp->subscriptions()'; + my $nntp = shift; + + $nntp->_LIST('SUBSCRIPTIONS') + ? $nntp->_articlelist + : undef; +} + + +sub listgroup { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )'; + my $nntp = shift; + + $nntp->_LISTGROUP(@_) + ? $nntp->_articlelist + : undef; +} + + +sub reader { + @_ == 1 or croak 'usage: $nntp->reader()'; + my $nntp = shift; + + $nntp->_MODE('READER'); +} + + +sub xgtitle { + @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )'; + my $nntp = shift; + + $nntp->_XGTITLE(@_) + ? $nntp->_description + : undef; +} + + +sub xhdr { + @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )'; + my $nntp = shift; + my $hdr = shift; + my $arg = _msg_arg(@_); + + $nntp->_XHDR($hdr, $arg) + ? $nntp->_description + : undef; +} + + +sub xover { + @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )'; + my $nntp = shift; + my $arg = _msg_arg(@_); + + $nntp->_XOVER($arg) + ? $nntp->_fieldlist + : undef; +} + + +sub xpat { + @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )'; + my $nntp = shift; + my $hdr = shift; + my $pat = shift; + my $arg = _msg_arg(@_); + + $pat = join(" ", @$pat) + if ref($pat); + + $nntp->_XPAT($hdr, $arg, $pat) + ? $nntp->_description + : undef; +} + + +sub xpath { + @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )'; + my ($nntp, $mid) = @_; + + return + unless $nntp->_XPATH($mid); + + my $m; + ($m = $nntp->message) =~ s/^\d+\s+//o; + my @p = split /\s+/, $m; + + wantarray ? @p : $p[0]; +} + + +sub xrover { + @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )'; + my $nntp = shift; + my $arg = _msg_arg(@_); + + $nntp->_XROVER($arg) + ? $nntp->_description + : undef; +} + + +sub date { + @_ == 1 or croak 'usage: $nntp->date()'; + my $nntp = shift; + + $nntp->_DATE + && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ + ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900) + : undef; +} + + +## +## Private subroutines +## + + +sub _msg_arg { + my $spec = shift; + my $arg = ""; + + if (@_) { + carp "Depriciated passing of two message numbers, " . "pass a reference" + if $^W; + $spec = [$spec, $_[0]]; + } + + if (defined $spec) { + if (ref($spec)) { + $arg = $spec->[0]; + if (defined $spec->[1]) { + $arg .= "-" + if $spec->[1] != $spec->[0]; + $arg .= $spec->[1] + if $spec->[1] > $spec->[0]; + } + } + else { + $arg = $spec; + } + } + + $arg; +} + + +sub _timestr { + my $time = shift; + my @g = reverse((gmtime($time))[0 .. 5]); + $g[1] += 1; + $g[0] %= 100; + sprintf "%02d%02d%02d %02d%02d%02d GMT", @g; +} + + +sub _grouplist { + my $nntp = shift; + my $arr = $nntp->read_until_dot + or return; + + my $hash = {}; + + foreach my $ln (@$arr) { + my @a = split(/[\s\n]+/, $ln); + $hash->{$a[0]} = [@a[1, 2, 3]]; + } + + $hash; +} + + +sub _fieldlist { + my $nntp = shift; + my $arr = $nntp->read_until_dot + or return; + + my $hash = {}; + + foreach my $ln (@$arr) { + my @a = split(/[\t\n]/, $ln); + my $m = shift @a; + $hash->{$m} = [@a]; + } + + $hash; +} + + +sub _articlelist { + my $nntp = shift; + my $arr = $nntp->read_until_dot; + + chomp(@$arr) + if $arr; + + $arr; +} + + +sub _description { + my $nntp = shift; + my $arr = $nntp->read_until_dot + or return; + + my $hash = {}; + + foreach my $ln (@$arr) { + chomp($ln); + + $hash->{$1} = $ln + if $ln =~ s/^\s*(\S+)\s*//o; + } + + $hash; + +} + +## +## The commands +## + + +sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK } +sub _AUTHINFO { shift->command('AUTHINFO', @_)->response } +sub _BODY { shift->command('BODY', @_)->response == CMD_OK } +sub _DATE { shift->command('DATE')->response == CMD_INFO } +sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK } +sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK } +sub _HELP { shift->command('HELP', @_)->response == CMD_INFO } +sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE } +sub _LAST { shift->command('LAST')->response == CMD_OK } +sub _LIST { shift->command('LIST', @_)->response == CMD_OK } +sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK } +sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK } +sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK } +sub _NEXT { shift->command('NEXT')->response == CMD_OK } +sub _POST { shift->command('POST', @_)->response == CMD_MORE } +sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK } +sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK } +sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_MORE } +sub _STAT { shift->command('STAT', @_)->response == CMD_OK } +sub _MODE { shift->command('MODE', @_)->response == CMD_OK } +sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK } +sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK } +sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK } +sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK } +sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK } +sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK } +sub _XTHREAD { shift->unsupported } +sub _XSEARCH { shift->unsupported } +sub _XINDEX { shift->unsupported } + +## +## IO/perl methods +## + + +sub DESTROY { + my $nntp = shift; + defined(fileno($nntp)) && $nntp->quit; +} + +{ + package Net::NNTP::_SSL; + our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::NNTP' ); + sub starttls { die "NNTP connection is already in SSL mode" } + sub start_SSL { + my ($class,$nntp,%arg) = @_; + delete @arg{ grep { !m{^SSL_} } keys %arg }; + ( $arg{SSL_verifycn_name} ||= $nntp->host ) + =~s{(?can_client_sni; + my $ok = $class->SUPER::start_SSL($nntp, + SSL_verifycn_scheme => 'nntp', + %arg + ); + $@ = $ssl_class->errstr if !$ok; + return $ok; + } +} + + + + +1; + +__END__ + +# Net::FTP.pm +# +# Copyright (C) 1995-2004 Graham Barr. All rights reserved. +# Copyright (C) 2013-2017 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. +# +# Documentation (at end) improved 1996 by Nathan Torkington . + +package Net::FTP; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC); +use IO::Socket; +use Net::Cmd; +use Net::Config; +use Socket; +use Time::Local; + +our $VERSION = '3.11'; + +our $IOCLASS; +my $family_key; +BEGIN { + # Code for detecting if we can use SSL + my $ssl_class = eval { + require IO::Socket::SSL; + # first version with default CA on most platforms + no warnings 'numeric'; + IO::Socket::SSL->VERSION(2.007); + } && 'IO::Socket::SSL'; + + my $nossl_warn = !$ssl_class && + 'To use SSL please install IO::Socket::SSL with version>=2.007'; + + # Code for detecting if we can use IPv6 + my $inet6_class = eval { + require IO::Socket::IP; + no warnings 'numeric'; + IO::Socket::IP->VERSION(0.25); + } && 'IO::Socket::IP' || eval { + require IO::Socket::INET6; + no warnings 'numeric'; + IO::Socket::INET6->VERSION(2.62); + } && 'IO::Socket::INET6'; + + sub can_ssl { $ssl_class }; + sub can_inet6 { $inet6_class }; + + $IOCLASS = $ssl_class || $inet6_class || 'IO::Socket::INET'; + $family_key = + ( $ssl_class ? $ssl_class->can_ipv6 : $inet6_class || '' ) + eq 'IO::Socket::IP' + ? 'Family' : 'Domain'; +} + +our @ISA = ('Exporter','Net::Cmd',$IOCLASS); + +use constant TELNET_IAC => 255; +use constant TELNET_IP => 244; +use constant TELNET_DM => 242; + +use constant EBCDIC => $^O eq 'os390'; + +sub new { + my $pkg = shift; + my ($peer, %arg); + if (@_ % 2) { + $peer = shift; + %arg = @_; + } + else { + %arg = @_; + $peer = delete $arg{Host}; + } + + my $host = $peer; + my $fire = undef; + my $fire_type = undef; + + if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) { + $fire = $arg{Firewall} + || $ENV{FTP_FIREWALL} + || $NetConfig{ftp_firewall} + || undef; + + if (defined $fire) { + $peer = $fire; + delete $arg{Port}; + $fire_type = $arg{FirewallType} + || $ENV{FTP_FIREWALL_TYPE} + || $NetConfig{firewall_type} + || undef; + } + } + + my %tlsargs; + if (can_ssl()) { + # for name verification strip port from domain:port, ipv4:port, [ipv6]:port + (my $hostname = $host) =~s{(? 'ftp', + SSL_verifycn_name => $hostname, + # use SNI if supported by IO::Socket::SSL + $pkg->can_client_sni ? (SSL_hostname => $hostname):(), + # reuse SSL session of control connection in data connections + SSL_session_cache => Net::FTP::_SSL_SingleSessionCache->new, + ); + # user defined SSL arg + $tlsargs{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); + + } elsif ($arg{SSL}) { + croak("IO::Socket::SSL >= 2.007 needed for SSL support"); + } + + my $ftp = $pkg->SUPER::new( + PeerAddr => $peer, + PeerPort => $arg{Port} || ($arg{SSL} ? 'ftps(990)' : 'ftp(21)'), + LocalAddr => $arg{'LocalAddr'}, + $family_key => $arg{Domain} || $arg{Family}, + Proto => 'tcp', + Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120, + %tlsargs, + $arg{SSL} ? ():( SSL_startHandshake => 0 ), + ) or return; + + ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname + ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode + ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240); + + ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'}; + ${*$ftp}{'net_ftp_domain'} = $arg{Domain} || $arg{Family}; + + ${*$ftp}{'net_ftp_firewall'} = $fire + if (defined $fire); + ${*$ftp}{'net_ftp_firewall_type'} = $fire_type + if (defined $fire_type); + + ${*$ftp}{'net_ftp_passive'} = + int exists $arg{Passive} ? $arg{Passive} + : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE} + : defined $fire ? $NetConfig{ftp_ext_passive} + : $NetConfig{ftp_int_passive}; # Whew! :-) + + ${*$ftp}{net_ftp_tlsargs} = \%tlsargs if %tlsargs; + if ($arg{SSL}) { + ${*$ftp}{net_ftp_tlsprot} = 'P'; + ${*$ftp}{net_ftp_tlsdirect} = 1; + } + + $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024); + + $ftp->autoflush(1); + + $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($ftp->response() == CMD_OK) { + $ftp->close(); + # keep @$ if no message. Happens, when response did not start with a code. + $@ = $ftp->message || $@; + undef $ftp; + } + + $ftp; +} + +## +## User interface methods +## + + +sub host { + my $me = shift; + ${*$me}{'net_ftp_host'}; +} + +sub passive { + my $ftp = shift; + return ${*$ftp}{'net_ftp_passive'} unless @_; + ${*$ftp}{'net_ftp_passive'} = shift; +} + + +sub hash { + my $ftp = shift; # self + + my ($h, $b) = @_; + unless ($h) { + delete ${*$ftp}{'net_ftp_hash'}; + return [\*STDERR, 0]; + } + ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024); + select((select($h), $| = 1)[0]); + $b = 512 if $b < 512; + ${*$ftp}{'net_ftp_hash'} = [$h, $b]; +} + + +sub quit { + my $ftp = shift; + + $ftp->_QUIT; + $ftp->close; +} + + +sub DESTROY { } + + +sub ascii { shift->type('A', @_); } +sub binary { shift->type('I', @_); } + + +sub ebcdic { + carp "TYPE E is unsupported, shall default to I"; + shift->type('E', @_); +} + + +sub byte { + carp "TYPE L is unsupported, shall default to I"; + shift->type('L', @_); +} + +# Allow the user to send a command directly, BE CAREFUL !! + + +sub quot { + my $ftp = shift; + my $cmd = shift; + + $ftp->command(uc $cmd, @_); + $ftp->response(); +} + + +sub site { + my $ftp = shift; + + $ftp->command("SITE", @_); + $ftp->response(); +} + + +sub mdtm { + my $ftp = shift; + my $file = shift; + + # Server Y2K bug workaround + # + # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of + # ("%d",tm.tm_year+1900). This results in an extra digit in the + # string returned. To account for this we allow an optional extra + # digit in the year. Then if the first two digits are 19 we use the + # remainder, otherwise we subtract 1900 from the whole year. + + $ftp->_MDTM($file) + && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ + ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900)) + : undef; +} + + +sub size { + my $ftp = shift; + my $file = shift; + my $io; + if ($ftp->supported("SIZE")) { + return $ftp->_SIZE($file) + ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0] + : undef; + } + elsif ($ftp->supported("STAT")) { + my @msg; + return + unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3; + foreach my $line (@msg) { + return (split(/\s+/, $line))[4] + if $line =~ /^[-rwxSsTt]{10}/; + } + } + else { + my @files = $ftp->dir($file); + if (@files) { + return (split(/\s+/, $1))[4] + if $files[0] =~ /^([-rwxSsTt]{10}.*)$/; + } + } + undef; +} + + +sub starttls { + my $ftp = shift; + can_ssl() or croak("IO::Socket::SSL >= 2.007 needed for SSL support"); + $ftp->is_SSL and croak("called starttls within SSL session"); + $ftp->_AUTH('TLS') == CMD_OK or return; + + $ftp->connect_SSL or return; + $ftp->prot('P'); + return 1; +} + +sub prot { + my ($ftp,$prot) = @_; + $prot eq 'C' or $prot eq 'P' or croak("prot must by C or P"); + $ftp->_PBSZ(0) or return; + $ftp->_PROT($prot) or return; + ${*$ftp}{net_ftp_tlsprot} = $prot; + return 1; +} + +sub stoptls { + my $ftp = shift; + $ftp->is_SSL or croak("called stoptls outside SSL session"); + ${*$ftp}{net_ftp_tlsdirect} and croak("cannot stoptls direct SSL session"); + $ftp->_CCC() or return; + $ftp->stop_SSL(); + return 1; +} + +sub login { + my ($ftp, $user, $pass, $acct) = @_; + my ($ok, $ruser, $fwtype); + + unless (defined $user) { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}); + + ($user, $pass, $acct) = $rc->lpa() + if ($rc); + } + + $user ||= "anonymous"; + $ruser = $user; + + $fwtype = ${*$ftp}{'net_ftp_firewall_type'} + || $NetConfig{'ftp_firewall_type'} + || 0; + + if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) { + if ($fwtype == 1 || $fwtype == 7) { + $user .= '@' . ${*$ftp}{'net_ftp_host'}; + } + else { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); + + my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : (); + + if ($fwtype == 5) { + $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'}); + $pass = $pass . '@' . $fwpass; + } + else { + if ($fwtype == 2) { + $user .= '@' . ${*$ftp}{'net_ftp_host'}; + } + elsif ($fwtype == 6) { + $fwuser .= '@' . ${*$ftp}{'net_ftp_host'}; + } + + $ok = $ftp->_USER($fwuser); + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + + $ok = $ftp->_PASS($fwpass || ""); + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + + $ok = $ftp->_ACCT($fwacct) + if defined($fwacct); + + if ($fwtype == 3) { + $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response; + } + elsif ($fwtype == 4) { + $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response; + } + + return 0 unless $ok == CMD_OK || $ok == CMD_MORE; + } + } + } + + $ok = $ftp->_USER($user); + + # Some dumb firewalls don't prefix the connection messages + $ok = $ftp->response() + if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/); + + if ($ok == CMD_MORE) { + unless (defined $pass) { + require Net::Netrc; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser); + + ($ruser, $pass, $acct) = $rc->lpa() + if ($rc); + + $pass = '-anonymous@' + if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o)); + } + + $ok = $ftp->_PASS($pass || ""); + } + + $ok = $ftp->_ACCT($acct) + if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK)); + + if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) { + my ($f, $auth, $resp) = _auth_id($ftp); + $ftp->authorize($auth, $resp) if defined($resp); + } + + $ok == CMD_OK; +} + + +sub account { + @_ == 2 or croak 'usage: $ftp->account( ACCT )'; + my $ftp = shift; + my $acct = shift; + $ftp->_ACCT($acct) == CMD_OK; +} + + +sub _auth_id { + my ($ftp, $auth, $resp) = @_; + + unless (defined $resp) { + require Net::Netrc; + + $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; + + my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth) + || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); + + ($auth, $resp) = $rc->lpa() + if ($rc); + } + ($ftp, $auth, $resp); +} + + +sub authorize { + @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; + + my ($ftp, $auth, $resp) = &_auth_id; + + my $ok = $ftp->_AUTH($auth || ""); + + return $ftp->_RESP($resp || "") + if ($ok == CMD_MORE); + + $ok == CMD_OK; +} + + +sub rename { + @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)'; + + my ($ftp, $from, $to) = @_; + + $ftp->_RNFR($from) + && $ftp->_RNTO($to); +} + + +sub type { + my $ftp = shift; + my $type = shift; + my $oldval = ${*$ftp}{'net_ftp_type'}; + + return $oldval + unless (defined $type); + + return + unless ($ftp->_TYPE($type, @_)); + + ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_); + + $oldval; +} + + +sub alloc { + my $ftp = shift; + my $size = shift; + my $oldval = ${*$ftp}{'net_ftp_allo'}; + + return $oldval + unless (defined $size); + + return + unless ($ftp->supported("ALLO") and $ftp->_ALLO($size, @_)); + + ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_); + + $oldval; +} + + +sub abort { + my $ftp = shift; + + send($ftp, pack("CCC", TELNET_IAC, TELNET_IP, TELNET_IAC), MSG_OOB); + + $ftp->command(pack("C", TELNET_DM) . "ABOR"); + + ${*$ftp}{'net_ftp_dataconn'}->close() + if defined ${*$ftp}{'net_ftp_dataconn'}; + + $ftp->response(); + + $ftp->status == CMD_OK; +} + + +sub get { + my ($ftp, $remote, $local, $where) = @_; + + my ($loc, $len, $buf, $resp, $data); + local *FD; + + my $localfd = ref($local) || ref(\$local) eq "GLOB"; + + ($local = $remote) =~ s#^.*/## + unless (defined $local); + + croak("Bad remote filename '$remote'\n") + if $remote =~ /[\r\n]/s; + + ${*$ftp}{'net_ftp_rest'} = $where if defined $where; + my $rest = ${*$ftp}{'net_ftp_rest'}; + + delete ${*$ftp}{'net_ftp_port'}; + delete ${*$ftp}{'net_ftp_pasv'}; + + $data = $ftp->retr($remote) + or return; + + if ($localfd) { + $loc = $local; + } + else { + $loc = \*FD; + + unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) { + carp "Cannot open Local file $local: $!\n"; + $data->abort; + return; + } + } + + if ($ftp->type eq 'I' && !binmode($loc)) { + carp "Cannot binmode Local file $local: $!\n"; + $data->abort; + close($loc) unless $localfd; + return; + } + + $buf = ''; + my ($count, $hashh, $hashb, $ref) = (0); + + ($hashh, $hashb) = @$ref + if ($ref = ${*$ftp}{'net_ftp_hash'}); + + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + local $\; # Just in case + + while (1) { + last unless $len = $data->read($buf, $blksize); + + if (EBCDIC && $ftp->type ne 'I') { + $buf = $ftp->toebcdic($buf); + $len = length($buf); + } + + if ($hashh) { + $count += $len; + print $hashh "#" x (int($count / $hashb)); + $count %= $hashb; + } + unless (print $loc $buf) { + carp "Cannot write to Local file $local: $!\n"; + $data->abort; + close($loc) + unless $localfd; + return; + } + } + + print $hashh "\n" if $hashh; + + unless ($localfd) { + unless (close($loc)) { + carp "Cannot close file $local (perhaps disk space) $!\n"; + return; + } + } + + unless ($data->close()) # implied $ftp->response + { + carp "Unable to close datastream"; + return; + } + + return $local; +} + + +sub cwd { + @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )'; + + my ($ftp, $dir) = @_; + + $dir = "/" unless defined($dir) && $dir =~ /\S/; + + $dir eq ".." + ? $ftp->_CDUP() + : $ftp->_CWD($dir); +} + + +sub cdup { + @_ == 1 or croak 'usage: $ftp->cdup()'; + $_[0]->_CDUP; +} + + +sub pwd { + @_ == 1 || croak 'usage: $ftp->pwd()'; + my $ftp = shift; + + $ftp->_PWD(); + $ftp->_extract_path; +} + +# rmdir( $ftp, $dir, [ $recurse ] ) +# +# Removes $dir on remote host via FTP. +# $ftp is handle for remote host +# +# If $recurse is TRUE, the directory and deleted recursively. +# This means all of its contents and subdirectories. +# +# Initial version contributed by Dinkum Software +# +sub rmdir { + @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )'); + + # Pick off the args + my ($ftp, $dir, $recurse) = @_; + my $ok; + + return $ok + if $ok = $ftp->_RMD($dir) + or !$recurse; + + # Try to delete the contents + # Get a list of all the files in the directory, excluding the current and parent directories + my @filelist = map { /^(?:\S+;)+ (.+)$/ ? ($1) : () } grep { !/^(?:\S+;)*type=[cp]dir;/i } $ftp->_list_cmd("MLSD", $dir); + + # Fallback to using the less well-defined NLST command if MLSD fails + @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir) + unless @filelist; + + return + unless @filelist; # failed, it is probably not a directory + + return $ftp->delete($dir) + if @filelist == 1 and $dir eq $filelist[0]; + + # Go thru and delete each file or the directory + foreach my $file (map { m,/, ? $_ : "$dir/$_" } @filelist) { + next # successfully deleted the file + if $ftp->delete($file); + + # Failed to delete it, assume its a directory + # Recurse and ignore errors, the final rmdir() will + # fail on any errors here + return $ok + unless $ok = $ftp->rmdir($file, 1); + } + + # Directory should be empty + # Try to remove the directory again + # Pass results directly to caller + # If any of the prior deletes failed, this + # rmdir() will fail because directory is not empty + return $ftp->_RMD($dir); +} + + +sub restart { + @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )'; + + my ($ftp, $where) = @_; + + ${*$ftp}{'net_ftp_rest'} = $where; + + return; +} + + +sub mkdir { + @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; + + my ($ftp, $dir, $recurse) = @_; + + $ftp->_MKD($dir) || $recurse + or return; + + my $path = $dir; + + unless ($ftp->ok) { + my @path = split(m#(?=/+)#, $dir); + + $path = ""; + + while (@path) { + $path .= shift @path; + + $ftp->_MKD($path); + + $path = $ftp->_extract_path($path); + } + + # If the creation of the last element was not successful, see if we + # can cd to it, if so then return path + + unless ($ftp->ok) { + my ($status, $message) = ($ftp->status, $ftp->message); + my $pwd = $ftp->pwd; + + if ($pwd && $ftp->cwd($dir)) { + $path = $dir; + $ftp->cwd($pwd); + } + else { + undef $path; + } + $ftp->set_status($status, $message); + } + } + + $path; +} + + +sub delete { + @_ == 2 || croak 'usage: $ftp->delete( FILENAME )'; + + $_[0]->_DELE($_[1]); +} + + +sub put { shift->_store_cmd("stor", @_) } +sub put_unique { shift->_store_cmd("stou", @_) } +sub append { shift->_store_cmd("appe", @_) } + + +sub nlst { shift->_data_cmd("NLST", @_) } +sub list { shift->_data_cmd("LIST", @_) } +sub retr { shift->_data_cmd("RETR", @_) } +sub stor { shift->_data_cmd("STOR", @_) } +sub stou { shift->_data_cmd("STOU", @_) } +sub appe { shift->_data_cmd("APPE", @_) } + + +sub _store_cmd { + my ($ftp, $cmd, $local, $remote) = @_; + my ($loc, $sock, $len, $buf); + local *FD; + + my $localfd = ref($local) || ref(\$local) eq "GLOB"; + + if (!defined($remote) and 'STOU' ne uc($cmd)) { + croak 'Must specify remote filename with stream input' + if $localfd; + + require File::Basename; + $remote = File::Basename::basename($local); + } + if (defined ${*$ftp}{'net_ftp_allo'}) { + delete ${*$ftp}{'net_ftp_allo'}; + } + else { + + # if the user hasn't already invoked the alloc method since the last + # _store_cmd call, figure out if the local file is a regular file(not + # a pipe, or device) and if so get the file size from stat, and send + # an ALLO command before sending the STOR, STOU, or APPE command. + my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe + ${*$ftp}{'net_ftp_allo'} = $size if $size; + } + croak("Bad remote filename '$remote'\n") + if defined($remote) and $remote =~ /[\r\n]/s; + + if ($localfd) { + $loc = $local; + } + else { + $loc = \*FD; + + unless (sysopen($loc, $local, O_RDONLY)) { + carp "Cannot open Local file $local: $!\n"; + return; + } + } + + if ($ftp->type eq 'I' && !binmode($loc)) { + carp "Cannot binmode Local file $local: $!\n"; + return; + } + + delete ${*$ftp}{'net_ftp_port'}; + delete ${*$ftp}{'net_ftp_pasv'}; + + $sock = $ftp->_data_cmd($cmd, grep { defined } $remote) + or return; + + $remote = ($ftp->message =~ /\w+\s*:\s*(.*)/)[0] + if 'STOU' eq uc $cmd; + + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + + my ($count, $hashh, $hashb, $ref) = (0); + + ($hashh, $hashb) = @$ref + if ($ref = ${*$ftp}{'net_ftp_hash'}); + + while (1) { + last unless $len = read($loc, $buf = "", $blksize); + + if (EBCDIC && $ftp->type ne 'I') { + $buf = $ftp->toascii($buf); + $len = length($buf); + } + + if ($hashh) { + $count += $len; + print $hashh "#" x (int($count / $hashb)); + $count %= $hashb; + } + + my $wlen; + unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) { + $sock->abort; + close($loc) + unless $localfd; + print $hashh "\n" if $hashh; + return; + } + } + + print $hashh "\n" if $hashh; + + close($loc) + unless $localfd; + + $sock->close() + or return; + + if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) { + require File::Basename; + $remote = File::Basename::basename($+); + } + + return $remote; +} + + +sub port { + @_ == 1 || @_ == 2 or croak 'usage: $self->port([PORT])'; + return _eprt('PORT',@_); +} + +sub eprt { + @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([PORT])'; + return _eprt('EPRT',@_); +} + +sub _eprt { + my ($cmd,$ftp,$port) = @_; + delete ${*$ftp}{net_ftp_intern_port}; + unless ($port) { + my $listen = ${*$ftp}{net_ftp_listen} ||= $IOCLASS->new( + Listen => 1, + Timeout => $ftp->timeout, + LocalAddr => $ftp->sockhost, + $family_key => $ftp->sockdomain, + can_ssl() ? ( + %{ ${*$ftp}{net_ftp_tlsargs} }, + SSL_startHandshake => 0, + ):(), + ); + ${*$ftp}{net_ftp_intern_port} = 1; + my $fam = ($listen->sockdomain == AF_INET) ? 1:2; + if ( $cmd eq 'EPRT' || $fam == 2 ) { + $port = "|$fam|".$listen->sockhost."|".$listen->sockport."|"; + $cmd = 'EPRT'; + } else { + my $p = $listen->sockport; + $port = join(',',split(m{\.},$listen->sockhost),$p >> 8,$p & 0xff); + } + } elsif (ref($port) eq 'ARRAY') { + $port = join(',',split(m{\.},@$port[0]),@$port[1] >> 8,@$port[1] & 0xff); + } + my $ok = $cmd eq 'EPRT' ? $ftp->_EPRT($port) : $ftp->_PORT($port); + ${*$ftp}{net_ftp_port} = $port if $ok; + return $ok; +} + + +sub ls { shift->_list_cmd("NLST", @_); } +sub dir { shift->_list_cmd("LIST", @_); } + + +sub pasv { + my $ftp = shift; + @_ and croak 'usage: $ftp->port()'; + return $ftp->epsv if $ftp->sockdomain != AF_INET; + delete ${*$ftp}{net_ftp_intern_port}; + + if ( $ftp->_PASV && + $ftp->message =~ m{(\d+,\d+,\d+,\d+),(\d+),(\d+)} ) { + my $port = 256 * $2 + $3; + ( my $ip = $1 ) =~s{,}{.}g; + return ${*$ftp}{net_ftp_pasv} = [ $ip,$port ]; + } + return; +} + +sub epsv { + my $ftp = shift; + @_ and croak 'usage: $ftp->epsv()'; + delete ${*$ftp}{net_ftp_intern_port}; + + $ftp->_EPSV && $ftp->message =~ m{\(([\x33-\x7e])\1\1(\d+)\1\)} + ? ${*$ftp}{net_ftp_pasv} = [ $ftp->peerhost, $2 ] + : undef; +} + + +sub unique_name { + my $ftp = shift; + ${*$ftp}{'net_ftp_unique'} || undef; +} + + +sub supported { + @_ == 2 or croak 'usage: $ftp->supported( CMD )'; + my $ftp = shift; + my $cmd = uc shift; + my $hash = ${*$ftp}{'net_ftp_supported'} ||= {}; + + return $hash->{$cmd} + if exists $hash->{$cmd}; + + return $hash->{$cmd} = 1 + if $ftp->feature($cmd); + + return $hash->{$cmd} = 0 + unless $ftp->_HELP($cmd); + + my $text = $ftp->message; + if ($text =~ /following.+commands/i) { + $text =~ s/^.*\n//; + while ($text =~ /(\*?)(\w+)(\*?)/sg) { + $hash->{"\U$2"} = !length("$1$3"); + } + } + else { + $hash->{$cmd} = $text !~ /unimplemented/i; + } + + $hash->{$cmd} ||= 0; +} + +## +## Deprecated methods +## + + +sub lsl { + carp "Use of Net::FTP::lsl deprecated, use 'dir'" + if $^W; + goto &dir; +} + + +sub authorise { + carp "Use of Net::FTP::authorise deprecated, use 'authorize'" + if $^W; + goto &authorize; +} + + +## +## Private methods +## + + +sub _extract_path { + my ($ftp, $path) = @_; + + # This tries to work both with and without the quote doubling + # convention (RFC 959 requires it, but the first 3 servers I checked + # didn't implement it). It will fail on a server which uses a quote in + # the message which isn't a part of or surrounding the path. + $ftp->ok + && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ + && ($path = $1) =~ s/\"\"/\"/g; + + $path; +} + +## +## Communication methods +## + + +sub _dataconn { + my $ftp = shift; + my $pkg = "Net::FTP::" . $ftp->type; + eval "require " . $pkg ## no critic (BuiltinFunctions::ProhibitStringyEval) + or croak("cannot load $pkg required for type ".$ftp->type); + $pkg =~ s/ /_/g; + delete ${*$ftp}{net_ftp_dataconn}; + + my $conn; + my $pasv = ${*$ftp}{net_ftp_pasv}; + if ($pasv) { + $conn = $pkg->new( + PeerAddr => $pasv->[0], + PeerPort => $pasv->[1], + LocalAddr => ${*$ftp}{net_ftp_localaddr}, + $family_key => ${*$ftp}{net_ftp_domain}, + Timeout => $ftp->timeout, + can_ssl() ? ( + SSL_startHandshake => 0, + $ftp->is_SSL ? ( + SSL_reuse_ctx => $ftp, + SSL_verifycn_name => ${*$ftp}{net_ftp_tlsargs}{SSL_verifycn_name}, + # This will cause the use of SNI if supported by IO::Socket::SSL. + $ftp->can_client_sni ? ( + SSL_hostname => ${*$ftp}{net_ftp_tlsargs}{SSL_hostname} + ):(), + ) :( %{${*$ftp}{net_ftp_tlsargs}} ), + ):(), + ) or return; + } elsif (my $listen = delete ${*$ftp}{net_ftp_listen}) { + $conn = $listen->accept($pkg) or return; + $conn->timeout($ftp->timeout); + close($listen); + } else { + croak("no listener in active mode"); + } + + if (( ${*$ftp}{net_ftp_tlsprot} || '') eq 'P') { + if ($conn->connect_SSL) { + # SSL handshake ok + } else { + carp("failed to ssl upgrade dataconn: $IO::Socket::SSL::SSL_ERROR"); + return; + } + } + + ${*$ftp}{net_ftp_dataconn} = $conn; + ${*$conn} = ""; + ${*$conn}{net_ftp_cmd} = $ftp; + ${*$conn}{net_ftp_blksize} = ${*$ftp}{net_ftp_blksize}; + return $conn; +} + + +sub _list_cmd { + my $ftp = shift; + my $cmd = uc shift; + + delete ${*$ftp}{'net_ftp_port'}; + delete ${*$ftp}{'net_ftp_pasv'}; + + my $data = $ftp->_data_cmd($cmd, @_); + + return + unless (defined $data); + + require Net::FTP::A; + bless $data, "Net::FTP::A"; # Force ASCII mode + + my $databuf = ''; + my $buf = ''; + my $blksize = ${*$ftp}{'net_ftp_blksize'}; + + while ($data->read($databuf, $blksize)) { + $buf .= $databuf; + } + + my $list = [split(/\n/, $buf)]; + + $data->close(); + + if (EBCDIC) { + for (@$list) { $_ = $ftp->toebcdic($_) } + } + + wantarray + ? @{$list} + : $list; +} + + +sub _data_cmd { + my $ftp = shift; + my $cmd = uc shift; + my $ok = 1; + my $where = delete ${*$ftp}{'net_ftp_rest'} || 0; + my $arg; + + for my $arg (@_) { + croak("Bad argument '$arg'\n") + if $arg =~ /[\r\n]/s; + } + + if ( ${*$ftp}{'net_ftp_passive'} + && !defined ${*$ftp}{'net_ftp_pasv'} + && !defined ${*$ftp}{'net_ftp_port'}) + { + return unless defined $ftp->pasv; + + if ($where and !$ftp->_REST($where)) { + my ($status, $message) = ($ftp->status, $ftp->message); + $ftp->abort; + $ftp->set_status($status, $message); + return; + } + + # first send command, then open data connection + # otherwise the peer might not do a full accept (with SSL + # handshake if PROT P) + $ftp->command($cmd, @_); + my $data = $ftp->_dataconn(); + if (CMD_INFO == $ftp->response()) { + $data->reading + if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; + return $data; + } + $data->_close if $data; + + return; + } + + $ok = $ftp->port + unless (defined ${*$ftp}{'net_ftp_port'} + || defined ${*$ftp}{'net_ftp_pasv'}); + + $ok = $ftp->_REST($where) + if $ok && $where; + + return + unless $ok; + + if ($cmd =~ /(STOR|APPE|STOU)/ and exists ${*$ftp}{net_ftp_allo} and + $ftp->supported("ALLO")) + { + $ftp->_ALLO(delete ${*$ftp}{net_ftp_allo}) + or return; + } + + $ftp->command($cmd, @_); + + return 1 + if (defined ${*$ftp}{'net_ftp_pasv'}); + + $ok = CMD_INFO == $ftp->response(); + + return $ok + unless exists ${*$ftp}{'net_ftp_intern_port'}; + + if ($ok) { + my $data = $ftp->_dataconn(); + + $data->reading + if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; + + return $data; + } + + + close(delete ${*$ftp}{'net_ftp_listen'}); + + return; +} + +## +## Over-ride methods (Net::Cmd) +## + + +sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; } + + +sub command { + my $ftp = shift; + + delete ${*$ftp}{'net_ftp_port'}; + $ftp->SUPER::command(@_); +} + + +sub response { + my $ftp = shift; + my $code = $ftp->SUPER::response() || 5; # assume 500 if undef + + delete ${*$ftp}{'net_ftp_pasv'} + if ($code != CMD_MORE && $code != CMD_INFO); + + $code; +} + + +sub parse_response { + return ($1, $2 eq "-") + if $_[1] =~ s/^(\d\d\d)([- ]?)//o; + + my $ftp = shift; + + # Darn MS FTP server is a load of CRAP !!!! + # Expect to see undef here. + return () + unless 0 + (${*$ftp}{'net_cmd_code'} || 0); + + (${*$ftp}{'net_cmd_code'}, 1); +} + +## +## Allow 2 servers to talk directly +## + + +sub pasv_xfer_unique { + my ($sftp, $sfile, $dftp, $dfile) = @_; + $sftp->pasv_xfer($sfile, $dftp, $dfile, 1); +} + + +sub pasv_xfer { + my ($sftp, $sfile, $dftp, $dfile, $unique) = @_; + + ($dfile = $sfile) =~ s#.*/## + unless (defined $dfile); + + my $port = $sftp->pasv + or return; + + $dftp->port($port) + or return; + + return + unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile)); + + unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) { + $sftp->retr($sfile); + $dftp->abort; + $dftp->response(); + return; + } + + $dftp->pasv_wait($sftp); +} + + +sub pasv_wait { + @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)'; + + my ($ftp, $non_pasv) = @_; + my ($file, $rin, $rout); + + vec($rin = '', fileno($ftp), 1) = 1; + select($rout = $rin, undef, undef, undef); + + my $dres = $ftp->response(); + my $sres = $non_pasv->response(); + + return + unless $dres == CMD_OK && $sres == CMD_OK; + + return + unless $ftp->ok() && $non_pasv->ok(); + + return $1 + if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/; + + return $1 + if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/; + + return 1; +} + + +sub feature { + @_ == 2 or croak 'usage: $ftp->feature( NAME )'; + my ($ftp, $feat) = @_; + + my $feature = ${*$ftp}{net_ftp_feature} ||= do { + my @feat; + + # Example response + # 211-Features: + # MDTM + # REST STREAM + # SIZE + # 211 End + + @feat = map { /^\s+(.*\S)/ } $ftp->message + if $ftp->_FEAT; + + \@feat; + }; + + return grep { /^\Q$feat\E\b/i } @$feature; +} + + +sub cmd { shift->command(@_)->response() } + +######################################## +# +# RFC959 + RFC2428 + RFC4217 commands +# + + +sub _ABOR { shift->command("ABOR")->response() == CMD_OK } +sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK } +sub _CDUP { shift->command("CDUP")->response() == CMD_OK } +sub _NOOP { shift->command("NOOP")->response() == CMD_OK } +sub _PASV { shift->command("PASV")->response() == CMD_OK } +sub _QUIT { shift->command("QUIT")->response() == CMD_OK } +sub _DELE { shift->command("DELE", @_)->response() == CMD_OK } +sub _CWD { shift->command("CWD", @_)->response() == CMD_OK } +sub _PORT { shift->command("PORT", @_)->response() == CMD_OK } +sub _RMD { shift->command("RMD", @_)->response() == CMD_OK } +sub _MKD { shift->command("MKD", @_)->response() == CMD_OK } +sub _PWD { shift->command("PWD", @_)->response() == CMD_OK } +sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK } +sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK } +sub _RESP { shift->command("RESP", @_)->response() == CMD_OK } +sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK } +sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK } +sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } +sub _STAT { shift->command("STAT", @_)->response() == CMD_OK } +sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK } +sub _PBSZ { shift->command("PBSZ", @_)->response() == CMD_OK } +sub _PROT { shift->command("PROT", @_)->response() == CMD_OK } +sub _CCC { shift->command("CCC", @_)->response() == CMD_OK } +sub _EPRT { shift->command("EPRT", @_)->response() == CMD_OK } +sub _EPSV { shift->command("EPSV", @_)->response() == CMD_OK } +sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO } +sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO } +sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO } +sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO } +sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO } +sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO } +sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE } +sub _REST { shift->command("REST", @_)->response() == CMD_MORE } +sub _PASS { shift->command("PASS", @_)->response() } +sub _ACCT { shift->command("ACCT", @_)->response() } +sub _AUTH { shift->command("AUTH", @_)->response() } + + +sub _USER { + my $ftp = shift; + my $ok = $ftp->command("USER", @_)->response(); + + # A certain brain dead firewall :-) + $ok = $ftp->command("user", @_)->response() + unless $ok == CMD_MORE or $ok == CMD_OK; + + $ok; +} + + +sub _SMNT { shift->unsupported(@_) } +sub _MODE { shift->unsupported(@_) } +sub _SYST { shift->unsupported(@_) } +sub _STRU { shift->unsupported(@_) } +sub _REIN { shift->unsupported(@_) } + +{ + # Session Cache with single entry + # used to make sure that we reuse same session for control and data channels + package Net::FTP::_SSL_SingleSessionCache; + sub new { my $x; return bless \$x,shift } + sub add_session { + my ($cache,$key,$session) = @_; + Net::SSLeay::SESSION_free($$cache) if $$cache; + $$cache = $session; + } + sub get_session { + my $cache = shift; + return $$cache + } + sub DESTROY { + my $cache = shift; + Net::SSLeay::SESSION_free($$cache) if $$cache; + } +} + +1; + +__END__ + +# Net::Netrc.pm +# +# Copyright (C) 1995-1998 Graham Barr. All rights reserved. +# Copyright (C) 2013-2014 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::Netrc; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use FileHandle; + +our $VERSION = "3.11"; + +our $TESTING; + +my %netrc = (); + +sub _readrc { + my($class, $host) = @_; + my ($home, $file); + + if ($^O eq "MacOS") { + $home = $ENV{HOME} || `pwd`; + chomp($home); + $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); + } + else { + + # Some OS's don't have "getpwuid", so we default to $ENV{HOME} + $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; + $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; + if (-e $home . "/.netrc") { + $file = $home . "/.netrc"; + } + elsif (-e $home . "/_netrc") { + $file = $home . "/_netrc"; + } + else { + return unless $TESTING; + } + } + + my ($login, $pass, $acct) = (undef, undef, undef); + my $fh; + local $_; + + $netrc{default} = undef; + + # OS/2 and Win32 do not handle stat in a way compatible with this check :-( + unless ($^O eq 'os2' + || $^O eq 'MSWin32' + || $^O eq 'MacOS' + || $^O =~ /^cygwin/) + { + my @stat = stat($file); + + if (@stat) { + if ($stat[2] & 077) { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros) + carp "Bad permissions: $file"; + return; + } + if ($stat[4] != $<) { + carp "Not owner: $file"; + return; + } + } + } + + if ($fh = FileHandle->new($file, "r")) { + my ($mach, $macdef, $tok, @tok) = (0, 0); + + while (<$fh>) { + undef $macdef if /\A\n\Z/; + + if ($macdef) { + push(@$macdef, $_); + next; + } + + s/^\s*//; + chomp; + + while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { + (my $tok = $+) =~ s/\\(.)/$1/g; + push(@tok, $tok); + } + + TOKEN: + while (@tok) { + if ($tok[0] eq "default") { + shift(@tok); + $mach = bless {}, $class; + $netrc{default} = [$mach]; + + next TOKEN; + } + + last TOKEN + unless @tok > 1; + + $tok = shift(@tok); + + if ($tok eq "machine") { + my $host = shift @tok; + $mach = bless {machine => $host}, $class; + + $netrc{$host} = [] + unless exists($netrc{$host}); + push(@{$netrc{$host}}, $mach); + } + elsif ($tok =~ /^(login|password|account)$/) { + next TOKEN unless $mach; + my $value = shift @tok; + + # Following line added by rmerrell to remove '/' escape char in .netrc + $value =~ s/\/\\/\\/g; + $mach->{$1} = $value; + } + elsif ($tok eq "macdef") { + next TOKEN unless $mach; + my $value = shift @tok; + $mach->{macdef} = {} + unless exists $mach->{macdef}; + $macdef = $mach->{machdef}{$value} = []; + } + } + } + $fh->close(); + } +} + + +sub lookup { + my ($class, $mach, $login) = @_; + + $class->_readrc() + unless exists $netrc{default}; + + $mach ||= 'default'; + undef $login + if $mach eq 'default'; + + if (exists $netrc{$mach}) { + if (defined $login) { + foreach my $m (@{$netrc{$mach}}) { + return $m + if (exists $m->{login} && $m->{login} eq $login); + } + return; + } + return $netrc{$mach}->[0]; + } + + return $netrc{default}->[0] + if defined $netrc{default}; + + return; +} + + +sub login { + my $me = shift; + + exists $me->{login} + ? $me->{login} + : undef; +} + + +sub account { + my $me = shift; + + exists $me->{account} + ? $me->{account} + : undef; +} + + +sub password { + my $me = shift; + + exists $me->{password} + ? $me->{password} + : undef; +} + + +sub lpa { + my $me = shift; + ($me->login, $me->password, $me->account); +} + +1; + +__END__ + +# Net::Config.pm +# +# Copyright (C) 2000 Graham Barr. All rights reserved. +# Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::Config; + +use 5.008001; + +use strict; +use warnings; + +use Exporter; +use Socket qw(inet_aton inet_ntoa); + +our @EXPORT = qw(%NetConfig); +our @ISA = qw(Net::LocalCfg Exporter); +our $VERSION = "3.11"; + +our($CONFIGURE, $LIBNET_CFG); + +eval { + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + local $SIG{__DIE__}; + require Net::LocalCfg; +}; + +our %NetConfig = ( + nntp_hosts => [], + snpp_hosts => [], + pop3_hosts => [], + smtp_hosts => [], + ph_hosts => [], + daytime_hosts => [], + time_hosts => [], + inet_domain => undef, + ftp_firewall => undef, + ftp_ext_passive => 1, + ftp_int_passive => 1, + test_hosts => 1, + test_exist => 1, +); + +# +# Try to get as much configuration info as possible from InternetConfig +# +{ +## no critic (BuiltinFunctions::ProhibitStringyEval) +$^O eq 'MacOS' and eval < [ \$InternetConfig{ kICNNTPHost() } ], + pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ], + smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ], + ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef, + ph_hosts => [ \$InternetConfig{ kICPhHost() } ], + ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, + ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, + socks_hosts => + \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [], + ftp_firewall => + \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [], +); +\@NetConfig{keys %nc} = values %nc; +} +TRY_INTERNET_CONFIG +} + +my $file = __FILE__; +my $ref; +$file =~ s/Config.pm/libnet.cfg/; +if (-f $file) { + $ref = eval { local $SIG{__DIE__}; do $file }; + if (ref($ref) eq 'HASH') { + %NetConfig = (%NetConfig, %{$ref}); + $LIBNET_CFG = $file; + } +} +if ($< == $> and !$CONFIGURE) { + my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME}; + $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; + if (defined $home) { + $file = $home . "/.libnetrc"; + $ref = eval { local $SIG{__DIE__}; do $file } if -f $file; + %NetConfig = (%NetConfig, %{$ref}) + if ref($ref) eq 'HASH'; + } +} +my ($k, $v); +while (($k, $v) = each %NetConfig) { + $NetConfig{$k} = [$v] + if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v)); +} + +# Take a hostname and determine if it is inside the firewall + + +sub requires_firewall { + shift; # ignore package + my $host = shift; + + return 0 unless defined $NetConfig{'ftp_firewall'}; + + $host = inet_aton($host) or return -1; + $host = inet_ntoa($host); + + if (exists $NetConfig{'local_netmask'}) { + my $quad = unpack("N", pack("C*", split(/\./, $host))); + my $list = $NetConfig{'local_netmask'}; + $list = [$list] unless ref($list); + foreach (@$list) { + my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next; + my $mask = ~0 << (32 - $bits); + my $addr = unpack("N", pack("C*", split(/\./, $net))); + + return 0 if (($addr & $mask) == ($quad & $mask)); + } + return 1; + } + + return 0; +} + +*is_external = \&requires_firewall; + +1; + +__END__ + +# Net::Cmd.pm +# +# Copyright (C) 1995-2006 Graham Barr. All rights reserved. +# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::Cmd; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Exporter; +use Symbol 'gensym'; +use Errno 'EINTR'; + +BEGIN { + if ($^O eq 'os390') { + require Convert::EBCDIC; + + # Convert::EBCDIC->import; + } +} + +our $VERSION = "3.11"; +our @ISA = qw(Exporter); +our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); + +use constant CMD_INFO => 1; +use constant CMD_OK => 2; +use constant CMD_MORE => 3; +use constant CMD_REJECT => 4; +use constant CMD_ERROR => 5; +use constant CMD_PENDING => 0; + +use constant DEF_REPLY_CODE => 421; + +my %debug = (); + +my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; + +sub toebcdic { + my $cmd = shift; + + unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { + my $string = $_[0]; + my $ebcdicstr = $tr->toebcdic($string); + ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; + } + + ${*$cmd}{'net_cmd_asciipeer'} + ? $tr->toebcdic($_[0]) + : $_[0]; +} + + +sub toascii { + my $cmd = shift; + ${*$cmd}{'net_cmd_asciipeer'} + ? $tr->toascii($_[0]) + : $_[0]; +} + + +sub _print_isa { + no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) + + my $pkg = shift; + my $cmd = $pkg; + + $debug{$pkg} ||= 0; + + my %done = (); + my @do = ($pkg); + my %spc = ($pkg, ""); + + while ($pkg = shift @do) { + next if defined $done{$pkg}; + + $done{$pkg} = 1; + + my $v = + defined ${"${pkg}::VERSION"} + ? "(" . ${"${pkg}::VERSION"} . ")" + : ""; + + my $spc = $spc{$pkg}; + $cmd->debug_print(1, "${spc}${pkg}${v}\n"); + + if (@{"${pkg}::ISA"}) { + @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; + unshift(@do, @{"${pkg}::ISA"}); + } + } +} + + +sub debug { + @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; + + my ($cmd, $level) = @_; + my $pkg = ref($cmd) || $cmd; + my $oldval = 0; + + if (ref($cmd)) { + $oldval = ${*$cmd}{'net_cmd_debug'} || 0; + } + else { + $oldval = $debug{$pkg} || 0; + } + + return $oldval + unless @_ == 2; + + $level = $debug{$pkg} || 0 + unless defined $level; + + _print_isa($pkg) + if ($level && !exists $debug{$pkg}); + + if (ref($cmd)) { + ${*$cmd}{'net_cmd_debug'} = $level; + } + else { + $debug{$pkg} = $level; + } + + $oldval; +} + + +sub message { + @_ == 1 or croak 'usage: $obj->message()'; + + my $cmd = shift; + + wantarray + ? @{${*$cmd}{'net_cmd_resp'}} + : join("", @{${*$cmd}{'net_cmd_resp'}}); +} + + +sub debug_text { $_[2] } + + +sub debug_print { + my ($cmd, $out, $text) = @_; + print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); +} + + +sub code { + @_ == 1 or croak 'usage: $obj->code()'; + + my $cmd = shift; + + ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE + unless exists ${*$cmd}{'net_cmd_code'}; + + ${*$cmd}{'net_cmd_code'}; +} + + +sub status { + @_ == 1 or croak 'usage: $obj->status()'; + + my $cmd = shift; + + substr(${*$cmd}{'net_cmd_code'}, 0, 1); +} + + +sub set_status { + @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)'; + + my $cmd = shift; + my ($code, $resp) = @_; + + $resp = defined $resp ? [$resp] : [] + unless ref($resp); + + (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); + + 1; +} + +sub _syswrite_with_timeout { + my $cmd = shift; + my $line = shift; + + my $len = length($line); + my $offset = 0; + my $win = ""; + vec($win, fileno($cmd), 1) = 1; + my $timeout = $cmd->timeout || undef; + my $initial = time; + my $pending = $timeout; + + local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; + + while ($len) { + my $wout; + my $nfound = select(undef, $wout = $win, undef, $pending); + if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32 + { + my $w = syswrite($cmd, $line, $len, $offset); + if (! defined($w) ) { + my $err = $!; + $cmd->close; + $cmd->_set_status_closed($err); + return; + } + $len -= $w; + $offset += $w; + } + elsif ($nfound == -1) { + if ( $! == EINTR ) { + if ( defined($timeout) ) { + redo if ($pending = $timeout - ( time - $initial ) ) > 0; + $cmd->_set_status_timeout; + return; + } + redo; + } + my $err = $!; + $cmd->close; + $cmd->_set_status_closed($err); + return; + } + else { + $cmd->_set_status_timeout; + return; + } + } + + return 1; +} + +sub _set_status_timeout { + my $cmd = shift; + my $pkg = ref($cmd) || $cmd; + + $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout"); + carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug; +} + +sub _set_status_closed { + my $cmd = shift; + my $err = shift; + my $pkg = ref($cmd) || $cmd; + + $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed"); + carp(ref($cmd) . ": " . (caller(1))[3] + . "(): unexpected EOF on command channel: $err") if $cmd->debug; +} + +sub _is_closed { + my $cmd = shift; + if (!defined fileno($cmd)) { + $cmd->_set_status_closed($!); + return 1; + } + return 0; +} + +sub command { + my $cmd = shift; + + return $cmd + if $cmd->_is_closed; + + $cmd->dataend() + if (exists ${*$cmd}{'net_cmd_last_ch'}); + + if (scalar(@_)) { + my $str = join( + " ", + map { + /\n/ + ? do { my $n = $_; $n =~ tr/\n/ /; $n } + : $_; + } @_ + ); + $str = $cmd->toascii($str) if $tr; + $str .= "\015\012"; + + $cmd->debug_print(1, $str) + if ($cmd->debug); + + # though documented to return undef on failure, the legacy behavior + # was to return $cmd even on failure, so this odd construct does that + $cmd->_syswrite_with_timeout($str) + or return $cmd; + } + + $cmd; +} + + +sub ok { + @_ == 1 or croak 'usage: $obj->ok()'; + + my $code = $_[0]->code; + 0 < $code && $code < 400; +} + + +sub unsupported { + my $cmd = shift; + + $cmd->set_status(580, 'Unsupported command'); + + 0; +} + + +sub getline { + my $cmd = shift; + + ${*$cmd}{'net_cmd_lines'} ||= []; + + return shift @{${*$cmd}{'net_cmd_lines'}} + if scalar(@{${*$cmd}{'net_cmd_lines'}}); + + my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; + + return + if $cmd->_is_closed; + + my $fd = fileno($cmd); + my $rin = ""; + vec($rin, $fd, 1) = 1; + + my $buf; + + until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { + my $timeout = $cmd->timeout || undef; + my $rout; + + my $select_ret = select($rout = $rin, undef, undef, $timeout); + if ($select_ret > 0) { + unless (sysread($cmd, $buf = "", 1024)) { + my $err = $!; + $cmd->close; + $cmd->_set_status_closed($err); + return; + } + + substr($buf, 0, 0) = $partial; ## prepend from last sysread + + my @buf = split(/\015?\012/, $buf, -1); ## break into lines + + $partial = pop @buf; + + push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); + + } + else { + $cmd->_set_status_timeout; + return; + } + } + + ${*$cmd}{'net_cmd_partial'} = $partial; + + if ($tr) { + foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { + $ln = $cmd->toebcdic($ln); + } + } + + shift @{${*$cmd}{'net_cmd_lines'}}; +} + + +sub ungetline { + my ($cmd, $str) = @_; + + ${*$cmd}{'net_cmd_lines'} ||= []; + unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); +} + + +sub parse_response { + return () + unless $_[1] =~ s/^(\d\d\d)(.?)//o; + ($1, $2 eq "-"); +} + + +sub response { + my $cmd = shift; + my ($code, $more) = (undef) x 2; + + $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response + + while (1) { + my $str = $cmd->getline(); + + return CMD_ERROR + unless defined($str); + + $cmd->debug_print(0, $str) + if ($cmd->debug); + + ($code, $more) = $cmd->parse_response($str); + unless (defined $code) { + carp("$cmd: response(): parse error in '$str'") if ($cmd->debug); + $cmd->ungetline($str); + $@ = $str; # $@ used as tunneling hack + return CMD_ERROR; + } + + ${*$cmd}{'net_cmd_code'} = $code; + + push(@{${*$cmd}{'net_cmd_resp'}}, $str); + + last unless ($more); + } + + return unless defined $code; + substr($code, 0, 1); +} + + +sub read_until_dot { + my $cmd = shift; + my $fh = shift; + my $arr = []; + + while (1) { + my $str = $cmd->getline() or return; + + $cmd->debug_print(0, $str) + if ($cmd->debug & 4); + + last if ($str =~ /^\.\r?\n/o); + + $str =~ s/^\.\././o; + + if (defined $fh) { + print $fh $str; + } + else { + push(@$arr, $str); + } + } + + $arr; +} + + +sub datasend { + my $cmd = shift; + my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; + my $line = join("", @$arr); + + # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with + # the substitutions below when dealing with strings stored internally in + # UTF-8, so downgrade them (if possible). + # Data passed to datasend() should be encoded to octets upstream already so + # shouldn't even have the UTF-8 flag on to start with, but if it so happens + # that the octets are stored in an upgraded string (as can sometimes occur) + # then they would still downgrade without fail anyway. + # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to + # downgrade. We fail silently in that case, and a "Wide character in print" + # warning will be emitted later by syswrite(). + utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; + + return 0 + if $cmd->_is_closed; + + my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; + + # We have not send anything yet, so last_ch = "\012" means we are at the start of a line + $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; + + return 1 unless length $line; + + if ($cmd->debug) { + foreach my $b (split(/\n/, $line)) { + $cmd->debug_print(1, "$b\n"); + } + } + + $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; + + my $first_ch = ''; + + if ($last_ch eq "\015") { + # Remove \012 so it does not get prefixed with another \015 below + # and escape the . if there is one following it because the fixup + # below will not find it + $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/; + } + elsif ($last_ch eq "\012") { + # Fixup below will not find the . as the first character of the buffer + $first_ch = "." if $line =~ /^\./; + } + + $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; + + substr($line, 0, 0) = $first_ch; + + ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); + + $cmd->_syswrite_with_timeout($line) + or return; + + 1; +} + + +sub rawdatasend { + my $cmd = shift; + my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; + my $line = join("", @$arr); + + return 0 + if $cmd->_is_closed; + + return 1 + unless length($line); + + if ($cmd->debug) { + my $b = "$cmd>>> "; + print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; + } + + $cmd->_syswrite_with_timeout($line) + or return; + + 1; +} + + +sub dataend { + my $cmd = shift; + + return 0 + if $cmd->_is_closed; + + my $ch = ${*$cmd}{'net_cmd_last_ch'}; + my $tosend; + + if (!defined $ch) { + return 1; + } + elsif ($ch ne "\012") { + $tosend = "\015\012"; + } + + $tosend .= ".\015\012"; + + $cmd->debug_print(1, ".\n") + if ($cmd->debug); + + $cmd->_syswrite_with_timeout($tosend) + or return 0; + + delete ${*$cmd}{'net_cmd_last_ch'}; + + $cmd->response() == CMD_OK; +} + +# read and write to tied filehandle +sub tied_fh { + my $cmd = shift; + ${*$cmd}{'net_cmd_readbuf'} = ''; + my $fh = gensym(); + tie *$fh, ref($cmd), $cmd; + return $fh; +} + +# tie to myself +sub TIEHANDLE { + my $class = shift; + my $cmd = shift; + return $cmd; +} + +# Tied filehandle read. Reads requested data length, returning +# end-of-file when the dot is encountered. +sub READ { + my $cmd = shift; + my ($len, $offset) = @_[1, 2]; + return unless exists ${*$cmd}{'net_cmd_readbuf'}; + my $done = 0; + while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { + ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; + $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; + } + + $_[0] = ''; + substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); + substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; + delete ${*$cmd}{'net_cmd_readbuf'} if $done; + + return length $_[0]; +} + + +sub READLINE { + my $cmd = shift; + + # in this context, we use the presence of readbuf to + # indicate that we have not yet reached the eof + return unless exists ${*$cmd}{'net_cmd_readbuf'}; + my $line = $cmd->getline; + return if $line =~ /^\.\r?\n/; + $line; +} + + +sub PRINT { + my $cmd = shift; + my ($buf, $len, $offset) = @_; + $len ||= length($buf); + $offset += 0; + return unless $cmd->datasend(substr($buf, $offset, $len)); + ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() + return $len; +} + + +sub CLOSE { + my $cmd = shift; + my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; + delete ${*$cmd}{'net_cmd_readbuf'}; + delete ${*$cmd}{'net_cmd_sending'}; + $r; +} + +1; + +__END__ + + +# Net::POP3.pm +# +# Copyright (C) 1995-2004 Graham Barr. All rights reserved. +# Copyright (C) 2013-2016 Steve Hay. All rights reserved. +# This module is free software; you can redistribute it and/or modify it under +# the same terms as Perl itself, i.e. under the terms of either the GNU General +# Public License or the Artistic License, as specified in the F file. + +package Net::POP3; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use IO::Socket; +use Net::Cmd; +use Net::Config; + +our $VERSION = "3.11"; + +# Code for detecting if we can use SSL +my $ssl_class = eval { + require IO::Socket::SSL; + # first version with default CA on most platforms + no warnings 'numeric'; + IO::Socket::SSL->VERSION(2.007); +} && 'IO::Socket::SSL'; + +my $nossl_warn = !$ssl_class && + 'To use SSL please install IO::Socket::SSL with version>=2.007'; + +# Code for detecting if we can use IPv6 +my $family_key = 'Domain'; +my $inet6_class = eval { + require IO::Socket::IP; + no warnings 'numeric'; + IO::Socket::IP->VERSION(0.25) || die; + $family_key = 'Family'; +} && 'IO::Socket::IP' || eval { + require IO::Socket::INET6; + no warnings 'numeric'; + IO::Socket::INET6->VERSION(2.62); +} && 'IO::Socket::INET6'; + + +sub can_ssl { $ssl_class }; +sub can_inet6 { $inet6_class }; + +our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); + +sub new { + my $self = shift; + my $type = ref($self) || $self; + my ($host, %arg); + if (@_ % 2) { + $host = shift; + %arg = @_; + } + else { + %arg = @_; + $host = delete $arg{Host}; + } + my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts}; + my $obj; + + if ($arg{SSL}) { + # SSL from start + die $nossl_warn if !$ssl_class; + $arg{Port} ||= 995; + } + + $arg{Timeout} = 120 if ! defined $arg{Timeout}; + + foreach my $h (@{$hosts}) { + $obj = $type->SUPER::new( + PeerAddr => ($host = $h), + PeerPort => $arg{Port} || 'pop3(110)', + Proto => 'tcp', + $family_key => $arg{Domain} || $arg{Family}, + LocalAddr => $arg{LocalAddr}, + LocalPort => exists($arg{ResvPort}) ? $arg{ResvPort} : $arg{LocalPort}, + Timeout => $arg{Timeout}, + ) + and last; + } + + return + unless defined $obj; + + ${*$obj}{'net_pop3_arg'} = \%arg; + ${*$obj}{'net_pop3_host'} = $host; + if ($arg{SSL}) { + Net::POP3::_SSL->start_SSL($obj,%arg) or return; + } + + $obj->autoflush(1); + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + unless ($obj->response() == CMD_OK) { + $obj->close(); + return; + } + + ${*$obj}{'net_pop3_banner'} = $obj->message; + + $obj; +} + + +sub host { + my $me = shift; + ${*$me}{'net_pop3_host'}; +} + +## +## We don't want people sending me their passwords when they report problems +## now do we :-) +## + + +sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } + + +sub login { + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; + my ($me, $user, $pass) = @_; + + if (@_ <= 2) { + ($user, $pass) = $me->_lookup_credentials($user); + } + + $me->user($user) + and $me->pass($pass); +} + +sub starttls { + my $self = shift; + $ssl_class or die $nossl_warn; + $self->_STLS or return; + Net::POP3::_SSL->start_SSL($self, + %{ ${*$self}{'net_pop3_arg'} }, # (ssl) args given in new + @_ # more (ssl) args + ) or return; + return 1; +} + +sub apop { + @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; + my ($me, $user, $pass) = @_; + my $banner; + my $md; + + if (eval { local $SIG{__DIE__}; require Digest::MD5 }) { + $md = Digest::MD5->new(); + } + elsif (eval { local $SIG{__DIE__}; require MD5 }) { + $md = MD5->new(); + } + else { + carp "You need to install Digest::MD5 or MD5 to use the APOP command"; + return; + } + + return + unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]); + + if (@_ <= 2) { + ($user, $pass) = $me->_lookup_credentials($user); + } + + $md->add($banner, $pass); + + return + unless ($me->_APOP($user, $md->hexdigest)); + + $me->_get_mailbox_count(); +} + + +sub user { + @_ == 2 or croak 'usage: $pop3->user( USER )'; + $_[0]->_USER($_[1]) ? 1 : undef; +} + + +sub pass { + @_ == 2 or croak 'usage: $pop3->pass( PASS )'; + + my ($me, $pass) = @_; + + return + unless ($me->_PASS($pass)); + + $me->_get_mailbox_count(); +} + + +sub reset { + @_ == 1 or croak 'usage: $obj->reset()'; + + my $me = shift; + + return 0 + unless ($me->_RSET); + + if (defined ${*$me}{'net_pop3_mail'}) { + local $_; + foreach (@{${*$me}{'net_pop3_mail'}}) { + delete $_->{'net_pop3_deleted'}; + } + } +} + + +sub last { + @_ == 1 or croak 'usage: $obj->last()'; + + return + unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; + + return $1; +} + + +sub top { + @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; + my $me = shift; + + return + unless $me->_TOP($_[0], $_[1] || 0); + + $me->read_until_dot; +} + + +sub popstat { + @_ == 1 or croak 'usage: $pop3->popstat()'; + my $me = shift; + + return () + unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; + + ($1 || 0, $2 || 0); +} + + +sub list { + @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; + my $me = shift; + + return + unless $me->_LIST(@_); + + if (@_) { + $me->message =~ /\d+\D+(\d+)/; + return $1 || undef; + } + + my $info = $me->read_until_dot + or return; + + my %hash = map { (/(\d+)\D+(\d+)/) } @$info; + + return \%hash; +} + + +sub get { + @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; + my $me = shift; + + return + unless $me->_RETR(shift); + + $me->read_until_dot(@_); +} + + +sub getfh { + @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )'; + my $me = shift; + + return unless $me->_RETR(shift); + return $me->tied_fh; +} + + +sub delete { + @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; + my $me = shift; + return 0 unless $me->_DELE(@_); + ${*$me}{'net_pop3_deleted'} = 1; +} + + +sub uidl { + @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; + my $me = shift; + my $uidl; + + $me->_UIDL(@_) + or return; + if (@_) { + $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; + } + else { + my $ref = $me->read_until_dot + or return; + $uidl = {}; + foreach my $ln (@$ref) { + my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; + $uidl->{$msg} = $uid; + } + } + return $uidl; +} + + +sub ping { + @_ == 2 or croak 'usage: $pop3->ping( USER )'; + my $me = shift; + + return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; + + ($1 || 0, $2 || 0); +} + + +sub _lookup_credentials { + my ($me, $user) = @_; + + require Net::Netrc; + + $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } + || $ENV{NAME} + || $ENV{USER} + || $ENV{LOGNAME}; + + my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user); + $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); + + my $pass = $m + ? $m->password || "" + : ""; + + ($user, $pass); +} + + +sub _get_mailbox_count { + my ($me) = @_; + my $ret = ${*$me}{'net_pop3_count'} = + ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0]; + + $ret ? $ret : "0E0"; +} + + +sub _STAT { shift->command('STAT' )->response() == CMD_OK } +sub _LIST { shift->command('LIST', @_)->response() == CMD_OK } +sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK } +sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK } +sub _NOOP { shift->command('NOOP' )->response() == CMD_OK } +sub _RSET { shift->command('RSET' )->response() == CMD_OK } +sub _QUIT { shift->command('QUIT' )->response() == CMD_OK } +sub _TOP { shift->command( 'TOP', @_)->response() == CMD_OK } +sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK } +sub _USER { shift->command('USER', $_[0])->response() == CMD_OK } +sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK } +sub _APOP { shift->command('APOP', @_)->response() == CMD_OK } +sub _PING { shift->command('PING', $_[0])->response() == CMD_OK } +sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK } +sub _LAST { shift->command('LAST' )->response() == CMD_OK } +sub _CAPA { shift->command('CAPA' )->response() == CMD_OK } +sub _STLS { shift->command("STLS", )->response() == CMD_OK } + + +sub quit { + my $me = shift; + + $me->_QUIT; + $me->close; +} + + +sub DESTROY { + my $me = shift; + + if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) { + $me->reset; + $me->quit; + } +} + +## +## POP3 has weird responses, so we emulate them to look the same :-) +## + + +sub response { + my $cmd = shift; + my $str = $cmd->getline() or return; + my $code = "500"; + + $cmd->debug_print(0, $str) + if ($cmd->debug); + + if ($str =~ s/^\+OK\s*//io) { + $code = "200"; + } + elsif ($str =~ s/^\+\s*//io) { + $code = "300"; + } + else { + $str =~ s/^-ERR\s*//io; + } + + ${*$cmd}{'net_cmd_resp'} = [$str]; + ${*$cmd}{'net_cmd_code'} = $code; + + substr($code, 0, 1); +} + + +sub capa { + my $this = shift; + my ($capa, %capabilities); + + # Fake a capability here + $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/); + + if ($this->_CAPA()) { + $capabilities{CAPA} = 1; + $capa = $this->read_until_dot(); + %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa); + } + else { + + # Check AUTH for SASL capabilities + if ($this->command('AUTH')->response() == CMD_OK) { + my $mechanism = $this->read_until_dot(); + $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism}; + } + } + + return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; +} + + +sub capabilities { + my $this = shift; + + ${*$this}{'net_pop3e_capabilities'} || $this->capa; +} + + +sub auth { + my ($self, $username, $password) = @_; + + eval { + require MIME::Base64; + require Authen::SASL; + } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; + + my $capa = $self->capa; + my $mechanisms = $capa->{SASL} || 'CRAM-MD5'; + + my $sasl; + + if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { + $sasl = $username; + my $user_mech = $sasl->mechanism || ''; + my @user_mech = split(/\s+/, $user_mech); + my %user_mech; + @user_mech{@user_mech} = (); + + my @server_mech = split(/\s+/, $mechanisms); + my @mech = @user_mech + ? grep { exists $user_mech{$_} } @server_mech + : @server_mech; + unless (@mech) { + $self->set_status( + 500, + [ 'Client SASL mechanisms (', + join(', ', @user_mech), + ') do not match the SASL mechnism the server announces (', + join(', ', @server_mech), ')', + ] + ); + return 0; + } + + $sasl->mechanism(join(" ", @mech)); + } + else { + die "auth(username, password)" if not length $username; + $sasl = Authen::SASL->new( + mechanism => $mechanisms, + callback => { + user => $username, + pass => $password, + authname => $username, + } + ); + } + + # We should probably allow the user to pass the host, but I don't + # currently know and SASL mechanisms that are used by smtp that need it + my ($hostname) = split /:/, ${*$self}{'net_pop3_host'}; + my $client = eval { $sasl->client_new('pop', $hostname, 0) }; + + unless ($client) { + my $mech = $sasl->mechanism; + $self->set_status( + 500, + [ " Authen::SASL failure: $@", + '(please check if your local Authen::SASL installation', + "supports mechanism '$mech'" + ] + ); + return 0; + } + + my ($token) = $client->client_start + or do { + my $mech = $client->mechanism; + $self->set_status( + 500, + [ ' Authen::SASL failure: $client->client_start ', + "mechanism '$mech' hostname #$hostname#", + $client->error + ] + ); + return 0; + }; + + # We don't support sasl mechanisms that encrypt the socket traffic. + # todo that we would really need to change the ISA hierarchy + # so we don't inherit from IO::Socket, but instead hold it in an attribute + + my @cmd = ("AUTH", $client->mechanism); + my $code; + + push @cmd, MIME::Base64::encode_base64($token, '') + if defined $token and length $token; + + while (($code = $self->command(@cmd)->response()) == CMD_MORE) { + + my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do { + $self->set_status( + 500, + [ ' Authen::SASL failure: $client->client_step ', + "mechanism '", $client->mechanism, " hostname #$hostname#, ", + $client->error + ] + ); + return 0; + }; + + @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', '')); + } + + $code == CMD_OK; +} + + +sub banner { + my $this = shift; + + return ${*$this}{'net_pop3_banner'}; +} + +{ + package Net::POP3::_SSL; + our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::POP3' ); + sub starttls { die "POP3 connection is already in SSL mode" } + sub start_SSL { + my ($class,$pop3,%arg) = @_; + delete @arg{ grep { !m{^SSL_} } keys %arg }; + ( $arg{SSL_verifycn_name} ||= $pop3->host ) + =~s{(?can_client_sni; + $arg{SSL_verifycn_scheme} ||= 'pop3'; + my $ok = $class->SUPER::start_SSL($pop3,%arg); + $@ = $ssl_class->errstr if !$ok; + return $ok; + } +} + + + +1; + +__END__ + +package Net::netent; +use strict; + +use 5.006_001; +our $VERSION = '1.01'; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ( + $n_name, @n_aliases, + $n_addrtype, $n_net +); + +BEGIN { + use Exporter (); + @EXPORT = qw(getnetbyname getnetbyaddr getnet); + @EXPORT_OK = qw( + $n_name @n_aliases + $n_addrtype $n_net + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'Net::netent' => [ + name => '$', + aliases => '@', + addrtype => '$', + net => '$', +]; + +sub populate (@) { + return unless @_; + my $nob = new(); + $n_name = $nob->[0] = $_[0]; + @n_aliases = @{ $nob->[1] } = split ' ', $_[1]; + $n_addrtype = $nob->[2] = $_[2]; + $n_net = $nob->[3] = $_[3]; + return $nob; +} + +sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) } + +sub getnetbyaddr ($;$) { + my ($net, $addrtype); + $net = shift; + require Socket if @_; + $addrtype = @_ ? shift : Socket::AF_INET(); + populate(CORE::getnetbyaddr($net, $addrtype)) +} + +sub getnet($) { + if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { + require Socket; + &getnetbyaddr(Socket::inet_aton(shift)); + } else { + &getnetbyname; + } +} + +1; +__END__ + +## +## Generic data connection package +## + +package Net::FTP::dataconn; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Errno; +use Net::Cmd; + +our $VERSION = '3.11'; + +$Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn"; +our @ISA = $Net::FTP::IOCLASS; + +sub reading { + my $data = shift; + ${*$data}{'net_ftp_bytesread'} = 0; +} + + +sub abort { + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + # no need to abort if we have finished the xfer + return $data->close + if ${*$data}{'net_ftp_eof'}; + + # for some reason if we continuously open RETR connections and not + # read a single byte, then abort them after a while the server will + # close our connection, this prevents the unexpected EOF on the + # command channel -- GMB + if (exists ${*$data}{'net_ftp_bytesread'} + && (${*$data}{'net_ftp_bytesread'} == 0)) + { + my $buf = ""; + my $timeout = $data->timeout; + $data->can_read($timeout) && sysread($data, $buf, 1); + } + + ${*$data}{'net_ftp_eof'} = 1; # fake + + $ftp->abort; # this will close me +} + + +sub _close { + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + $data->SUPER::close(); + + delete ${*$ftp}{'net_ftp_dataconn'} + if defined $ftp + && exists ${*$ftp}{'net_ftp_dataconn'} + && $data == ${*$ftp}{'net_ftp_dataconn'}; +} + + +sub close { + my $data = shift; + my $ftp = ${*$data}{'net_ftp_cmd'}; + + if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) { + my $junk; + eval { local($SIG{__DIE__}); $data->read($junk, 1, 0) }; + return $data->abort unless ${*$data}{'net_ftp_eof'}; + } + + $data->_close; + + return unless defined $ftp; + + $ftp->response() == CMD_OK + && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ + && (${*$ftp}{'net_ftp_unique'} = $1); + + $ftp->status == CMD_OK; +} + + +sub _select { + my ($data, $timeout, $do_read) = @_; + my ($rin, $rout, $win, $wout, $tout, $nfound); + + vec($rin = '', fileno($data), 1) = 1; + + ($win, $rin) = ($rin, $win) unless $do_read; + + while (1) { + $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout); + + last if $nfound >= 0; + + croak "select: $!" + unless $!{EINTR}; + } + + $nfound; +} + + +sub can_read { + _select(@_[0, 1], 1); +} + + +sub can_write { + _select(@_[0, 1], 0); +} + + +sub cmd { + my $ftp = shift; + + ${*$ftp}{'net_ftp_cmd'}; +} + + +sub bytes_read { + my $ftp = shift; + + ${*$ftp}{'net_ftp_bytesread'} || 0; +} + +1; + +__END__ + +## +## Package to read/write on BINARY data connections +## + +package Net::FTP::I; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Net::FTP::dataconn; + +our @ISA = qw(Net::FTP::dataconn); +our $VERSION = "3.11"; + +our $buf; + +sub read { + my $data = shift; + local *buf = \$_[0]; + shift; + my $size = shift || croak 'read($buf,$size,[$timeout])'; + my $timeout = @_ ? shift: $data->timeout; + + my $n; + + if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) { + $data->can_read($timeout) + or croak "Timeout"; + + my $blksize = ${*$data}{'net_ftp_blksize'}; + $blksize = $size if $size > $blksize; + + unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) { + return unless defined $n; + ${*$data}{'net_ftp_eof'} = 1; + } + } + + $buf = substr(${*$data}, 0, $size); + + $n = length($buf); + + substr(${*$data}, 0, $n) = ''; + + ${*$data}{'net_ftp_bytesread'} += $n; + + $n; +} + + +sub write { + my $data = shift; + local *buf = \$_[0]; + shift; + my $size = shift || croak 'write($buf,$size,[$timeout])'; + my $timeout = @_ ? shift: $data->timeout; + + # If the remote server has closed the connection we will be signal'd + # when we write. This can happen if the disk on the remote server fills up + + local $SIG{PIPE} = 'IGNORE' + unless ($SIG{PIPE} || '') eq 'IGNORE' + or $^O eq 'MacOS'; + my $sent = $size; + my $off = 0; + + my $blksize = ${*$data}{'net_ftp_blksize'}; + while ($sent > 0) { + $data->can_write($timeout) + or croak "Timeout"; + + my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off); + return unless defined($n); + $sent -= $n; + $off += $n; + } + + $size; +} + +1; +## +## Package to read/write on ASCII data connections +## + +package Net::FTP::A; + +use 5.008001; + +use strict; +use warnings; + +use Carp; +use Net::FTP::dataconn; + +our @ISA = qw(Net::FTP::dataconn); +our $VERSION = "3.11"; + +our $buf; + +sub read { + my $data = shift; + local *buf = \$_[0]; + shift; + my $size = shift || croak 'read($buf,$size,[$offset])'; + my $timeout = @_ ? shift: $data->timeout; + + if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) { + my $blksize = ${*$data}{'net_ftp_blksize'}; + $blksize = $size if $size > $blksize; + + my $l = 0; + my $n; + + READ: + { + my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : ''; + + $data->can_read($timeout) + or croak "Timeout"; + + if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) { + ${*$data}{'net_ftp_bytesread'} += $n; + ${*$data}{'net_ftp_cr'} = + substr($readbuf, -1) eq "\015" + ? chop($readbuf) + : undef; + } + else { + return + unless defined $n; + + ${*$data}{'net_ftp_eof'} = 1; + } + + $readbuf =~ s/\015\012/\n/sgo; + ${*$data} .= $readbuf; + + unless (length(${*$data})) { + + redo READ + if ($n > 0); + + $size = length(${*$data}) + if ($n == 0); + } + } + } + + $buf = substr(${*$data}, 0, $size); + substr(${*$data}, 0, $size) = ''; + + length $buf; +} + + +sub write { + my $data = shift; + local *buf = \$_[0]; + shift; + my $size = shift || croak 'write($buf,$size,[$timeout])'; + my $timeout = @_ ? shift: $data->timeout; + + my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/; + $tmp =~ s/(?can_write($timeout) + or croak "Timeout"; + + $off += $wrote; + $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len); + return + unless defined($wrote); + $len -= $wrote; + } + + $size; +} + +1; +package Net::FTP::L; + +use 5.008001; + +use strict; +use warnings; + +use Net::FTP::I; + +our @ISA = qw(Net::FTP::I); +our $VERSION = "3.11"; + +1; +package Net::FTP::E; + +use 5.008001; + +use strict; +use warnings; + +use Net::FTP::I; + +our @ISA = qw(Net::FTP::I); +our $VERSION = "3.11"; + +1; +package Time::gmtime; +use strict; +use 5.006_001; + +use Time::tm; + +our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); +our ( $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst, +); + +BEGIN { + use Exporter (); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(gmtime gmctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.04; +} + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)} +sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)} + +1; +__END__ + +package Time::localtime; +use strict; +use 5.006_001; + +use Time::tm; + +our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); +our ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst +); + +BEGIN { + use Exporter (); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(localtime ctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.03; +} + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)} +sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) } + +1; + +__END__ + +package Time::Local; + +use strict; + +use Carp (); +use Exporter; + +our $VERSION = '1.25'; + +use parent 'Exporter'; + +our @EXPORT = qw( timegm timelocal ); +our @EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); + +my @MonthDays = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); + +# Determine breakpoint for rolling century +my $ThisYear = ( localtime() )[5]; +my $Breakpoint = ( $ThisYear + 50 ) % 100; +my $NextCentury = $ThisYear - $ThisYear % 100; +$NextCentury += 100 if $Breakpoint < 50; +my $Century = $NextCentury - 100; +my $SecOff = 0; + +my ( %Options, %Cheat ); + +use constant SECS_PER_MINUTE => 60; +use constant SECS_PER_HOUR => 3600; +use constant SECS_PER_DAY => 86400; + +my $MaxDay; +if ( $] < 5.012000 ) { + require Config; + ## no critic (Variables::ProhibitPackageVars) + + my $MaxInt; + if ( $^O eq 'MacOS' ) { + + # time_t is unsigned... + $MaxInt = ( 1 << ( 8 * $Config::Config{ivsize} ) ) + - 1; ## no critic qw(ProhibitPackageVars) + } + else { + $MaxInt + = ( ( 1 << ( 8 * $Config::Config{ivsize} - 2 ) ) - 1 ) * 2 + + 1; ## no critic qw(ProhibitPackageVars) + } + + $MaxDay = int( ( $MaxInt - ( SECS_PER_DAY / 2 ) ) / SECS_PER_DAY ) - 1; +} +else { + # recent localtime()'s limit is the year 2**31 + $MaxDay = 365 * ( 2**31 ); +} + +# Determine the EPOC day for this machine +my $Epoc = 0; +if ( $^O eq 'vos' ) { + + # work around posix-977 -- VOS doesn't handle dates in the range + # 1970-1980. + $Epoc = _daygm( 0, 0, 0, 1, 0, 70, 4, 0 ); +} +elsif ( $^O eq 'MacOS' ) { + $MaxDay *= 2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack? + # MacOS time() is seconds since 1 Jan 1904, localtime + # so we need to calculate an offset to apply later + $Epoc = 693901; + $SecOff = timelocal( localtime(0) ) - timelocal( gmtime(0) ); + $Epoc += _daygm( gmtime(0) ); +} +else { + $Epoc = _daygm( gmtime(0) ); +} + +%Cheat = (); # clear the cache as epoc has changed + +sub _daygm { + + # This is written in such a byzantine way in order to avoid + # lexical variables and sub calls, for speed + return $_[3] + ( + $Cheat{ pack( 'ss', @_[ 4, 5 ] ) } ||= do { + my $month = ( $_[4] + 10 ) % 12; + my $year = $_[5] + 1900 - int( $month / 10 ); + + ( ( 365 * $year ) + + int( $year / 4 ) + - int( $year / 100 ) + + int( $year / 400 ) + + int( ( ( $month * 306 ) + 5 ) / 10 ) ) - $Epoc; + } + ); +} + +sub _timegm { + my $sec + = $SecOff + $_[0] + + ( SECS_PER_MINUTE * $_[1] ) + + ( SECS_PER_HOUR * $_[2] ); + + return $sec + ( SECS_PER_DAY * &_daygm ); +} + +sub timegm { + my ( $sec, $min, $hour, $mday, $month, $year ) = @_; + + if ( $year >= 1000 ) { + $year -= 1900; + } + elsif ( $year < 100 and $year >= 0 ) { + $year += ( $year > $Breakpoint ) ? $Century : $NextCentury; + } + + unless ( $Options{no_range_check} ) { + Carp::croak("Month '$month' out of range 0..11") + if $month > 11 + or $month < 0; + + my $md = $MonthDays[$month]; + ++$md + if $month == 1 && _is_leap_year( $year + 1900 ); + + Carp::croak("Day '$mday' out of range 1..$md") + if $mday > $md or $mday < 1; + Carp::croak("Hour '$hour' out of range 0..23") + if $hour > 23 or $hour < 0; + Carp::croak("Minute '$min' out of range 0..59") + if $min > 59 or $min < 0; + Carp::croak("Second '$sec' out of range 0..59") + if $sec >= 60 or $sec < 0; + } + + my $days = _daygm( undef, undef, undef, $mday, $month, $year ); + + unless ( $Options{no_range_check} or abs($days) < $MaxDay ) { + my $msg = q{}; + $msg .= "Day too big - $days > $MaxDay\n" if $days > $MaxDay; + + $year += 1900; + $msg + .= "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)"; + + Carp::croak($msg); + } + + return + $sec + $SecOff + + ( SECS_PER_MINUTE * $min ) + + ( SECS_PER_HOUR * $hour ) + + ( SECS_PER_DAY * $days ); +} + +sub _is_leap_year { + return 0 if $_[0] % 4; + return 1 if $_[0] % 100; + return 0 if $_[0] % 400; + + return 1; +} + +sub timegm_nocheck { + local $Options{no_range_check} = 1; + return &timegm; +} + +sub timelocal { + my $ref_t = &timegm; + my $loc_for_ref_t = _timegm( localtime($ref_t) ); + + my $zone_off = $loc_for_ref_t - $ref_t + or return $loc_for_ref_t; + + # Adjust for timezone + my $loc_t = $ref_t - $zone_off; + + # Are we close to a DST change or are we done + my $dst_off = $ref_t - _timegm( localtime($loc_t) ); + + # If this evaluates to true, it means that the value in $loc_t is + # the _second_ hour after a DST change where the local time moves + # backward. + if ( + !$dst_off + && ( ( $ref_t - SECS_PER_HOUR ) + - _timegm( localtime( $loc_t - SECS_PER_HOUR ) ) < 0 ) + ) { + return $loc_t - SECS_PER_HOUR; + } + + # Adjust for DST change + $loc_t += $dst_off; + + return $loc_t if $dst_off > 0; + + # If the original date was a non-extent gap in a forward DST jump, + # we should now have the wrong answer - undo the DST adjustment + my ( $s, $m, $h ) = localtime($loc_t); + $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2]; + + return $loc_t; +} + +sub timelocal_nocheck { + local $Options{no_range_check} = 1; + return &timelocal; +} + +1; + +# ABSTRACT: Efficiently compute time from local and GMT time + +__END__ + +package Time::tm; +use strict; + +our $VERSION = '1.00'; + +use Class::Struct qw(struct); +struct('Time::tm' => [ + map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } +]); + +1; +__END__ + +use strict; +use warnings; + +package Perl::OSType; +# ABSTRACT: Map Perl operating system names to generic types + +our $VERSION = '1.010'; + +require Exporter; +our @ISA = qw(Exporter); + +our %EXPORT_TAGS = ( all => [qw( os_type is_os_type )] ); + +our @EXPORT_OK = @{ $EXPORT_TAGS{all} }; + +# originally taken from Module::Build by Ken Williams et al. +my %OSTYPES = qw( + aix Unix + bsdos Unix + beos Unix + bitrig Unix + dgux Unix + dragonfly Unix + dynixptx Unix + freebsd Unix + linux Unix + haiku Unix + hpux Unix + iphoneos Unix + irix Unix + darwin Unix + machten Unix + midnightbsd Unix + minix Unix + mirbsd Unix + next Unix + openbsd Unix + netbsd Unix + dec_osf Unix + nto Unix + svr4 Unix + svr5 Unix + sco Unix + sco_sv Unix + unicos Unix + unicosmk Unix + solaris Unix + sunos Unix + cygwin Unix + msys Unix + os2 Unix + interix Unix + gnu Unix + gnukfreebsd Unix + nto Unix + qnx Unix + android Unix + + dos Windows + MSWin32 Windows + + os390 EBCDIC + os400 EBCDIC + posix-bc EBCDIC + vmesa EBCDIC + + MacOS MacOS + VMS VMS + vos VOS + riscos RiscOS + amigaos Amiga + mpeix MPEiX +); + +sub os_type { + my ($os) = @_; + $os = $^O unless defined $os; + return $OSTYPES{$os} || q{}; +} + +sub is_os_type { + my ( $type, $os ) = @_; + return unless $type; + $os = $^O unless defined $os; + return os_type($os) eq $type; +} + +1; + + +__END__ + + +# vim: ts=4 sts=4 sw=4 et: +package User::grent; +use strict; + +use 5.006_001; +our $VERSION = '1.02'; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ($gr_name, $gr_gid, $gr_passwd, $gr_mem, @gr_members); +BEGIN { + use Exporter (); + @EXPORT = qw(getgrent getgrgid getgrnam getgr); + @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'User::grent' => [ + name => '$', + passwd => '$', + gid => '$', + members => '@', +]; + +sub populate (@) { + return unless @_; + my $gob = new(); + ($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2]; + @gr_members = @{$gob->[3]} = split ' ', $_[3]; + return $gob; +} + +sub getgrent ( ) { populate(CORE::getgrent()) } +sub getgrnam ($) { populate(CORE::getgrnam(shift)) } +sub getgrgid ($) { populate(CORE::getgrgid(shift)) } +sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam } + +1; +__END__ + +package User::pwent; + +use 5.006; +our $VERSION = '1.01'; + +use strict; +use warnings; + +use Config; +use Carp; + +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); +our ( $pw_name, $pw_passwd, $pw_uid, $pw_gid, + $pw_gecos, $pw_dir, $pw_shell, + $pw_expire, $pw_change, $pw_class, + $pw_age, + $pw_quota, $pw_comment, + ); +BEGIN { + use Exporter (); + @EXPORT = qw(getpwent getpwuid getpwnam getpw); + @EXPORT_OK = qw( + pw_has + + $pw_name $pw_passwd $pw_uid $pw_gid + $pw_gecos $pw_dir $pw_shell + $pw_expire $pw_change $pw_class + $pw_age + $pw_quota $pw_comment + ); + %EXPORT_TAGS = ( + FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ], + ALL => [ @EXPORT, @EXPORT_OK ], + ); +} + +# +# XXX: these mean somebody hacked this module's source +# without understanding the underlying assumptions. +# +my $IE = "[INTERNAL ERROR]"; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'User::pwent' => [ + name => '$', # pwent[0] + passwd => '$', # pwent[1] + uid => '$', # pwent[2] + gid => '$', # pwent[3] + + # you'll only have one/none of these three + change => '$', # pwent[4] + age => '$', # pwent[4] + quota => '$', # pwent[4] + + # you'll only have one/none of these two + comment => '$', # pwent[5] + class => '$', # pwent[5] + + # you might not have this one + gecos => '$', # pwent[6] + + dir => '$', # pwent[7] + shell => '$', # pwent[8] + + # you might not have this one + expire => '$', # pwent[9] + +]; + + +# init our groks hash to be true if the built platform knew how +# to do each struct pwd field that perl can ever under any circumstances +# know about. we do not use /^pw_?/, but just the tails. +sub _feature_init { + our %Groks; # whether build system knew how to do this feature + for my $feep ( qw{ + pwage pwchange pwclass pwcomment + pwexpire pwgecos pwpasswd pwquota + } + ) + { + my $short = $feep =~ /^pw(.*)/ + ? $1 + : do { + # not cluck, as we know we called ourselves, + # and a confession is probably imminent anyway + warn("$IE $feep is a funny struct pwd field"); + $feep; + }; + + exists $Config{ "d_" . $feep } + || confess("$IE Configure doesn't d_$feep"); + $Groks{$short} = defined $Config{ "d_" . $feep }; + } + # assume that any that are left are always there + for my $feep (grep /^\$pw_/s, @EXPORT_OK) { + $feep =~ /^\$pw_(.*)/; + $Groks{$1} = 1 unless defined $Groks{$1}; + } +} + +# With arguments, reports whether one or more fields are all implemented +# in the build machine's struct pwd pw_*. May be whitespace separated. +# We do not use /^pw_?/, just the tails. +# +# Without arguments, returns the list of fields implemented on build +# machine, space separated in scalar context. +# +# Takes exception to being asked whether this machine's struct pwd has +# a field that Perl never knows how to provide under any circumstances. +# If the module does this idiocy to itself, the explosion is noisier. +# +sub pw_has { + our %Groks; # whether build system knew how to do this feature + my $cando = 1; + my $sploder = caller() ne __PACKAGE__ + ? \&croak + : sub { confess("$IE @_") }; + if (@_ == 0) { + my @valid = sort grep { $Groks{$_} } keys %Groks; + return wantarray ? @valid : "@valid"; + } + for my $feep (map { split } @_) { + defined $Groks{$feep} + || $sploder->("$feep is never a valid struct pwd field"); + $cando &&= $Groks{$feep}; + } + return $cando; +} + +sub _populate (@) { + return unless @_; + my $pwob = new(); + + # Any that haven't been pw_had are assumed on "all" platforms of + # course, this may not be so, but you can't get here otherwise, + # since the underlying core call already took exception to your + # impudence. + + $pw_name = $pwob->name ( $_[0] ); + $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd"); + $pw_uid = $pwob->uid ( $_[2] ); + $pw_gid = $pwob->gid ( $_[3] ); + + if (pw_has("change")) { + $pw_change = $pwob->change ( $_[4] ); + } + elsif (pw_has("age")) { + $pw_age = $pwob->age ( $_[4] ); + } + elsif (pw_has("quota")) { + $pw_quota = $pwob->quota ( $_[4] ); + } + + if (pw_has("class")) { + $pw_class = $pwob->class ( $_[5] ); + } + elsif (pw_has("comment")) { + $pw_comment = $pwob->comment( $_[5] ); + } + + $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos"); + + $pw_dir = $pwob->dir ( $_[7] ); + $pw_shell = $pwob->shell ( $_[8] ); + + $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire"); + + return $pwob; +} + +sub getpwent ( ) { _populate(CORE::getpwent()) } +sub getpwnam ($) { _populate(CORE::getpwnam(shift)) } +sub getpwuid ($) { _populate(CORE::getpwuid(shift)) } +sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam } + +_feature_init(); + +1; +__END__ + +package Attribute::Handlers; +use 5.006; +use Carp; +use warnings; +use strict; +our $AUTOLOAD; +our $VERSION = '1.01'; # remember to update version in POD! +# $DB::single=1; + +my %symcache; +sub findsym { + my ($pkg, $ref, $type) = @_; + return $symcache{$pkg,$ref} if $symcache{$pkg,$ref}; + $type ||= ref($ref); + no strict 'refs'; + my $symtab = \%{$pkg."::"}; + for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) { + if (ref $sym && $sym == $ref) { + return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"}; + } + use strict; + next unless ref ( \$sym ) eq 'GLOB'; + return $symcache{$pkg,$ref} = \$sym + if *{$sym}{$type} && *{$sym}{$type} == $ref; + }} +} + +my %validtype = ( + VAR => [qw[SCALAR ARRAY HASH]], + ANY => [qw[SCALAR ARRAY HASH CODE]], + "" => [qw[SCALAR ARRAY HASH CODE]], + SCALAR => [qw[SCALAR]], + ARRAY => [qw[ARRAY]], + HASH => [qw[HASH]], + CODE => [qw[CODE]], +); +my %lastattr; +my @declarations; +my %raw; +my %phase; +my %sigil = (SCALAR=>'$', ARRAY=>'@', HASH=>'%'); +my $global_phase = 0; +my %global_phases = ( + BEGIN => 0, + CHECK => 1, + INIT => 2, + END => 3, +); +my @global_phases = qw(BEGIN CHECK INIT END); + +sub _usage_AH_ { + croak "Usage: use $_[0] autotie => {AttrName => TieClassName,...}"; +} + +my $qual_id = qr/^[_a-z]\w*(::[_a-z]\w*)*$/i; + +sub import { + my $class = shift @_; + return unless $class eq "Attribute::Handlers"; + while (@_) { + my $cmd = shift; + if ($cmd =~ /^autotie((?:ref)?)$/) { + my $tiedata = ($1 ? '$ref, ' : '') . '@$data'; + my $mapping = shift; + _usage_AH_ $class unless ref($mapping) eq 'HASH'; + while (my($attr, $tieclass) = each %$mapping) { + $tieclass =~ s/^([_a-z]\w*(::[_a-z]\w*)*)(.*)/$1/is; + my $args = $3||'()'; + _usage_AH_ $class unless $attr =~ $qual_id + && $tieclass =~ $qual_id + && eval "use base q\0$tieclass\0; 1"; + if ($tieclass->isa('Exporter')) { + local $Exporter::ExportLevel = 2; + $tieclass->import(eval $args); + } + $attr =~ s/__CALLER__/caller(1)/e; + $attr = caller()."::".$attr unless $attr =~ /::/; + eval qq{ + sub $attr : ATTR(VAR) { + my (\$ref, \$data) = \@_[2,4]; + my \$was_arrayref = ref \$data eq 'ARRAY'; + \$data = [ \$data ] unless \$was_arrayref; + my \$type = ref(\$ref)||"value (".(\$ref||"").")"; + (\$type eq 'SCALAR')? tie \$\$ref,'$tieclass',$tiedata + :(\$type eq 'ARRAY') ? tie \@\$ref,'$tieclass',$tiedata + :(\$type eq 'HASH') ? tie \%\$ref,'$tieclass',$tiedata + : die "Can't autotie a \$type\n" + } 1 + } or die "Internal error: $@"; + } + } + else { + croak "Can't understand $_"; + } + } +} + +# On older perls, code attribute handlers run before the sub gets placed +# in its package. Since the :ATTR handlers need to know the name of the +# sub they're applied to, the name lookup (via findsym) needs to be +# delayed: we do it immediately before we might need to find attribute +# handlers from their name. However, on newer perls (which fix some +# problems relating to attribute application), a sub gets placed in its +# package before its attributes are processed. In this case, the +# delayed name lookup might be too late, because the sub we're looking +# for might have already been replaced. So we need to detect which way +# round this perl does things, and time the name lookup accordingly. +BEGIN { + my $delayed; + sub Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES { + $delayed = \&Attribute::Handlers::_TEST_::t != $_[1]; + return (); + } + sub Attribute::Handlers::_TEST_::t :T { } + *_delayed_name_resolution = sub() { $delayed }; + undef &Attribute::Handlers::_TEST_::MODIFY_CODE_ATTRIBUTES; + undef &Attribute::Handlers::_TEST_::t; +} + +sub _resolve_lastattr { + return unless $lastattr{ref}; + my $sym = findsym @lastattr{'pkg','ref'} + or die "Internal error: $lastattr{pkg} symbol went missing"; + my $name = *{$sym}{NAME}; + warn "Declaration of $name attribute in package $lastattr{pkg} may clash with future reserved word\n" + if $^W and $name !~ /[A-Z]/; + foreach ( @{$validtype{$lastattr{type}}} ) { + no strict 'refs'; + *{"$lastattr{pkg}::_ATTR_${_}_${name}"} = $lastattr{ref}; + } + %lastattr = (); +} + +sub AUTOLOAD { + return if $AUTOLOAD =~ /::DESTROY$/; + my ($class) = $AUTOLOAD =~ m/(.*)::/g; + $AUTOLOAD =~ m/_ATTR_(.*?)_(.*)/ or + croak "Can't locate class method '$AUTOLOAD' via package '$class'"; + croak "Attribute handler '$2' doesn't handle $1 attributes"; +} + +my $builtin = $] ge '5.027000' + ? qr/lvalue|method|shared/ + : qr/lvalue|method|locked|shared|unique/; + +sub _gen_handler_AH_() { + return sub { + _resolve_lastattr if _delayed_name_resolution; + my ($pkg, $ref, @attrs) = @_; + my (undef, $filename, $linenum) = caller 2; + foreach (@attrs) { + my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next; + if ($attr eq 'ATTR') { + no strict 'refs'; + $data ||= "ANY"; + $raw{$ref} = $data =~ s/\s*,?\s*RAWDATA\s*,?\s*//; + $phase{$ref}{BEGIN} = 1 + if $data =~ s/\s*,?\s*(BEGIN)\s*,?\s*//; + $phase{$ref}{INIT} = 1 + if $data =~ s/\s*,?\s*(INIT)\s*,?\s*//; + $phase{$ref}{END} = 1 + if $data =~ s/\s*,?\s*(END)\s*,?\s*//; + $phase{$ref}{CHECK} = 1 + if $data =~ s/\s*,?\s*(CHECK)\s*,?\s*// + || ! keys %{$phase{$ref}}; + # Added for cleanup to not pollute next call. + (%lastattr = ()), + croak "Can't have two ATTR specifiers on one subroutine" + if keys %lastattr; + croak "Bad attribute type: ATTR($data)" + unless $validtype{$data}; + %lastattr=(pkg=>$pkg,ref=>$ref,type=>$data); + _resolve_lastattr unless _delayed_name_resolution; + } + else { + my $type = ref $ref; + my $handler = $pkg->can("_ATTR_${type}_${attr}"); + next unless $handler; + my $decl = [$pkg, $ref, $attr, $data, + $raw{$handler}, $phase{$handler}, $filename, $linenum]; + foreach my $gphase (@global_phases) { + _apply_handler_AH_($decl,$gphase) + if $global_phases{$gphase} <= $global_phase; + } + if ($global_phase != 0) { + # if _gen_handler_AH_ is being called after + # CHECK it's for a lexical, so make sure + # it didn't want to run anything later + + local $Carp::CarpLevel = 2; + carp "Won't be able to apply END handler" + if $phase{$handler}{END}; + } + else { + push @declarations, $decl + } + } + $_ = undef; + } + return grep {defined && !/$builtin/} @attrs; + } +} + +{ + no strict 'refs'; + *{"Attribute::Handlers::UNIVERSAL::MODIFY_${_}_ATTRIBUTES"} = + _gen_handler_AH_ foreach @{$validtype{ANY}}; +} +push @UNIVERSAL::ISA, 'Attribute::Handlers::UNIVERSAL' + unless grep /^Attribute::Handlers::UNIVERSAL$/, @UNIVERSAL::ISA; + +sub _apply_handler_AH_ { + my ($declaration, $phase) = @_; + my ($pkg, $ref, $attr, $data, $raw, $handlerphase, $filename, $linenum) = @$declaration; + return unless $handlerphase->{$phase}; + # print STDERR "Handling $attr on $ref in $phase with [$data]\n"; + my $type = ref $ref; + my $handler = "_ATTR_${type}_${attr}"; + my $sym = findsym($pkg, $ref); + $sym ||= $type eq 'CODE' ? 'ANON' : 'LEXICAL'; + no warnings; + if (!$raw && defined($data)) { + if ($data ne '') { + my $evaled = eval("package $pkg; no warnings; no strict; + local \$SIG{__WARN__}=sub{die}; [$data]"); + $data = $evaled unless $@; + } + else { $data = undef } + } + $pkg->$handler($sym, + (ref $sym eq 'GLOB' ? *{$sym}{ref $ref}||$ref : $ref), + $attr, + $data, + $phase, + $filename, + $linenum, + ); + return 1; +} + +{ + no warnings 'void'; + CHECK { + $global_phase++; + _resolve_lastattr if _delayed_name_resolution; + foreach my $decl (@declarations) { + _apply_handler_AH_($decl, 'CHECK'); + } + } + + INIT { + $global_phase++; + foreach my $decl (@declarations) { + _apply_handler_AH_($decl, 'INIT'); + } + } +} + +END { + $global_phase++; + foreach my $decl (@declarations) { + _apply_handler_AH_($decl, 'END'); + } +} + +1; +__END__ + +Encode::$_Name_ version 0.1 +======== + +NAME + Encode::$_Name_ - + +SYNOPSIS + use Encode::$_Name_; + # +ABSTRACT + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires perl version 5.7.3 or later. + +COPYRIGHT AND LICENCE + +Copyright (C) 2002 Your Name + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +# +# This file is auto-generated by: +# enc2xs version $_Version_ +# $_Now_ +# +use 5.7.2; +use strict; +use ExtUtils::MakeMaker; +use Config; + +# Please edit the following to the taste! +my $name = '$_Name_'; +my %tables = ( + $_Name__t => [ $_TableFiles_ ], + ); + +#### DO NOT EDIT BEYOND THIS POINT! +require File::Spec; +my ($enc2xs, $encode_h) = (); +my @path_ext = (''); +@path_ext = split(';', $ENV{PATHEXT}) if $^O eq 'MSWin32'; +PATHLOOP: +for my $d (@Config{qw/bin sitebin vendorbin/}, + (split /$Config{path_sep}/o, $ENV{PATH})){ + for my $f (qw/enc2xs enc2xs5.7.3/){ + my $path = File::Spec->catfile($d, $f); + for my $ext (@path_ext) { + my $bin = "$path$ext"; + -r "$bin" and $enc2xs = $bin and last PATHLOOP; + } + } +} +$enc2xs or die "enc2xs not found!"; +print "enc2xs is $enc2xs\n"; +my %encode_h = (); +for my $d (@INC){ + my $dir = File::Spec->catfile($d, "Encode"); + my $file = File::Spec->catfile($dir, "encode.h"); + -f $file and $encode_h{$dir} = -M $file; +} +%encode_h or die "encode.h not found!"; +# find the latest one +($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h; +print "encode.h is at $encode_h\n"; + +WriteMakefile( + INC => "-I$encode_h", +#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! #### + NAME => 'Encode::'.$name, + VERSION_FROM => "$name.pm", + OBJECT => '$(O_FILES)', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, + PREREQ_PM => { + 'Encode' => "1.41", + }, + # OS 390 winges about line numbers > 64K ??? + XSOPT => '-nolinenumbers', + ); + +package MY; + +sub post_initialize +{ + my ($self) = @_; + my %o; + my $x = $self->{'OBJ_EXT'}; + # Add the table O_FILES + foreach my $e (keys %tables) + { + $o{$e.$x} = 1; + } + $o{"$name$x"} = 1; + $self->{'O_FILES'} = [sort keys %o]; + my @files = ("$name.xs"); + $self->{'C'} = ["$name.c"]; + # The next two lines to make MacPerl Happy -- dankogai via pudge + $self->{SOURCE} .= " $name.c" + if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/; + # $self->{'H'} = [$self->catfile($self->updir,'encode.h')]; + my %xs; + foreach my $table (sort keys %tables) { + push (@{$self->{'C'}},"$table.c"); + # Do NOT add $table.h etc. to H_FILES unless we own up as to how they + # get built. + foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) { + push (@files,$table.$ext); + } + } + $self->{'XS'} = { "$name.xs" => "$name.c" }; + $self->{'clean'}{'FILES'} .= join(' ',@files); + open(XS,">$name.xs") || die "Cannot open $name.xs:$!"; + print XS <<'END'; +#include +#include +#include +#include "encode.h" +END + foreach my $table (sort keys %tables) { + print XS qq[#include "${table}.h"\n]; + } + print XS <<"END"; + +static void +Encode_XSEncoding(pTHX_ encode_t *enc) +{ + dSP; + HV *stash = gv_stashpv("Encode::XS", TRUE); + SV *iv = newSViv(PTR2IV(enc)); + SV *sv = sv_bless(newRV_noinc(iv),stash); + int i = 0; + /* with the SvLEN() == 0 hack, PVX won't be freed. We cast away name's + constness, in the hope that perl won't mess with it. */ + assert(SvTYPE(iv) >= SVt_PV); assert(SvLEN(iv) == 0); + SvFLAGS(iv) |= SVp_POK; + SvPVX(iv) = (char*) enc->name[0]; + PUSHMARK(sp); + XPUSHs(sv); + while (enc->name[i]) + { + const char *name = enc->name[i++]; + XPUSHs(sv_2mortal(newSVpvn(name,strlen(name)))); + } + PUTBACK; + call_pv("Encode::define_encoding",G_DISCARD); + SvREFCNT_dec(sv); +} + +MODULE = Encode::$name PACKAGE = Encode::$name +PROTOTYPES: DISABLE +BOOT: +{ +END + foreach my $table (sort keys %tables) { + print XS qq[#include "${table}.exh"\n]; + } + print XS "}\n"; + close(XS); + return "# Built $name.xs\n\n"; +} + +sub postamble +{ + my $self = shift; + my $dir = "."; # $self->catdir('Encode'); + my $str = "# $name\$(OBJ_EXT) depends on .h and .exh files not .c files - but all written by enc2xs\n"; + $str .= "$name.c : $name.xs "; + foreach my $table (sort keys %tables) + { + $str .= " $table.c"; + } + $str .= "\n\n"; + $str .= "$name\$(OBJ_EXT) : $name.c\n\n"; + + foreach my $table (sort keys %tables) + { + my $numlines = 1; + my $lengthsofar = length($str); + my $continuator = ''; + $str .= "$table.c : Makefile.PL"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= " \\\n\t"; + $numlines++; + } else { + $continuator = ''; + } + } + my $plib = $self->{PERL_CORE} ? '"-I$(PERL_LIB)"' : ''; + my $ucopts = '-"Q"'; + $str .= + qq{\n\t\$(PERL) $plib $enc2xs $ucopts -o \$\@ -f $table.fnm\n\n}; + open (FILELIST, ">$table.fnm") + || die "Could not open $table.fnm: $!"; + foreach my $file (@{$tables{$table}}) + { + print FILELIST $self->catfile($dir,$file) . "\n"; + } + close(FILELIST); + } + return $str; +} + +# +# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $ +# Revision history for Perl extension Encode::$_Name_. +# + +0.01 $_Now_ + Autogenerated by enc2xs version $_Version_. +# +# Local demand-load module list +# +# You should not edit this file by hand! use "enc2xs -C" +# +package Encode::ConfigLocal; +our $VERSION = $_LocalVer_; + +use strict; + +$_ModLines_ + +1; +package Encode::$_Name_; +our $VERSION = "0.01"; + +use Encode; +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::$_Name_ - New Encoding + +=head1 SYNOPSIS + +You got to fill this in! + +=head1 SEE ALSO + +L + +=cut +use strict; +# Adjust the number here! +use Test::More tests => 2; + +BEGIN { + use_ok('Encode'); + use_ok('Encode::$_Name_'); +} +# Add more test here! +use 5.008001; +use strict; +use warnings; +package Parse::CPAN::Meta; +# ABSTRACT: Parse META.yml and META.json CPAN metadata files + +our $VERSION = '2.150010'; + +use Exporter; +use Carp 'croak'; + +our @ISA = qw/Exporter/; +our @EXPORT_OK = qw/Load LoadFile/; + +sub load_file { + my ($class, $filename) = @_; + + my $meta = _slurp($filename); + + if ($filename =~ /\.ya?ml$/) { + return $class->load_yaml_string($meta); + } + elsif ($filename =~ /\.json$/) { + return $class->load_json_string($meta); + } + else { + $class->load_string($meta); # try to detect yaml/json + } +} + +sub load_string { + my ($class, $string) = @_; + if ( $string =~ /^---/ ) { # looks like YAML + return $class->load_yaml_string($string); + } + elsif ( $string =~ /^\s*\{/ ) { # looks like JSON + return $class->load_json_string($string); + } + else { # maybe doc-marker-free YAML + return $class->load_yaml_string($string); + } +} + +sub load_yaml_string { + my ($class, $string) = @_; + my $backend = $class->yaml_backend(); + my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; + croak $@ if $@; + return $data || {}; # in case document was valid but empty +} + +sub load_json_string { + my ($class, $string) = @_; + require Encode; + # load_json_string takes characters, decode_json expects bytes + my $encoded = Encode::encode('UTF-8', $string, Encode::PERLQQ()); + my $data = eval { $class->json_decoder()->can('decode_json')->($encoded) }; + croak $@ if $@; + return $data || {}; +} + +sub yaml_backend { + if ($ENV{PERL_CORE} or not defined $ENV{PERL_YAML_BACKEND} ) { + _can_load( 'CPAN::Meta::YAML', 0.011 ) + or croak "CPAN::Meta::YAML 0.011 is not available\n"; + return "CPAN::Meta::YAML"; + } + else { + my $backend = $ENV{PERL_YAML_BACKEND}; + _can_load( $backend ) + or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; + $backend->can("Load") + or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; + return $backend; + } +} + +sub json_decoder { + if ($ENV{PERL_CORE}) { + _can_load( 'JSON::PP' => 2.27300 ) + or croak "JSON::PP 2.27300 is not available\n"; + return 'JSON::PP'; + } + if (my $decoder = $ENV{CPAN_META_JSON_DECODER}) { + _can_load( $decoder ) + or croak "Could not load CPAN_META_JSON_DECODER '$decoder'\n"; + $decoder->can('decode_json') + or croak "No decode_json sub provided by CPAN_META_JSON_DECODER '$decoder'\n"; + return $decoder; + } + return $_[0]->json_backend; +} + +sub json_backend { + if ($ENV{PERL_CORE}) { + _can_load( 'JSON::PP' => 2.27300 ) + or croak "JSON::PP 2.27300 is not available\n"; + return 'JSON::PP'; + } + if (my $backend = $ENV{CPAN_META_JSON_BACKEND}) { + _can_load( $backend ) + or croak "Could not load CPAN_META_JSON_BACKEND '$backend'\n"; + $backend->can('new') + or croak "No constructor provided by CPAN_META_JSON_BACKEND '$backend'\n"; + return $backend; + } + if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { + _can_load( 'JSON::PP' => 2.27300 ) + or croak "JSON::PP 2.27300 is not available\n"; + return 'JSON::PP'; + } + else { + _can_load( 'JSON' => 2.5 ) + or croak "JSON 2.5 is required for " . + "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; + return "JSON"; + } +} + +sub _slurp { + require Encode; + open my $fh, "<:raw", "$_[0]" ## no critic + or die "can't open $_[0] for reading: $!"; + my $content = do { local $/; <$fh> }; + $content = Encode::decode('UTF-8', $content, Encode::PERLQQ()); + return $content; +} + +sub _can_load { + my ($module, $version) = @_; + (my $file = $module) =~ s{::}{/}g; + $file .= ".pm"; + return 1 if $INC{$file}; + return 0 if exists $INC{$file}; # prior load failed + eval { require $file; 1 } + or return 0; + if ( defined $version ) { + eval { $module->VERSION($version); 1 } + or return 0; + } + return 1; +} + +# Kept for backwards compatibility only +# Create an object from a file +sub LoadFile ($) { ## no critic + return Load(_slurp(shift)); +} + +# Parse a document from a string. +sub Load ($) { ## no critic + require CPAN::Meta::YAML; + my $object = eval { CPAN::Meta::YAML::Load(shift) }; + croak $@ if $@; + return $object; +} + +1; + +__END__ + +package Thread::Queue; + +use strict; +use warnings; + +our $VERSION = '3.12'; +$VERSION = eval $VERSION; + +use threads::shared 1.21; +use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr); + +# Carp errors from threads::shared calls should complain about caller +our @CARP_NOT = ("threads::shared"); + +# Create a new queue possibly pre-populated with items +sub new +{ + my $class = shift; + my @queue :shared = map { shared_clone($_) } @_; + my %self :shared = ( 'queue' => \@queue ); + return bless(\%self, $class); +} + +# Add items to the tail of a queue +sub enqueue +{ + my $self = shift; + lock(%$self); + + if ($$self{'ENDED'}) { + require Carp; + Carp::croak("'enqueue' method called on queue that has been 'end'ed"); + } + + # Block if queue size exceeds any specified limit + my $queue = $$self{'queue'}; + cond_wait(%$self) while ($$self{'LIMIT'} && (@$queue >= $$self{'LIMIT'})); + + # Add items to queue, and then signal other threads + push(@$queue, map { shared_clone($_) } @_) + and cond_signal(%$self); +} + +# Set or return the max. size for a queue +sub limit : lvalue +{ + my $self = shift; + lock(%$self); + $$self{'LIMIT'}; +} + +# Return a count of the number of items on a queue +sub pending +{ + my $self = shift; + lock(%$self); + return if ($$self{'ENDED'} && ! @{$$self{'queue'}}); + return scalar(@{$$self{'queue'}}); +} + +# Indicate that no more data will enter the queue +sub end +{ + my $self = shift; + lock(%$self); + # No more data is coming + $$self{'ENDED'} = 1; + + cond_signal(%$self); # Unblock possibly waiting threads +} + +# Return 1 or more items from the head of a queue, blocking if needed +sub dequeue +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Wait for requisite number of items + cond_wait(%$self) while ((@$queue < $count) && ! $$self{'ENDED'}); + + # If no longer blocking, try getting whatever is left on the queue + return $self->dequeue_nb($count) if ($$self{'ENDED'}); + + # Return single item + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } + + # Return multiple items + my @items; + push(@items, shift(@$queue)) for (1..$count); + cond_signal(%$self); # Unblock possibly waiting threads + return @items; +} + +# Return items from the head of a queue with no blocking +sub dequeue_nb +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Return single item + if ($count == 1) { + my $item = shift(@$queue); + cond_signal(%$self); # Unblock possibly waiting threads + return $item; + } + + # Return multiple items + my @items; + for (1..$count) { + last if (! @$queue); + push(@items, shift(@$queue)); + } + cond_signal(%$self); # Unblock possibly waiting threads + return @items; +} + +# Return items from the head of a queue, blocking if needed up to a timeout +sub dequeue_timed +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + # Timeout may be relative or absolute + my $timeout = @_ ? $self->_validate_timeout(shift) : -1; + # Convert to an absolute time for use with cond_timedwait() + if ($timeout < 32000000) { # More than one year + $timeout += time(); + } + + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Wait for requisite number of items, or until timeout + while ((@$queue < $count) && ! $$self{'ENDED'}) { + last if (! cond_timedwait(%$self, $timeout)); + } + + # Get whatever we need off the queue if available + return $self->dequeue_nb($count); +} + +# Return an item without removing it from a queue +sub peek +{ + my $self = shift; + lock(%$self); + my $index = @_ ? $self->_validate_index(shift) : 0; + return $$self{'queue'}[$index]; +} + +# Insert items anywhere into a queue +sub insert +{ + my $self = shift; + lock(%$self); + + if ($$self{'ENDED'}) { + require Carp; + Carp::croak("'insert' method called on queue that has been 'end'ed"); + } + + my $queue = $$self{'queue'}; + + my $index = $self->_validate_index(shift); + + return if (! @_); # Nothing to insert + + # Support negative indices + if ($index < 0) { + $index += @$queue; + if ($index < 0) { + $index = 0; + } + } + + # Dequeue items from $index onward + my @tmp; + while (@$queue > $index) { + unshift(@tmp, pop(@$queue)) + } + + # Add new items to the queue + push(@$queue, map { shared_clone($_) } @_); + + # Add previous items back onto the queue + push(@$queue, @tmp); + + cond_signal(%$self); # Unblock possibly waiting threads +} + +# Remove items from anywhere in a queue +sub extract +{ + my $self = shift; + lock(%$self); + my $queue = $$self{'queue'}; + + my $index = @_ ? $self->_validate_index(shift) : 0; + my $count = @_ ? $self->_validate_count(shift) : 1; + + # Support negative indices + if ($index < 0) { + $index += @$queue; + if ($index < 0) { + $count += $index; + return if ($count <= 0); # Beyond the head of the queue + return $self->dequeue_nb($count); # Extract from the head + } + } + + # Dequeue items from $index+$count onward + my @tmp; + while (@$queue > ($index+$count)) { + unshift(@tmp, pop(@$queue)) + } + + # Extract desired items + my @items; + unshift(@items, pop(@$queue)) while (@$queue > $index); + + # Add back any removed items + push(@$queue, @tmp); + + cond_signal(%$self); # Unblock possibly waiting threads + + # Return single item + return $items[0] if ($count == 1); + + # Return multiple items + return @items; +} + +### Internal Methods ### + +# Check value of the requested index +sub _validate_index +{ + my $self = shift; + my $index = shift; + + if (! defined($index) || + ! looks_like_number($index) || + (int($index) != $index)) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $index = 'undef' if (! defined($index)); + Carp::croak("Invalid 'index' argument ($index) to '$method' method"); + } + + return $index; +}; + +# Check value of the requested count +sub _validate_count +{ + my $self = shift; + my $count = shift; + + if (! defined($count) || + ! looks_like_number($count) || + (int($count) != $count) || + ($count < 1) || + ($$self{'LIMIT'} && $count > $$self{'LIMIT'})) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $count = 'undef' if (! defined($count)); + if ($$self{'LIMIT'} && $count > $$self{'LIMIT'}) { + Carp::croak("'count' argument ($count) to '$method' method exceeds queue size limit ($$self{'LIMIT'})"); + } else { + Carp::croak("Invalid 'count' argument ($count) to '$method' method"); + } + } + + return $count; +}; + +# Check value of the requested timeout +sub _validate_timeout +{ + my $self = shift; + my $timeout = shift; + + if (! defined($timeout) || + ! looks_like_number($timeout)) + { + require Carp; + my ($method) = (caller(1))[3]; + my $class_name = ref($self); + $method =~ s/$class_name\:://; + $timeout = 'undef' if (! defined($timeout)); + Carp::croak("Invalid 'timeout' argument ($timeout) to '$method' method"); + } + + return $timeout; +}; + +1; + +package Thread::Semaphore; + +use strict; +use warnings; + +our $VERSION = '2.13'; +$VERSION = eval $VERSION; + +use threads::shared; +use Scalar::Util 1.10 qw(looks_like_number); + +# Predeclarations for internal functions +my ($validate_arg); + +# Create a new semaphore optionally with specified count (count defaults to 1) +sub new { + my $class = shift; + + my $val :shared = 1; + if (@_) { + $val = shift; + if (! defined($val) || + ! looks_like_number($val) || + (int($val) != $val)) + { + require Carp; + $val = 'undef' if (! defined($val)); + Carp::croak("Semaphore initializer is not an integer: $val"); + } + } + + return bless(\$val, $class); +} + +# Decrement a semaphore's count (decrement amount defaults to 1) +sub down { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + cond_wait($$sema) until ($$sema >= $dec); + $$sema -= $dec; +} + +# Decrement a semaphore's count only if count >= decrement value +# (decrement amount defaults to 1) +sub down_nb { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + my $ok = ($$sema >= $dec); + $$sema -= $dec if $ok; + return $ok; +} + +# Decrement a semaphore's count even if the count goes below 0 +# (decrement amount defaults to 1) +sub down_force { + my $sema = shift; + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + $$sema -= $dec; +} + +# Decrement a semaphore's count with timeout +# (timeout in seconds; decrement amount defaults to 1) +sub down_timed { + my $sema = shift; + my $timeout = $validate_arg->(shift); + my $dec = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + my $abs = time() + $timeout; + until ($$sema >= $dec) { + return if !cond_timedwait($$sema, $abs); + } + $$sema -= $dec; + return 1; +} + +# Increment a semaphore's count (increment amount defaults to 1) +sub up { + my $sema = shift; + my $inc = @_ ? $validate_arg->(shift) : 1; + + lock($$sema); + ($$sema += $inc) > 0 and cond_broadcast($$sema); +} + +### Internal Functions ### + +# Validate method argument +$validate_arg = sub { + my $arg = shift; + + if (! defined($arg) || + ! looks_like_number($arg) || + (int($arg) != $arg) || + ($arg < 1)) + { + require Carp; + my ($method) = (caller(1))[3]; + $method =~ s/Thread::Semaphore:://; + $arg = 'undef' if (! defined($arg)); + Carp::croak("Argument to semaphore method '$method' is not a positive integer: $arg"); + } + + return $arg; +}; + +1; + +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk + +package Future::Utils; + +use strict; +use warnings; + +our $VERSION = '0.39'; + +use Exporter 'import'; +# Can't import the one from Exporter as it relies on package inheritance +sub export_to_level +{ + my $pkg = shift; local $Exporter::ExportLevel = 1 + shift; $pkg->import(@_); +} + +our @EXPORT_OK = qw( + call + call_with_escape + + repeat + try_repeat try_repeat_until_success + repeat_until_success + + fmap fmap_concat + fmap1 fmap_scalar + fmap0 fmap_void +); + +use Carp; +our @CARP_NOT = qw( Future ); + +use Future; + + + +sub call(&) +{ + my ( $code ) = @_; + return Future->call( $code ); +} + + +sub call_with_escape(&) +{ + my ( $code ) = @_; + + my $escape_f = Future->new; + + return Future->wait_any( + Future->call( $code, $escape_f ), + $escape_f, + ); +} + + +sub _repeat +{ + my ( $code, $return, $trialp, $cond, $sense, $is_try ) = @_; + + my $prev = $$trialp; + + while(1) { + my $trial = $$trialp ||= Future->call( $code, $prev ); + $prev = $trial; + + if( !$trial->is_ready ) { + # defer + $return ||= $trial->new; + $trial->on_ready( sub { + return if $$trialp->is_cancelled; + _repeat( $code, $return, $trialp, $cond, $sense, $is_try ); + }); + return $return; + } + + my $stop; + if( not eval { $stop = !$cond->( $trial ) ^ $sense; 1 } ) { + $return ||= $trial->new; + $return->fail( $@ ); + return $return; + } + + if( $stop ) { + # Return result + $return ||= $trial->new; + $trial->on_done( $return ); + $trial->on_fail( $return ); + return $return; + } + + if( !$is_try and $trial->failure ) { + carp "Using Future::Utils::repeat to retry a failure is deprecated; use try_repeat instead"; + } + + # redo + undef $$trialp; + } +} + +sub repeat(&@) +{ + my $code = shift; + my %args = @_; + + # This makes it easier to account for other conditions + defined($args{while}) + defined($args{until}) == 1 + or defined($args{foreach}) + or defined($args{generate}) + or croak "Expected one of 'while', 'until', 'foreach' or 'generate'"; + + if( $args{foreach} ) { + $args{generate} and croak "Cannot use both 'foreach' and 'generate'"; + + my $array = delete $args{foreach}; + $args{generate} = sub { + @$array ? shift @$array : (); + }; + } + + if( $args{generate} ) { + my $generator = delete $args{generate}; + my $otherwise = delete $args{otherwise}; + + # TODO: This is slightly messy as this lexical is captured by both + # blocks of code. Can we do better somehow? + my $done; + + my $orig_code = $code; + $code = sub { + my ( $last_trial_f ) = @_; + my $again = my ( $value ) = $generator->( $last_trial_f ); + + if( $again ) { + unshift @_, $value; goto &$orig_code; + } + + $done++; + if( $otherwise ) { + goto &$otherwise; + } + else { + return $last_trial_f || Future->done; + } + }; + + if( my $orig_while = delete $args{while} ) { + $args{while} = sub { + $orig_while->( $_[0] ) and !$done; + }; + } + elsif( my $orig_until = delete $args{until} ) { + $args{while} = sub { + !$orig_until->( $_[0] ) and !$done; + }; + } + else { + $args{while} = sub { !$done }; + } + } + + my $future = $args{return}; + + my $trial; + $args{while} and $future = _repeat( $code, $future, \$trial, $args{while}, 0, $args{try} ); + $args{until} and $future = _repeat( $code, $future, \$trial, $args{until}, 1, $args{try} ); + + $future->on_cancel( sub { $trial->cancel } ); + + return $future; +} + + +sub try_repeat(&@) +{ + # defeat prototype + &repeat( @_, try => 1 ); +} + + +sub try_repeat_until_success(&@) +{ + my $code = shift; + my %args = @_; + + # TODO: maybe merge while/until conditions one day... + defined($args{while}) or defined($args{until}) + and croak "Cannot pass 'while' or 'until' to try_repeat_until_success"; + + # defeat prototype + &try_repeat( $code, while => sub { shift->failure }, %args ); +} + +# Legacy name +*repeat_until_success = \&try_repeat_until_success; + + +# This function is invoked in two circumstances: +# a) to create an item Future in a slot, +# b) once a non-immediate item Future is complete, to check its results +# It can tell which circumstance by whether the slot itself is defined or not +sub _fmap_slot +{ + my ( $slots, undef, $code, $generator, $collect, $results, $return ) = @_; + + SLOT: while(1) { + # Capture args each call because we mutate them + my ( undef, $idx ) = my @args = @_; + + unless( $slots->[$idx] ) { + # No item Future yet (case a), so create one + my $item; + unless( ( $item ) = $generator->() ) { + # All out of items, so now just wait for the slots to be finished + undef $slots->[$idx]; + defined and return $return for @$slots; + + # All the slots are done + $return ||= Future->new; + + $return->done( @$results ); + return $return; + } + + my $f = $slots->[$idx] = Future->call( $code, local $_ = $item ); + + if( $collect eq "array" ) { + push @$results, my $r = []; + $f->on_done( sub { @$r = @_ }); + } + elsif( $collect eq "scalar" ) { + push @$results, undef; + my $r = \$results->[-1]; + $f->on_done( sub { $$r = $_[0] }); + } + } + + my $f = $slots->[$idx]; + + # Slot is non-immediate; arrange for us to be invoked again later when it's ready + if( !$f->is_ready ) { + $args[-1] = ( $return ||= $f->new ); + $f->on_done( sub { _fmap_slot( @args ) } ); + $f->on_fail( $return ); + + # Try looking for more that might be ready + my $i = $idx + 1; + while( $i != $idx ) { + $i++; + $i %= @$slots; + next if defined $slots->[$i]; + + $_[1] = $i; + redo SLOT; + } + return $return; + } + + # Either we've been invoked again (case b), or the immediate Future was + # already ready. + if( $f->failure ) { + $return ||= $f->new; + $return->fail( $f->failure ); + return $return; + } + + undef $slots->[$idx]; + # next + } +} + +sub _fmap +{ + my $code = shift; + my %args = @_; + + my $concurrent = $args{concurrent} || 1; + my @slots; + + my $results = []; + my $future = $args{return}; + + my $generator; + if( $generator = $args{generate} ) { + # OK + } + elsif( my $array = $args{foreach} ) { + $generator = sub { return unless @$array; shift @$array }; + } + else { + croak "Expected either 'generate' or 'foreach'"; + } + + # If any of these immediately fail, don't bother continuing + foreach my $idx ( 0 .. $concurrent-1 ) { + $future = _fmap_slot( \@slots, $idx, $code, $generator, $args{collect}, $results, $future ); + last if $future->is_ready; + } + + $future->on_fail( sub { + !defined $_ or $_->is_ready or $_->cancel for @slots; + }); + $future->on_cancel( sub { + !defined $_ or $_->is_ready or $_->cancel for @slots; + }); + + return $future; +} + + +sub fmap_concat(&@) +{ + my $code = shift; + my %args = @_; + + _fmap( $code, %args, collect => "array" )->then( sub { + return Future->done( map { @$_ } @_ ); + }); +} +*fmap = \&fmap_concat; + + +sub fmap_scalar(&@) +{ + my $code = shift; + my %args = @_; + + _fmap( $code, %args, collect => "scalar" ) +} +*fmap1 = \&fmap_scalar; + + +sub fmap_void(&@) +{ + my $code = shift; + my %args = @_; + + _fmap( $code, %args, collect => "void" ) +} +*fmap0 = \&fmap_void; + + +0x55AA; +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2016-2017 -- leonerd@leonerd.org.uk + +package Future::Mutex; + +use strict; +use warnings; + +our $VERSION = '0.39'; + +use Future; + + + + +sub new +{ + my $class = shift; + my %params = @_; + + return bless { + avail => $params{count} // 1, + queue => [], + }, $class; +} + + + +sub enter +{ + my $self = shift; + my ( $code ) = @_; + + my $down_f; + if( $self->{avail} ) { + $self->{avail}--; + $down_f = Future->done; + } + else { + push @{ $self->{queue} }, $down_f = Future->new; + } + + my $up = sub { + if( my $next_f = shift @{ $self->{queue} } ) { + $next_f->done; + } + else { + $self->{avail}++; + } + }; + + $down_f->then( $code )->on_ready( $up ); +} + + +sub available +{ + my $self = shift; + return $self->{avail}; +} + + +0x55AA; + +# Time-stamp: "2004-10-06 23:26:33 ADT" +# Sean M. Burke + +require 5.000; +package I18N::LangTags; +use strict; +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(); +our @EXPORT_OK = qw(is_language_tag same_language_tag + extract_language_tags super_languages + similarity_language_tag is_dialect_of + locale2language_tag alternate_language_tags + encode_language_tag panic_languages + implicate_supers + implicate_supers_strictly + ); +our %EXPORT_TAGS = ('ALL' => \@EXPORT_OK); + +our $VERSION = "0.43"; +our %Panic; + +sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function + + + +########################################################################### + + +sub is_language_tag { + + ## Changes in the language tagging standards may have to be reflected here. + + my($tag) = lc($_[0]); + + return 0 if $tag eq "i" or $tag eq "x"; + # Bad degenerate cases that the following + # regexp would erroneously let pass + + return $tag =~ + /^(?: # First subtag + [xi] | [a-z]{2,3} + ) + (?: # Subtags thereafter + - # separator + [a-z0-9]{1,8} # subtag + )* + $/xs ? 1 : 0; +} + +########################################################################### + + +sub extract_language_tags { + + ## Changes in the language tagging standards may have to be reflected here. + + my($text) = + $_[0] =~ m/(.+)/ # to make for an untainted result + ? $1 : '' + ; + + return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags + $text =~ + m/ + \b + (?: # First subtag + [iIxX] | [a-zA-Z]{2,3} + ) + (?: # Subtags thereafter + - # separator + [a-zA-Z0-9]{1,8} # subtag + )* + \b + /xsg + ); +} + +########################################################################### + + +sub same_language_tag { + my $el1 = &encode_language_tag($_[0]); + return 0 unless defined $el1; + # this avoids the problem of + # encode_language_tag($lang1) eq and encode_language_tag($lang2) + # being true if $lang1 and $lang2 are both undef + + return $el1 eq &encode_language_tag($_[1]) ? 1 : 0; +} + +########################################################################### + + +sub similarity_language_tag { + my $lang1 = &encode_language_tag($_[0]); + my $lang2 = &encode_language_tag($_[1]); + # And encode_language_tag takes care of the whole + # no-nyn==nn, i-hakka==zh-hakka, etc, things + + # NB: (i-sil-...)? (i-sgn-...)? + + return undef if !defined($lang1) and !defined($lang2); + return 0 if !defined($lang1) or !defined($lang2); + + my @l1_subtags = split('-', $lang1); + my @l2_subtags = split('-', $lang2); + my $similarity = 0; + + while(@l1_subtags and @l2_subtags) { + if(shift(@l1_subtags) eq shift(@l2_subtags)) { + ++$similarity; + } else { + last; + } + } + return $similarity; +} + +########################################################################### + + +sub is_dialect_of { + + my $lang1 = &encode_language_tag($_[0]); + my $lang2 = &encode_language_tag($_[1]); + + return undef if !defined($lang1) and !defined($lang2); + return 0 if !defined($lang1) or !defined($lang2); + + return 1 if $lang1 eq $lang2; + return 0 if length($lang1) < length($lang2); + + $lang1 .= '-'; + $lang2 .= '-'; + return + (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0; +} + +########################################################################### + + +sub super_languages { + my $lang1 = $_[0]; + return() unless defined($lang1) && &is_language_tag($lang1); + + # a hack for those annoying new (2001) tags: + $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards + $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards + $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way + # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark + + my @l1_subtags = split('-', $lang1); + + ## Changes in the language tagging standards may have to be reflected here. + + # NB: (i-sil-...)? + + my @supers = (); + foreach my $bit (@l1_subtags) { + push @supers, + scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit; + } + pop @supers if @supers; + shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s; + return reverse @supers; +} + +########################################################################### + + +sub locale2language_tag { + my $lang = + $_[0] =~ m/(.+)/ # to make for an untainted result + ? $1 : '' + ; + + return $lang if &is_language_tag($lang); # like "en" + + $lang =~ tr<_><->; # "en_US" -> en-US + $lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s; # "en_US.ISO8859-1" -> en-US + # it_IT.utf8@euro => it-IT + + return $lang if &is_language_tag($lang); + + return; +} + +########################################################################### + + +sub encode_language_tag { + # Only similarity_language_tag() is allowed to analyse encodings! + + ## Changes in the language tagging standards may have to be reflected here. + + my($tag) = $_[0] || return undef; + return undef unless &is_language_tag($tag); + + # For the moment, these legacy variances are few enough that + # we can just handle them here with regexps. + $tag =~ s/^iw\b/he/i; # Hebrew + $tag =~ s/^in\b/id/i; # Indonesian + $tag =~ s/^cre\b/cr/i; # Cree + $tag =~ s/^jw\b/jv/i; # Javanese + $tag =~ s/^[ix]-lux\b/lb/i; # Luxemburger + $tag =~ s/^[ix]-navajo\b/nv/i; # Navajo + $tag =~ s/^ji\b/yi/i; # Yiddish + # SMB 2003 -- Hm. There's a bunch of new XXX->YY variances now, + # but maybe they're all so obscure I can ignore them. "Obscure" + # meaning either that the language is obscure, and/or that the + # XXX form was extant so briefly that it's unlikely it was ever + # used. I hope. + # + # These go FROM the simplex to complex form, to get + # similarity-comparison right. And that's okay, since + # similarity_language_tag is the only thing that + # analyzes our output. + $tag =~ s/^[ix]-hakka\b/zh-hakka/i; # Hakka + $tag =~ s/^nb\b/no-bok/i; # BACKWARDS for Bokmal + $tag =~ s/^nn\b/no-nyn/i; # BACKWARDS for Nynorsk + + $tag =~ s/^[xiXI]-//s; + # Just lop off any leading "x/i-" + + return "~" . uc($tag); +} + +#-------------------------------------------------------------------------- + + +my %alt = qw( i x x i I X X I ); +sub alternate_language_tags { + my $tag = $_[0]; + return() unless &is_language_tag($tag); + + my @em; # push 'em real goood! + + # For the moment, these legacy variances are few enough that + # we can just handle them here with regexps. + + if( $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1"; + } elsif($tag =~ m/^zh-hakka\b(.*)/i) { push @em, "x-hakka$1", "i-hakka$1"; + + } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1"; + } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1"; + + } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1"; + } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1"; + + } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1"; + } elsif($tag =~ m/^lb\b(.*)/i) { push @em, "i-lux$1", "x-lux$1"; + + } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1"; + } elsif($tag =~ m/^nv\b(.*)/i) { push @em, "i-navajo$1", "x-navajo$1"; + + } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1"; + } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1"; + + } elsif($tag =~ m/^nb\b(.*)/i) { push @em, "no-bok$1"; + } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1"; + + } elsif($tag =~ m/^nn\b(.*)/i) { push @em, "no-nyn$1"; + } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1"; + } + + push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/; + return @em; +} + +########################################################################### + +{ + # Init %Panic... + + my @panic = ( # MUST all be lowercase! + # Only large ("national") languages make it in this list. + # If you, as a user, are so bizarre that the /only/ language + # you claim to accept is Galician, then no, we won't do you + # the favor of providing Catalan as a panic-fallback for + # you. Because if I start trying to add "little languages" in + # here, I'll just go crazy. + + # Scandinavian lgs. All based on opinion and hearsay. + 'sv' => [qw(nb no da nn)], + 'da' => [qw(nb no sv nn)], # I guess + [qw(no nn nb)], [qw(no nn nb sv da)], + 'is' => [qw(da sv no nb nn)], + 'fo' => [qw(da is no nb nn sv)], # I guess + + # I think this is about the extent of tolerable intelligibility + # among large modern Romance languages. + 'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French + 'ca' => [qw(es pt it fr)], + 'es' => [qw(ca it fr pt)], + 'it' => [qw(es fr ca pt)], + 'fr' => [qw(es it ca pt)], + + # Also assume that speakers of the main Indian languages prefer + # to read/hear Hindi over English + [qw( + as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur + )] => 'hi', + # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri, + # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya, + # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu. + 'hi' => [qw(bn pa as or)], + # I welcome finer data for the other Indian languages. + # E.g., what should Oriya's list be, besides just Hindi? + + # And the panic languages for English is, of course, nil! + + # My guesses at Slavic intelligibility: + ([qw(ru be uk)]) x 2, # Russian, Belarusian, Ukranian + ([qw(sr hr bs)]) x 2, # Serbian, Croatian, Bosnian + 'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak + + 'ms' => 'id', 'id' => 'ms', # Malay + Indonesian + + 'et' => 'fi', 'fi' => 'et', # Estonian + Finnish + + #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai + + ); + my($k,$v); + while(@panic) { + ($k,$v) = splice(@panic,0,2); + foreach my $k (ref($k) ? @$k : $k) { + foreach my $v (ref($v) ? @$v : $v) { + push @{$Panic{$k} ||= []}, $v unless $k eq $v; + } + } + } +} + + +sub panic_languages { + # When in panic or in doubt, run in circles, scream, and shout! + my(@out, %seen); + foreach my $t (@_) { + next unless $t; + next if $seen{$t}++; # so we don't return it or hit it again + # push @out, super_languages($t); # nah, keep that separate + push @out, @{ $Panic{lc $t} || next }; + } + return grep !$seen{$_}++, @out, 'en'; +} + +#--------------------------------------------------------------------------- +#--------------------------------------------------------------------------- + + +sub implicate_supers { + my @languages = grep is_language_tag($_), @_; + my %seen_encoded; + foreach my $lang (@languages) { + $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1 + } + + my(@output_languages); + foreach my $lang (@languages) { + push @output_languages, $lang; + foreach my $s ( I18N::LangTags::super_languages($lang) ) { + # Note that super_languages returns the longest first. + last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) }; + push @output_languages, $s; + } + } + return uniq( @output_languages ); + +} + +sub implicate_supers_strictly { + my @tags = grep is_language_tag($_), @_; + return uniq( @_, map super_languages($_), @_ ); +} + + + +########################################################################### +1; +__END__ + + +package I18N::Collate; + +use strict; +our $VERSION = '1.02'; + + +# I18N::Collate.pm +# +# Author: Jarkko Hietaniemi > +# Helsinki University of Technology, Finland +# +# Acks: Guy Decoux > understood +# overloading magic much deeper than I and told +# how to cut the size of this code by more than half. +# (my first version did overload all of lt gt eq le ge cmp) +# +# Purpose: compare 8-bit scalar data according to the current locale +# +# Requirements: Perl5 POSIX::setlocale() and POSIX::strxfrm() +# +# Exports: setlocale 1) +# collate_xfrm 2) +# +# Overloads: cmp # 3) +# +# Usage: use I18N::Collate; +# setlocale(LC_COLLATE, 'locale-of-your-choice'); # 4) +# $s1 = I18N::Collate->("scalar_data_1"); +# $s2 = I18N::Collate->("scalar_data_2"); +# +# now you can compare $s1 and $s2: $s1 le $s2 +# to extract the data itself, you need to deref: $$s1 +# +# Notes: +# 1) this uses POSIX::setlocale +# 2) the basic collation conversion is done by strxfrm() which +# terminates at NUL characters being a decent C routine. +# collate_xfrm handles embedded NUL characters gracefully. +# 3) due to cmp and overload magic, lt le eq ge gt work also +# 4) the available locales depend on your operating system; +# try whether "locale -a" shows them or man pages for +# "locale" or "nlsinfo" work or the more direct +# approach "ls /usr/lib/nls/loc" or "ls /usr/lib/nls". +# Not all the locales that your vendor supports +# are necessarily installed: please consult your +# operating system's documentation. +# The locale names are probably something like +# 'xx_XX.(ISO)?8859-N' or 'xx_XX.(ISO)?8859N', +# for example 'fr_CH.ISO8859-1' is the Swiss (CH) +# variant of French (fr), ISO Latin (8859) 1 (-1) +# which is the Western European character set. +# +# Updated: 19961005 +# +# --- + +use POSIX qw(strxfrm LC_COLLATE); +use warnings::register; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(collate_xfrm setlocale LC_COLLATE); +our @EXPORT_OK = qw(); + +use overload qw( +fallback 1 +cmp collate_cmp +); + +our($LOCALE, $C); + +our $please_use_I18N_Collate_even_if_deprecated = 0; +sub new { + my $new = $_[1]; + + if (warnings::enabled() && $] >= 5.003_06) { + unless ($please_use_I18N_Collate_even_if_deprecated) { + warnings::warn <<___EOD___; +*** + + WARNING: starting from the Perl version 5.003_06 + the I18N::Collate interface for comparing 8-bit scalar data + according to the current locale + + HAS BEEN DEPRECATED + + That is, please do not use it anymore for any new applications + and please migrate the old applications away from it because its + functionality was integrated into the Perl core language in the + release 5.003_06. + + See the perllocale manual page for further information. + +*** +___EOD___ + $please_use_I18N_Collate_even_if_deprecated++; + } + } + + bless \$new; +} + +sub setlocale { + my ($category, $locale) = @_[0,1]; + + POSIX::setlocale($category, $locale) if (defined $category); + # the current $LOCALE + $LOCALE = $locale || $ENV{'LC_COLLATE'} || $ENV{'LC_ALL'} || ''; +} + +sub C { + my $s = ${$_[0]}; + + $C->{$LOCALE}->{$s} = collate_xfrm($s) + unless (defined $C->{$LOCALE}->{$s}); # cache when met + + $C->{$LOCALE}->{$s}; +} + +sub collate_xfrm { + my $s = $_[0]; + my $x = ''; + + for (split(/(\000+)/, $s)) { + $x .= (/^\000/) ? $_ : strxfrm("$_\000"); + } + + $x; +} + +sub collate_cmp { + &C($_[0]) cmp &C($_[1]); +} + +# init $LOCALE + +&I18N::Collate::setlocale(); + +1; # keep require happy + +require 5; +package I18N::LangTags::List; +# Time-stamp: "2004-10-06 23:26:21 ADT" +use strict; +our (%Name, %Is_Disrec, $Debug); +our $VERSION = '0.40'; +# POD at the end. + +#---------------------------------------------------------------------- +{ +# read the table out of our own POD! + my $seeking = 1; + my $count = 0; + my($disrec,$tag,$name); + my $last_name = ''; + while() { + if($seeking) { + $seeking = 0 if m/=for woohah/; + } elsif( ($disrec, $tag, $name) = + m/(\[?)\{([-0-9a-zA-Z]+)\}(?:\s*:)?\s*([^\[\]]+)/ + ) { + $name =~ s/\s*[;\.]*\s*$//g; + next unless $name; + ++$count; + print "<$tag> <$name>\n" if $Debug; + $last_name = $Name{$tag} = $name; + $Is_Disrec{$tag} = 1 if $disrec; + } elsif (m/[Ff]ormerly \"([-a-z0-9]+)\"/) { + $Name{$1} = "$last_name (old tag)" if $last_name; + $Is_Disrec{$1} = 1; + } + } + die "No tags read??" unless $count; +} +#---------------------------------------------------------------------- + +sub name { + my $tag = lc($_[0] || return); + $tag =~ s/^\s+//s; + $tag =~ s/\s+$//s; + + my $alt; + if($tag =~ m/^x-(.+)/) { + $alt = "i-$1"; + } elsif($tag =~ m/^i-(.+)/) { + $alt = "x-$1"; + } else { + $alt = ''; + } + + my $subform = ''; + my $name = ''; + print "Input: {$tag}\n" if $Debug; + while(length $tag) { + last if $name = $Name{$tag}; + last if $name = $Name{$alt}; + if($tag =~ s/(-[a-z0-9]+)$//s) { + print "Shaving off: $1 leaving $tag\n" if $Debug; + $subform = "$1$subform"; + # and loop around again + + $alt =~ s/(-[a-z0-9]+)$//s && $Debug && print " alt -> $alt\n"; + } else { + # we're trying to pull a subform off a primary tag. TILT! + print "Aborting on: {$name}{$subform}\n" if $Debug; + last; + } + } + print "Output: {$name}{$subform}\n" if $Debug; + + return unless $name; # Failure + return $name unless $subform; # Exact match + $subform =~ s/^-//s; + $subform =~ s/-$//s; + return "$name (Subform \"$subform\")"; +} + +#-------------------------------------------------------------------------- + +sub is_decent { + my $tag = lc($_[0] || return 0); + #require I18N::LangTags; + + return 0 unless + $tag =~ + /^(?: # First subtag + [xi] | [a-z]{2,3} + ) + (?: # Subtags thereafter + - # separator + [a-z0-9]{1,8} # subtag + )* + $/xs; + + my @supers = (); + foreach my $bit (split('-', $tag)) { + push @supers, + scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit; + } + return 0 unless @supers; + shift @supers if $supers[0] =~ m<^(i|x|sgn)$>s; + return 0 unless @supers; + + foreach my $f ($tag, @supers) { + return 0 if $Is_Disrec{$f}; + return 2 if $Name{$f}; + # so that decent subforms of indecent tags are decent + } + return 2 if $Name{$tag}; # not only is it decent, it's known! + return 1; +} + +#-------------------------------------------------------------------------- +1; + +__DATA__ + + + +# To generate a list of just the two and three-letter codes: + +#!/usr/local/bin/perl -w + +require 5; # Time-stamp: "2001-03-13 21:53:39 MST" + # Sean M. Burke, sburke@cpan.org + # This program is for generating the language_codes.txt file +use strict; +use LWP::Simple; +use HTML::TreeBuilder 3.10; +my $root = HTML::TreeBuilder->new(); +my $url = 'http://lcweb.loc.gov/standards/iso639-2/bibcodes.html'; +$root->parse(get($url) || die "Can't get $url"); +$root->eof(); + +my @codes; + +foreach my $tr ($root->find_by_tag_name('tr')) { + my @f = map $_->as_text(), $tr->content_list(); + #print map("<$_> ", @f), "\n"; + next unless @f == 5; + pop @f; # nix the French name + next if $f[-1] eq 'Language Name (English)'; # it's a header line + my $xx = splice(@f, 2,1); # pull out the two-letter code + $f[-1] =~ s/^\s+//; + $f[-1] =~ s/\s+$//; + if($xx =~ m/[a-zA-Z]/) { # there's a two-letter code for it + push @codes, [ lc($f[-1]), "$xx\t$f[-1]\n" ]; + } else { # print the three-letter codes. + if($f[0] eq $f[1]) { + push @codes, [ lc($f[-1]), "$f[1]\t$f[2]\n" ]; + } else { # shouldn't happen + push @codes, [ lc($f[-1]), "@f !!!!!!!!!!\n" ]; + } + } +} + +print map $_->[1], sort {; $a->[0] cmp $b->[0] } @codes; +print "[ based on $url\n at ", scalar(localtime), "]\n", + "[Note: doesn't include IANA-registered codes.]\n"; +exit; +__END__ + + +# Time-stamp: "2004-06-20 21:47:55 ADT" + +require 5; +package I18N::LangTags::Detect; +use strict; + +our ( $MATCH_SUPERS, $USING_LANGUAGE_TAGS, + $USE_LITERALS, $MATCH_SUPERS_TIGHTLY); + +BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } + # define the constant 'DEBUG' at compile-time + +our $VERSION = "1.07"; +our @ISA = (); +use I18N::LangTags qw(alternate_language_tags locale2language_tag); + +sub _uniq { my %seen; return grep(!($seen{$_}++), @_); } +sub _normalize { + my(@languages) = + map lc($_), + grep $_, + map {; $_, alternate_language_tags($_) } @_; + return _uniq(@languages) if wantarray; + return $languages[0]; +} + +#--------------------------------------------------------------------------- +# The extent of our functional interface: + +sub detect () { return __PACKAGE__->ambient_langprefs; } + +#=========================================================================== + +sub ambient_langprefs { # always returns things untainted + my $base_class = $_[0]; + + return $base_class->http_accept_langs + if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI + # it's off in its own routine because it's complicated + + # Not running as a CGI: try to puzzle out from the environment + my @languages; + + foreach my $envname (qw( LANGUAGE LC_ALL LC_MESSAGES LANG )) { + next unless $ENV{$envname}; + DEBUG and print "Noting \$$envname: $ENV{$envname}\n"; + push @languages, + map locale2language_tag($_), + # if it's a lg tag, fine, pass thru (untainted) + # if it's a locale ID, try converting to a lg tag (untainted), + # otherwise nix it. + + split m/[,:]/, + $ENV{$envname} + ; + last; # first one wins + } + + if($ENV{'IGNORE_WIN32_LOCALE'}) { + # no-op + } elsif(&_try_use('Win32::Locale')) { + # If we have that module installed... + push @languages, Win32::Locale::get_language() || '' + if defined &Win32::Locale::get_language; + } + return _normalize @languages; +} + +#--------------------------------------------------------------------------- + +sub http_accept_langs { + # Deal with HTTP "Accept-Language:" stuff. Hassle. + # This code is more lenient than RFC 3282, which you must read. + # Hm. Should I just move this into I18N::LangTags at some point? + no integer; + + my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'}; + # (always ends up untainting) + + return() unless defined $in and length $in; + + $in =~ s/\([^\)]*\)//g; # nix just about any comment + + if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) { + # Very common case: just one language tag + return _normalize $1; + } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) { + # Common case these days: just "foo, bar, baz" + return _normalize( $in =~ m/([a-zA-Z][-a-zA-Z]+)/g ); + } + + # Else it's complicated... + + $in =~ s/\s+//g; # Yes, we can just do without the WS! + my @in = $in =~ m/([^,]+)/g; + my %pref; + + my $q; + foreach my $tag (@in) { + next unless $tag =~ + m/^([a-zA-Z][-a-zA-Z]+) + (?: + ;q= + ( + \d* # a bit too broad of a RE, but so what. + (?: + \.\d+ + )? + ) + )? + $ + /sx + ; + $q = (defined $2 and length $2) ? $2 : 1; + #print "$1 with q=$q\n"; + push @{ $pref{$q} }, lc $1; + } + + return _normalize( + # Read off %pref, in descending key order... + map @{$pref{$_}}, + sort {$b <=> $a} + keys %pref + ); +} + +#=========================================================================== + +my %tried = (); + # memoization of whether we've used this module, or found it unusable. + +sub _try_use { # Basically a wrapper around "require Modulename" + # "Many men have tried..." "They tried and failed?" "They tried and died." + return $tried{$_[0]} if exists $tried{$_[0]}; # memoization + + my $module = $_[0]; # ASSUME sane module name! + { no strict 'refs'; + no warnings 'once'; + return($tried{$module} = 1) + if %{$module . "::Lexicon"} or @{$module . "::ISA"}; + # weird case: we never use'd it, but there it is! + } + + print " About to use $module ...\n" if DEBUG; + { + local $SIG{'__DIE__'}; + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + eval "require $module"; # used to be "use $module", but no point in that. + } + if($@) { + print "Error using $module \: $@\n" if DEBUG > 1; + return $tried{$module} = 0; + } else { + print " OK, $module is used\n" if DEBUG; + return $tried{$module} = 1; + } +} + +#--------------------------------------------------------------------------- +1; +__END__ + + + +# a tip: Put a bit of chopped up pickled ginger in your salad. It's tasty! +# Pod::PlainText -- Convert POD data to formatted ASCII text. +# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ +# +# Copyright 1999-2000 by Russ Allbery +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module is intended to be a replacement for Pod::Text, and attempts to +# match its output except for some specific circumstances where other +# decisions seemed to produce better output. It uses Pod::Parser and is +# designed to be very easy to subclass. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::PlainText; +use strict; + +require 5.005; + +use Carp qw(carp croak); +use Pod::Select (); + +use vars qw(@ISA %ESCAPES $VERSION); + +# We inherit from Pod::Select instead of Pod::Parser so that we can be used +# by Pod::Usage. +@ISA = qw(Pod::Select); + +$VERSION = '2.07'; + +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} + +############################################################################ +# Table of supported E<> escapes +############################################################################ + +# This table is taken near verbatim from Pod::PlainText in Pod::Parser, +# which got it near verbatim from the original Pod::Text. It is therefore +# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) +%ESCAPES = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1", # capital A, acute accent + "aacute" => "\xE1", # small a, acute accent + "Acirc" => "\xC2", # capital A, circumflex accent + "acirc" => "\xE2", # small a, circumflex accent + "AElig" => "\xC6", # capital AE diphthong (ligature) + "aelig" => "\xE6", # small ae diphthong (ligature) + "Agrave" => "\xC0", # capital A, grave accent + "agrave" => "\xE0", # small a, grave accent + "Aring" => "\xC5", # capital A, ring + "aring" => "\xE5", # small a, ring + "Atilde" => "\xC3", # capital A, tilde + "atilde" => "\xE3", # small a, tilde + "Auml" => "\xC4", # capital A, dieresis or umlaut mark + "auml" => "\xE4", # small a, dieresis or umlaut mark + "Ccedil" => "\xC7", # capital C, cedilla + "ccedil" => "\xE7", # small c, cedilla + "Eacute" => "\xC9", # capital E, acute accent + "eacute" => "\xE9", # small e, acute accent + "Ecirc" => "\xCA", # capital E, circumflex accent + "ecirc" => "\xEA", # small e, circumflex accent + "Egrave" => "\xC8", # capital E, grave accent + "egrave" => "\xE8", # small e, grave accent + "ETH" => "\xD0", # capital Eth, Icelandic + "eth" => "\xF0", # small eth, Icelandic + "Euml" => "\xCB", # capital E, dieresis or umlaut mark + "euml" => "\xEB", # small e, dieresis or umlaut mark + "Iacute" => "\xCD", # capital I, acute accent + "iacute" => "\xED", # small i, acute accent + "Icirc" => "\xCE", # capital I, circumflex accent + "icirc" => "\xEE", # small i, circumflex accent + "Igrave" => "\xCD", # capital I, grave accent + "igrave" => "\xED", # small i, grave accent + "Iuml" => "\xCF", # capital I, dieresis or umlaut mark + "iuml" => "\xEF", # small i, dieresis or umlaut mark + "Ntilde" => "\xD1", # capital N, tilde + "ntilde" => "\xF1", # small n, tilde + "Oacute" => "\xD3", # capital O, acute accent + "oacute" => "\xF3", # small o, acute accent + "Ocirc" => "\xD4", # capital O, circumflex accent + "ocirc" => "\xF4", # small o, circumflex accent + "Ograve" => "\xD2", # capital O, grave accent + "ograve" => "\xF2", # small o, grave accent + "Oslash" => "\xD8", # capital O, slash + "oslash" => "\xF8", # small o, slash + "Otilde" => "\xD5", # capital O, tilde + "otilde" => "\xF5", # small o, tilde + "Ouml" => "\xD6", # capital O, dieresis or umlaut mark + "ouml" => "\xF6", # small o, dieresis or umlaut mark + "szlig" => "\xDF", # small sharp s, German (sz ligature) + "THORN" => "\xDE", # capital THORN, Icelandic + "thorn" => "\xFE", # small thorn, Icelandic + "Uacute" => "\xDA", # capital U, acute accent + "uacute" => "\xFA", # small u, acute accent + "Ucirc" => "\xDB", # capital U, circumflex accent + "ucirc" => "\xFB", # small u, circumflex accent + "Ugrave" => "\xD9", # capital U, grave accent + "ugrave" => "\xF9", # small u, grave accent + "Uuml" => "\xDC", # capital U, dieresis or umlaut mark + "uuml" => "\xFC", # small u, dieresis or umlaut mark + "Yacute" => "\xDD", # capital Y, acute accent + "yacute" => "\xFD", # small y, acute accent + "yuml" => "\xFF", # small y, dieresis or umlaut mark + + "lchevron" => "\xAB", # left chevron (double less than) + "rchevron" => "\xBB", # right chevron (double greater than) +); + + +############################################################################ +# Initialization +############################################################################ + +# Initialize the object. Must be sure to call our parent initializer. +sub initialize { + my $self = shift; + + $$self{alt} = 0 unless defined $$self{alt}; + $$self{indent} = 4 unless defined $$self{indent}; + $$self{loose} = 0 unless defined $$self{loose}; + $$self{sentence} = 0 unless defined $$self{sentence}; + $$self{width} = 76 unless defined $$self{width}; + + $$self{INDENTS} = []; # Stack of indentations. + $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. + + return $self->SUPER::initialize; +} + + +############################################################################ +# Core overrides +############################################################################ + +# Called for each command paragraph. Gets the command, the associated +# paragraph, the line number, and a Pod::Paragraph object. Just dispatches +# the command to a method named the same as the command. =cut is handled +# internally by Pod::Parser. +sub command { + my $self = shift; + my $command = shift; + return if $command eq 'pod'; + return if ($$self{EXCLUDE} && $command ne 'end'); + if (defined $$self{ITEM}) { + $self->item ("\n"); + local $_ = "\n"; + $self->output($_) if($command eq 'back'); + } + $command = 'cmd_' . $command; + return $self->$command (@_); +} + +# Called for a verbatim paragraph. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Just output it verbatim, but with tabs converted +# to spaces. +sub verbatim { + my $self = shift; + return if $$self{EXCLUDE}; + $self->item if defined $$self{ITEM}; + local $_ = shift; + return if /^\s*$/; + s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; + return $self->output($_); +} + +# Called for a regular text block. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Perform interpolation and output the results. +sub textblock { + my $self = shift; + return if $$self{EXCLUDE}; + if($$self{VERBATIM}) { + $self->output($_[0]); + return; + } + local $_ = shift; + my $line = shift; + + # Perform a little magic to collapse multiple L<> references. This is + # here mostly for backwards-compatibility. We'll just rewrite the whole + # thing into actual text at this part, bypassing the whole internal + # sequence parsing thing. + s{ + ( + L< # A link of the form L. + / + ( + [:\w]+ # The item has to be a simple word... + (\(\))? # ...or simple function. + ) + > + ( + ,?\s+(and\s+)? # Allow lots of them, conjuncted. + L< + / + ( + [:\w]+ + (\(\))? + ) + > + )+ + ) + } { + local $_ = $1; + s%L]+)>%$1%g; + my @items = split /(?:,?\s+(?:and\s+)?)/; + my $string = "the "; + my $i; + for ($i = 0; $i < @items; $i++) { + $string .= $items[$i]; + $string .= ", " if @items > 2 && $i != $#items; + $string .= " and " if ($i == $#items - 1); + } + $string .= " entries elsewhere in this document"; + $string; + }gex; + + # Now actually interpolate and output the paragraph. + $_ = $self->interpolate ($_, $line); + s/\s*$/\n/s; + if (defined $$self{ITEM}) { + $self->item ($_ . "\n"); + } else { + $self->output ($self->reformat ($_ . "\n")); + } +} + +# Called for an interior sequence. Gets the command, argument, and a +# Pod::InteriorSequence object and is expected to return the resulting text. +# Calls code, bold, italic, file, and link to handle those types of +# sequences, and handles S<>, E<>, X<>, and Z<> directly. +sub interior_sequence { + my $self = shift; + my $command = shift; + local $_ = shift; + return '' if ($command eq 'X' || $command eq 'Z'); + + # Expand escapes into the actual character now, carping if invalid. + if ($command eq 'E') { + return $ESCAPES{$_} if defined $ESCAPES{$_}; + carp "Unknown escape: E<$_>"; + return "E<$_>"; + } + + # For all the other sequences, empty content produces no output. + return if $_ eq ''; + + # For S<>, compress all internal whitespace and then map spaces to \01. + # When we output the text, we'll map this back. + if ($command eq 'S') { + s/\s{2,}/ /g; + tr/ /\01/; + return $_; + } + + # Anything else needs to get dispatched to another method. + if ($command eq 'B') { return $self->seq_b ($_) } + elsif ($command eq 'C') { return $self->seq_c ($_) } + elsif ($command eq 'F') { return $self->seq_f ($_) } + elsif ($command eq 'I') { return $self->seq_i ($_) } + elsif ($command eq 'L') { return $self->seq_l ($_) } + else { carp "Unknown sequence $command<$_>" } +} + +# Called for each paragraph that's actually part of the POD. We take +# advantage of this opportunity to untabify the input. +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + return $_; +} + + +############################################################################ +# Command paragraphs +############################################################################ + +# All command paragraphs take the paragraph and the line number. + +# First level heading. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n==== $_ ====\n\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output ($_ . "\n"); + } +} + +# Second level heading. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n== $_ ==\n\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); + } +} + +# third level heading - not strictly perlpodspec compliant +sub cmd_head3 { + my $self = shift; + local $_ = shift; + s/\s+$//s; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n= $_ =\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output (' ' x ($$self{indent}) . $_ . "\n"); + } +} + +# fourth level heading - not strictly perlpodspec compliant +# just like head3 +*cmd_head4 = \&cmd_head3; + +# Start a list. +sub cmd_over { + my $self = shift; + local $_ = shift; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($_ + 0); +} + +# End a list. +sub cmd_back { + my $self = shift; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + unless (defined $$self{MARGIN}) { + carp 'Unmatched =back'; + $$self{MARGIN} = $$self{indent}; + } +} + +# An individual list item. +sub cmd_item { + my $self = shift; + if (defined $$self{ITEM}) { $self->item } + local $_ = shift; + s/\s+$//s; + $$self{ITEM} = $self->interpolate ($_); +} + +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). +sub cmd_begin { + my $self = shift; + local $_ = shift; + my ($kind) = /^(\S+)/ or return; + if ($kind eq 'text') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } +} + +# End a block for a particular translator. We assume that all =begin/=end +# pairs are properly closed. +sub cmd_end { + my $self = shift; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; +} + +# One paragraph for a particular translator. Ignore it unless it's intended +# for text, in which case we treat it as a verbatim text block. +sub cmd_for { + my $self = shift; + local $_ = shift; + my $line = shift; + return unless s/^text\b[ \t]*\r?\n?//; + $self->verbatim ($_, $line); +} + +# just a dummy method for the time being +sub cmd_encoding { + return; +} + +############################################################################ +# Interior sequences +############################################################################ + +# The simple formatting ones. These are here mostly so that subclasses can +# override them and do more complicated things. +sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } +sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } +sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } +sub seq_i { return '*' . $_[1] . '*' } + +# The complicated one. Handle links. Since this is plain text, we can't +# actually make any real links, so this is all to figure out what text we +# print out. +sub seq_l { + my $self = shift; + local $_ = shift; + + # Smash whitespace in case we were split across multiple lines. + s/\s+/ /g; + + # If we were given any explicit text, just output it. + if (/^([^|]+)\|/) { return $1 } + + # Okay, leading and trailing whitespace isn't important; get rid of it. + s/^\s+//; + s/\s+$//; + + # Default to using the whole content of the link entry as a section + # name. Note that L forces a manpage interpretation, as does + # something looking like L. The latter is an + # enhancement over the original Pod::Text. + my ($manpage, $section) = ('', $_); + if (/^(?:https?|ftp|news):/) { + # a URL + return $_; + } elsif (/^"\s*(.*?)\s*"$/) { + $section = '"' . $1 . '"'; + } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { + ($manpage, $section) = ($_, ''); + } elsif (m{/}) { + ($manpage, $section) = split (/\s*\/\s*/, $_, 2); + } + + my $text = ''; + # Now build the actual output text. + if (!length $section) { + $text = "the $manpage manpage" if length $manpage; + } elsif ($section =~ /^[:\w]+(?:\(\))?/) { + $text .= 'the ' . $section . ' entry'; + $text .= (length $manpage) ? " in the $manpage manpage" + : ' elsewhere in this document'; + } else { + $section =~ s/^\"\s*//; + $section =~ s/\s*\"$//; + $text .= 'the section on "' . $section . '"'; + $text .= " in the $manpage manpage" if length $manpage; + } + return $text; +} + + +############################################################################ +# List handling +############################################################################ + +# This method is called whenever an =item command is complete (in other +# words, we've seen its associated paragraph or know for certain that it +# doesn't have one). It gets the paragraph associated with the item as an +# argument. If that argument is empty, just output the item tag; if it +# contains a newline, output the item tag followed by the newline. +# Otherwise, see if there's enough room for us to output the item tag in the +# margin of the text or if we have to put it on a separate line. +sub item { + my $self = shift; + local $_ = shift; + my $tag = $$self{ITEM}; + unless (defined $tag) { + carp 'item called without tag'; + return; + } + undef $$self{ITEM}; + my $indent = $$self{INDENTS}[-1]; + unless (defined $indent) { $indent = $$self{indent} } + my $space = ' ' x $indent; + $space =~ s/^ /:/ if $$self{alt}; + if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { + my $margin = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/[\r\n]*$/\n/; + $self->output ($output); + $$self{MARGIN} = $margin; + $self->output ($self->reformat ($_)) if /\S/; + } else { + $_ = $self->reformat ($_); + s/^ /:/ if ($$self{alt} && $indent > 0); + my $tagspace = ' ' x length $tag; + s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; + $self->output ($_); + } +} + + +############################################################################ +# Output formatting +############################################################################ + +# Wrap a line, indenting by the current left margin. We can't use +# Text::Wrap because it plays games with tabs. We can't use formline, even +# though we'd really like to, because it screws up non-printing characters. +# So we have to do the wrapping ourselves. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +# Reformat a paragraph of text for the current margin. Takes the text to +# reformat and returns the formatted text. +sub reformat { + my $self = shift; + local $_ = shift; + + # If we're trying to preserve two spaces after sentences, do some + # munging to support that. Otherwise, smash all repeated whitespace. + if ($$self{sentence}) { + s/ +$//mg; + s/\.\r?\n/. \n/g; + s/[\r\n]+/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + return $self->wrap($_); +} + +# Output text to the output device. +sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } + + +############################################################################ +# Backwards compatibility +############################################################################ + +# The old Pod::Text module did everything in a pod2text() function. This +# tries to provide the same interface for legacy applications. +sub pod2text { + my @args; + + # This is really ugly; I hate doing option parsing in the middle of a + # module. But the old Pod::Text module supported passing flags to its + # entry function, so handle -a and -. + while ($_[0] =~ /^-/) { + my $flag = shift; + if ($flag eq '-a') { push (@args, alt => 1) } + elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } + else { + unshift (@_, $flag); + last; + } + } + + # Now that we know what arguments we're using, create the parser. + my $parser = Pod::PlainText->new (@args); + + # If two arguments were given, the second argument is going to be a file + # handle. That means we want to call parse_from_filehandle(), which + # means we need to turn the first argument into a file handle. Magic + # open will handle the <&STDIN case automagically. + if (defined $_[1]) { + my $infh; + if ($] < 5.006) { + $infh = gensym(); + } + unless (open ($infh, $_[0])) { + croak ("Can't open $_[0] for reading: $!\n"); + } + $_[0] = $infh; + return $parser->parse_from_filehandle (@_); + } else { + return $parser->parse_from_file (@_); + } +} + + +############################################################################ +# Module return value and documentation +############################################################################ + +1; +__END__ + +# Pod::ParseLink -- Parse an L<> formatting code in POD text. +# +# Copyright 2001, 2008, 2009, 2014 by Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module implements parsing of the text of an L<> formatting code as +# defined in perlpodspec. It should be suitable for any POD formatter. It +# exports only one function, parselink(), which returns the five-item parse +# defined in perlpodspec. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::ParseLink; + +use 5.006; +use strict; +use warnings; + +use vars qw(@EXPORT @ISA $VERSION); + +use Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parselink); + +$VERSION = '4.10'; + +############################################################################## +# Implementation +############################################################################## + +# Parse the name and section portion of a link into a name and section. +sub _parse_section { + my ($link) = @_; + $link =~ s/^\s+//; + $link =~ s/\s+$//; + + # If the whole link is enclosed in quotes, interpret it all as a section + # even if it contains a slash. + return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/); + + # Split into page and section on slash, and then clean up quoting in the + # section. If there is no section and the name contains spaces, also + # guess that it's an old section link. + my ($page, $section) = split (/\s*\/\s*/, $link, 2); + $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section; + if ($page && $page =~ / / && !defined ($section)) { + $section = $page; + $page = undef; + } else { + $page = undef unless $page; + $section = undef unless $section; + } + return ($page, $section); +} + +# Infer link text from the page and section. +sub _infer_text { + my ($page, $section) = @_; + my $inferred; + if ($page && !$section) { + $inferred = $page; + } elsif (!$page && $section) { + $inferred = '"' . $section . '"'; + } elsif ($page && $section) { + $inferred = '"' . $section . '" in ' . $page; + } + return $inferred; +} + +# Given the contents of an L<> formatting code, parse it into the link text, +# the possibly inferred link text, the name or URL, the section, and the type +# of link (pod, man, or url). +sub parselink { + my ($link) = @_; + $link =~ s/\s+/ /g; + my $text; + if ($link =~ /\|/) { + ($text, $link) = split (/\|/, $link, 2); + } + if ($link =~ /\A\w+:[^:\s]\S*\Z/) { + my $inferred; + if (defined ($text) && length ($text) > 0) { + return ($text, $text, $link, undef, 'url'); + } else { + return ($text, $link, $link, undef, 'url'); + } + } else { + my ($name, $section) = _parse_section ($link); + my $inferred; + if (defined ($text) && length ($text) > 0) { + $inferred = $text; + } else { + $inferred = _infer_text ($name, $section); + } + my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod'; + return ($text, $inferred, $name, $section, $type); + } +} + +############################################################################## +# Module return value and documentation +############################################################################## + +# Ensure we evaluate to true. +1; +__END__ + +# Convert POD data to formatted text. +# +# This module converts POD to formatted text. It replaces the old Pod::Text +# module that came with versions of Perl prior to 5.6.0 and attempts to match +# its output except for some specific circumstances where other decisions +# seemed to produce better output. It uses Pod::Parser and is designed to be +# very easy to subclass. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. +# +# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2014, +# 2015, 2016 Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text; + +use 5.006; +use strict; +use warnings; + +use vars qw(@ISA @EXPORT %ESCAPES $VERSION); + +use Carp qw(carp croak); +use Encode qw(encode); +use Exporter (); +use Pod::Simple (); + +@ISA = qw(Pod::Simple Exporter); + +# We have to export pod2text for backward compatibility. +@EXPORT = qw(pod2text); + +$VERSION = '4.10'; + +# Ensure that $Pod::Simple::nbsp and $Pod::Simple::shy are available. Code +# taken from Pod::Simple 3.32, but was only added in 3.30. +my ($NBSP, $SHY); +if ($Pod::Simple::VERSION ge 3.30) { + $NBSP = $Pod::Simple::nbsp; + $SHY = $Pod::Simple::shy; +} else { + if ($] ge 5.007_003) { + $NBSP = chr utf8::unicode_to_native(0xA0); + $SHY = chr utf8::unicode_to_native(0xAD); + } elsif (Pod::Simple::ASCII) { + $NBSP = "\xA0"; + $SHY = "\xAD"; + } else { + $NBSP = "\x41"; + $SHY = "\xCA"; + } +} + +############################################################################## +# Initialization +############################################################################## + +# This function handles code blocks. It's registered as a callback to +# Pod::Simple and therefore doesn't work as a regular method call, but all it +# does is call output_code with the line. +sub handle_code { + my ($line, $number, $parser) = @_; + $parser->output_code ($line . "\n"); +} + +# Initialize the object and set various Pod::Simple options that we need. +# Here, we also process any additional options passed to the constructor or +# set up defaults if none were given. Note that all internal object keys are +# in all-caps, reserving all lower-case object keys for Pod::Simple and user +# arguments. +sub new { + my $class = shift; + my $self = $class->SUPER::new; + + # Tell Pod::Simple to handle S<> by automatically inserting  . + $self->nbsp_for_S (1); + + # Tell Pod::Simple to keep whitespace whenever possible. + if ($self->can ('preserve_whitespace')) { + $self->preserve_whitespace (1); + } else { + $self->fullstop_space_harden (1); + } + + # The =for and =begin targets that we accept. + $self->accept_targets (qw/text TEXT/); + + # Ensure that contiguous blocks of code are merged together. Otherwise, + # some of the guesswork heuristics don't work right. + $self->merge_text (1); + + # Pod::Simple doesn't do anything useful with our arguments, but we want + # to put them in our object as hash keys and values. This could cause + # problems if we ever clash with Pod::Simple's own internal class + # variables. + my %opts = @_; + my @opts = map { ("opt_$_", $opts{$_}) } keys %opts; + %$self = (%$self, @opts); + + # Send errors to stderr if requested. + if ($$self{opt_stderr} and not $$self{opt_errors}) { + $$self{opt_errors} = 'stderr'; + } + delete $$self{opt_stderr}; + + # Validate the errors parameter and act on it. + if (not defined $$self{opt_errors}) { + $$self{opt_errors} = 'pod'; + } + if ($$self{opt_errors} eq 'stderr' || $$self{opt_errors} eq 'die') { + $self->no_errata_section (1); + $self->complain_stderr (1); + if ($$self{opt_errors} eq 'die') { + $$self{complain_die} = 1; + } + } elsif ($$self{opt_errors} eq 'pod') { + $self->no_errata_section (0); + $self->complain_stderr (0); + } elsif ($$self{opt_errors} eq 'none') { + $self->no_whining (1); + } else { + croak (qq(Invalid errors setting: "$$self{errors}")); + } + delete $$self{errors}; + + # Initialize various things from our parameters. + $$self{opt_alt} = 0 unless defined $$self{opt_alt}; + $$self{opt_indent} = 4 unless defined $$self{opt_indent}; + $$self{opt_margin} = 0 unless defined $$self{opt_margin}; + $$self{opt_loose} = 0 unless defined $$self{opt_loose}; + $$self{opt_sentence} = 0 unless defined $$self{opt_sentence}; + $$self{opt_width} = 76 unless defined $$self{opt_width}; + + # Figure out what quotes we'll be using for C<> text. + $$self{opt_quotes} ||= '"'; + if ($$self{opt_quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{opt_quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes}; + } elsif (length ($$self{opt_quotes}) % 2 == 0) { + my $length = length ($$self{opt_quotes}) / 2; + $$self{LQUOTE} = substr ($$self{opt_quotes}, 0, $length); + $$self{RQUOTE} = substr ($$self{opt_quotes}, $length); + } else { + croak qq(Invalid quote specification "$$self{opt_quotes}"); + } + + # If requested, do something with the non-POD text. + $self->code_handler (\&handle_code) if $$self{opt_code}; + + # Return the created object. + return $self; +} + +############################################################################## +# Core parsing +############################################################################## + +# This is the glue that connects the code below with Pod::Simple itself. The +# goal is to convert the event stream coming from the POD parser into method +# calls to handlers once the complete content of a tag has been seen. Each +# paragraph or POD command will have textual content associated with it, and +# as soon as all of a paragraph or POD command has been seen, that content +# will be passed in to the corresponding method for handling that type of +# object. The exceptions are handlers for lists, which have opening tag +# handlers and closing tag handlers that will be called right away. +# +# The internal hash key PENDING is used to store the contents of a tag until +# all of it has been seen. It holds a stack of open tags, each one +# represented by a tuple of the attributes hash for the tag and the contents +# of the tag. + +# Add a block of text to the contents of the current node, formatting it +# according to the current formatting instructions as we do. +sub _handle_text { + my ($self, $text) = @_; + my $tag = $$self{PENDING}[-1]; + $$tag[1] .= $text; +} + +# Given an element name, get the corresponding method name. +sub method_for_element { + my ($self, $element) = @_; + $element =~ tr/-/_/; + $element =~ tr/A-Z/a-z/; + $element =~ tr/_a-z0-9//cd; + return $element; +} + +# Handle the start of a new element. If cmd_element is defined, assume that +# we need to collect the entire tree for this element before passing it to the +# element method, and create a new tree into which we'll collect blocks of +# text and nested elements. Otherwise, if start_element is defined, call it. +sub _handle_element_start { + my ($self, $element, $attrs) = @_; + my $method = $self->method_for_element ($element); + + # If we have a command handler, we need to accumulate the contents of the + # tag before calling it. + if ($self->can ("cmd_$method")) { + push (@{ $$self{PENDING} }, [ $attrs, '' ]); + } elsif ($self->can ("start_$method")) { + my $method = 'start_' . $method; + $self->$method ($attrs, ''); + } +} + +# Handle the end of an element. If we had a cmd_ method for this element, +# this is where we pass along the text that we've accumulated. Otherwise, if +# we have an end_ method for the element, call that. +sub _handle_element_end { + my ($self, $element) = @_; + my $method = $self->method_for_element ($element); + + # If we have a command handler, pull off the pending text and pass it to + # the handler along with the saved attribute hash. + if ($self->can ("cmd_$method")) { + my $tag = pop @{ $$self{PENDING} }; + my $method = 'cmd_' . $method; + my $text = $self->$method (@$tag); + if (defined $text) { + if (@{ $$self{PENDING} } > 1) { + $$self{PENDING}[-1][1] .= $text; + } else { + $self->output ($text); + } + } + } elsif ($self->can ("end_$method")) { + my $method = 'end_' . $method; + $self->$method (); + } +} + +############################################################################## +# Output formatting +############################################################################## + +# Wrap a line, indenting by the current left margin. We can't use Text::Wrap +# because it plays games with tabs. We can't use formline, even though we'd +# really like to, because it screws up non-printing characters. So we have to +# do the wrapping ourselves. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + while (length > $width) { + if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +# Reformat a paragraph of text for the current margin. Takes the text to +# reformat and returns the formatted text. +sub reformat { + my $self = shift; + local $_ = shift; + + # If we're trying to preserve two spaces after sentences, do some munging + # to support that. Otherwise, smash all repeated whitespace. + if ($$self{opt_sentence}) { + s/ +$//mg; + s/\.\n/. \n/g; + s/\n/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + return $self->wrap ($_); +} + +# Output text to the output device. Replace non-breaking spaces with spaces +# and soft hyphens with nothing, and then try to fix the output encoding if +# necessary to match the input encoding unless UTF-8 output is forced. This +# preserves the traditional pass-through behavior of Pod::Text. +sub output { + my ($self, @text) = @_; + my $text = join ('', @text); + if ($NBSP) { + $text =~ s/$NBSP/ /g; + } + if ($SHY) { + $text =~ s/$SHY//g; + } + unless ($$self{opt_utf8}) { + my $encoding = $$self{encoding} || ''; + if ($encoding && $encoding ne $$self{ENCODING}) { + $$self{ENCODING} = $encoding; + eval { binmode ($$self{output_fh}, ":encoding($encoding)") }; + } + } + if ($$self{ENCODE}) { + print { $$self{output_fh} } encode ('UTF-8', $text); + } else { + print { $$self{output_fh} } $text; + } +} + +# Output a block of code (something that isn't part of the POD text). Called +# by preprocess_paragraph only if we were given the code option. Exists here +# only so that it can be overridden by subclasses. +sub output_code { $_[0]->output ($_[1]) } + +############################################################################## +# Document initialization +############################################################################## + +# Set up various things that have to be initialized on a per-document basis. +sub start_document { + my ($self, $attrs) = @_; + if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) { + $$self{CONTENTLESS} = 1; + } else { + delete $$self{CONTENTLESS}; + } + my $margin = $$self{opt_indent} + $$self{opt_margin}; + + # Initialize a few per-document variables. + $$self{INDENTS} = []; # Stack of indentations. + $$self{MARGIN} = $margin; # Default left margin. + $$self{PENDING} = [[]]; # Pending output. + + # We have to redo encoding handling for each document. + $$self{ENCODING} = ''; + + # When UTF-8 output is set, check whether our output file handle already + # has a PerlIO encoding layer set. If it does not, we'll need to encode + # our output before printing it (handled in the output() sub). Wrap the + # check in an eval to handle versions of Perl without PerlIO. + $$self{ENCODE} = 0; + if ($$self{opt_utf8}) { + $$self{ENCODE} = 1; + eval { + my @options = (output => 1, details => 1); + my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1]; + if ($flag & PerlIO::F_UTF8 ()) { + $$self{ENCODE} = 0; + $$self{ENCODING} = 'UTF-8'; + } + }; + } + + return ''; +} + +# Handle the end of the document. The only thing we do is handle dying on POD +# errors, since Pod::Parser currently doesn't. +sub end_document { + my ($self) = @_; + if ($$self{complain_die} && $self->errors_seen) { + croak ("POD document had syntax errors"); + } +} + +############################################################################## +# Text blocks +############################################################################## + +# Intended for subclasses to override, this method returns text with any +# non-printing formatting codes stripped out so that length() correctly +# returns the length of the text. For basic Pod::Text, it does nothing. +sub strip_format { + my ($self, $string) = @_; + return $string; +} + +# This method is called whenever an =item command is complete (in other words, +# we've seen its associated paragraph or know for certain that it doesn't have +# one). It gets the paragraph associated with the item as an argument. If +# that argument is empty, just output the item tag; if it contains a newline, +# output the item tag followed by the newline. Otherwise, see if there's +# enough room for us to output the item tag in the margin of the text or if we +# have to put it on a separate line. +sub item { + my ($self, $text) = @_; + my $tag = $$self{ITEM}; + unless (defined $tag) { + carp "Item called without tag"; + return; + } + undef $$self{ITEM}; + + # Calculate the indentation and margin. $fits is set to true if the tag + # will fit into the margin of the paragraph given our indentation level. + my $indent = $$self{INDENTS}[-1]; + $indent = $$self{opt_indent} unless defined $indent; + my $margin = ' ' x $$self{opt_margin}; + my $tag_length = length ($self->strip_format ($tag)); + my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1); + + # If the tag doesn't fit, or if we have no associated text, print out the + # tag separately. Otherwise, put the tag in the margin of the paragraph. + if (!$text || $text =~ /^\s+$/ || !$fits) { + my $realindent = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0); + $output =~ s/\n*$/\n/; + + # If the text is just whitespace, we have an empty item paragraph; + # this can result from =over/=item/=back without any intermixed + # paragraphs. Insert some whitespace to keep the =item from merging + # into the next paragraph. + $output .= "\n" if $text && $text =~ /^\s*$/; + + $self->output ($output); + $$self{MARGIN} = $realindent; + $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/); + } else { + my $space = ' ' x $indent; + $space =~ s/^$margin /$margin:/ if $$self{opt_alt}; + $text = $self->reformat ($text); + $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0); + my $tagspace = ' ' x $tag_length; + $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item"; + $self->output ($text); + } +} + +# Handle a basic block of text. The only tricky thing here is that if there +# is a pending item tag, we need to format this as an item paragraph. +sub cmd_para { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$/\n/; + if (defined $$self{ITEM}) { + $self->item ($text . "\n"); + } else { + $self->output ($self->reformat ($text . "\n")); + } + return ''; +} + +# Handle a verbatim paragraph. Just print it out, but indent it according to +# our margin. +sub cmd_verbatim { + my ($self, $attrs, $text) = @_; + $self->item if defined $$self{ITEM}; + return if $text =~ /^\s*$/; + $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme; + $text =~ s/\s*$/\n\n/; + $self->output ($text); + return ''; +} + +# Handle literal text (produced by =for and similar constructs). Just output +# it with the minimum of changes. +sub cmd_data { + my ($self, $attrs, $text) = @_; + $text =~ s/^\n+//; + $text =~ s/\n{0,2}$/\n/; + $self->output ($text); + return ''; +} + +############################################################################## +# Headings +############################################################################## + +# The common code for handling all headers. Takes the header text, the +# indentation, and the surrounding marker for the alt formatting method. +sub heading { + my ($self, $text, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text =~ s/\s+$//; + if ($$self{opt_alt}) { + my $closemark = reverse (split (//, $marker)); + my $margin = ' ' x $$self{opt_margin}; + $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n"); + } else { + $text .= "\n" if $$self{opt_loose}; + my $margin = ' ' x ($$self{opt_margin} + $indent); + $self->output ($margin . $text . "\n"); + } + return ''; +} + +# First level heading. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, 0, '===='); +} + +# Second level heading. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} / 2, '== '); +} + +# Third level heading. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= '); +} + +# Fourth level heading. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- '); +} + +############################################################################## +# List handling +############################################################################## + +# Handle the beginning of an =over block. Takes the type of the block as the +# first argument, and then the attr hash. This is called by the handlers for +# the four different types of lists (bullet, number, text, and block). +sub over_common_start { + my ($self, $attrs) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + + # Find the indentation level. + my $indent = $$attrs{indent}; + unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) { + $indent = $$self{opt_indent}; + } + + # Add this to our stack of indents and increase our current margin. + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($indent + 0); + return ''; +} + +# End an =over block. Takes no options other than the class pointer. Output +# any pending items and then pop one level of indentation. +sub over_common_end { + my ($self) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + return ''; +} + +# Dispatch the start and end calls as appropriate. +sub start_over_bullet { $_[0]->over_common_start ($_[1]) } +sub start_over_number { $_[0]->over_common_start ($_[1]) } +sub start_over_text { $_[0]->over_common_start ($_[1]) } +sub start_over_block { $_[0]->over_common_start ($_[1]) } +sub end_over_bullet { $_[0]->over_common_end } +sub end_over_number { $_[0]->over_common_end } +sub end_over_text { $_[0]->over_common_end } +sub end_over_block { $_[0]->over_common_end } + +# The common handler for all item commands. Takes the type of the item, the +# attributes, and then the text of the item. +sub item_common { + my ($self, $type, $attrs, $text) = @_; + $self->item if defined $$self{ITEM}; + + # Clean up the text. We want to end up with two variables, one ($text) + # which contains any body text after taking out the item portion, and + # another ($item) which contains the actual item text. Note the use of + # the internal Pod::Simple attribute here; that's a potential land mine. + $text =~ s/\s+$//; + my ($item, $index); + if ($type eq 'bullet') { + $item = '*'; + } elsif ($type eq 'number') { + $item = $$attrs{'~orig_content'}; + } else { + $item = $text; + $item =~ s/\s*\n\s*/ /g; + $text = ''; + } + $$self{ITEM} = $item; + + # If body text for this item was included, go ahead and output that now. + if ($text) { + $text =~ s/\s*$/\n/; + $self->item ($text); + } + return ''; +} + +# Dispatch the item commands to the appropriate place. +sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) } +sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) } +sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) } +sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) } + +############################################################################## +# Formatting codes +############################################################################## + +# The simple ones. +sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] } +sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] } +sub cmd_i { return '*' . $_[2] . '*' } +sub cmd_x { return '' } + +# Apply a whole bunch of messy heuristics to not quote things that don't +# benefit from being quoted. These originally come from Barrie Slaymaker and +# largely duplicate code in Pod::Man. +sub cmd_c { + my ($self, $attrs, $text) = @_; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + $text =~ m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \` .* \' # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xo && return $text; + + # If we didn't return, go ahead and quote the text. + return $$self{opt_alt} + ? "``$text''" + : "$$self{LQUOTE}$text$$self{RQUOTE}"; +} + +# Links reduce to the text that we're given, wrapped in angle brackets if it's +# a URL. +sub cmd_l { + my ($self, $attrs, $text) = @_; + if ($$attrs{type} eq 'url') { + if (not defined($$attrs{to}) or $$attrs{to} eq $text) { + return "<$text>"; + } elsif ($$self{opt_nourls}) { + return $text; + } else { + return "$text <$$attrs{to}>"; + } + } else { + return $text; + } +} + +############################################################################## +# Backwards compatibility +############################################################################## + +# The old Pod::Text module did everything in a pod2text() function. This +# tries to provide the same interface for legacy applications. +sub pod2text { + my @args; + + # This is really ugly; I hate doing option parsing in the middle of a + # module. But the old Pod::Text module supported passing flags to its + # entry function, so handle -a and -. + while ($_[0] =~ /^-/) { + my $flag = shift; + if ($flag eq '-a') { push (@args, alt => 1) } + elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } + else { + unshift (@_, $flag); + last; + } + } + + # Now that we know what arguments we're using, create the parser. + my $parser = Pod::Text->new (@args); + + # If two arguments were given, the second argument is going to be a file + # handle. That means we want to call parse_from_filehandle(), which means + # we need to turn the first argument into a file handle. Magic open will + # handle the <&STDIN case automagically. + if (defined $_[1]) { + my @fhs = @_; + local *IN; + unless (open (IN, $fhs[0])) { + croak ("Can't open $fhs[0] for reading: $!\n"); + return; + } + $fhs[0] = \*IN; + $parser->output_fh ($fhs[1]); + my $retval = $parser->parse_file ($fhs[0]); + my $fh = $parser->output_fh (); + close $fh; + return $retval; + } else { + $parser->output_fh (\*STDOUT); + return $parser->parse_file (@_); + } +} + +# Reset the underlying Pod::Simple object between calls to parse_from_file so +# that the same object can be reused to convert multiple pages. +sub parse_from_file { + my $self = shift; + $self->reinit; + + # Fake the old cutting option to Pod::Parser. This fiddles with internal + # Pod::Simple state and is quite ugly; we need a better approach. + if (ref ($_[0]) eq 'HASH') { + my $opts = shift @_; + if (defined ($$opts{-cutting}) && !$$opts{-cutting}) { + $$self{in_pod} = 1; + $$self{last_was_blank} = 1; + } + } + + # Do the work. + my $retval = $self->Pod::Simple::parse_from_file (@_); + + # Flush output, since Pod::Simple doesn't do this. Ideally we should also + # close the file descriptor if we had to open one, but we can't easily + # figure this out. + my $fh = $self->output_fh (); + my $oldfh = select $fh; + my $oldflush = $|; + $| = 1; + print $fh ''; + $| = $oldflush; + select $oldfh; + return $retval; +} + +# Pod::Simple failed to provide this backward compatibility function, so +# implement it ourselves. File handles are one of the inputs that +# parse_from_file supports. +sub parse_from_filehandle { + my $self = shift; + $self->parse_from_file (@_); +} + +# Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so +# ourself unless it was already set by the caller, since our documentation has +# always said that this should work. +sub parse_file { + my ($self, $in) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_file ($in); +} + +# Do the same for parse_lines, just to be polite. Pod::Simple's man page +# implies that the caller is responsible for setting this, but I don't see any +# reason not to set a default. +sub parse_lines { + my ($self, @lines) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_lines (@lines); +} + +# Likewise for parse_string_document. +sub parse_string_document { + my ($self, $doc) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_string_document ($doc); +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +package Pod::Escapes; +use strict; +use warnings; +use 5.006; + +use vars qw( + %Code2USASCII + %Name2character + %Name2character_number + %Latin1Code_to_fallback + %Latin1Char_to_fallback + $FAR_CHAR + $FAR_CHAR_NUMBER + $NOT_ASCII + @ISA $VERSION @EXPORT_OK %EXPORT_TAGS +); + +require Exporter; +@ISA = ('Exporter'); +$VERSION = '1.07'; +@EXPORT_OK = qw( + %Code2USASCII + %Name2character + %Name2character_number + %Latin1Code_to_fallback + %Latin1Char_to_fallback + e2char + e2charnum +); +%EXPORT_TAGS = ('ALL' => \@EXPORT_OK); + +#========================================================================== + +$FAR_CHAR = "?" unless defined $FAR_CHAR; +$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER; + +$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII; + +#-------------------------------------------------------------------------- +sub e2char { + my $in = $_[0]; + return undef unless defined $in and length $in; + + # Convert to decimal: + if($in =~ m/^(0[0-7]*)$/s ) { + $in = oct $in; + } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { + $in = hex $1; + } # else it's decimal, or named + + if($in =~ m/^\d+$/s) { + if($] < 5.007 and $in > 255) { # can't be trusted with Unicode + return $FAR_CHAR; + } elsif ($] >= 5.007003) { + return chr(utf8::unicode_to_native($in)); + } elsif ($NOT_ASCII) { + return $Code2USASCII{$in} # so "65" => "A" everywhere + || $Latin1Code_to_fallback{$in} # Fallback. + || $FAR_CHAR; # Fall further back + } else { + return chr($in); + } + } else { + return $Name2character{$in}; # returns undef if unknown + } +} + +#-------------------------------------------------------------------------- +sub e2charnum { + my $in = $_[0]; + return undef unless defined $in and length $in; + + # Convert to decimal: + if($in =~ m/^(0[0-7]*)$/s ) { + $in = oct $in; + } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) { + $in = hex $1; + } # else it's decimal, or named + + if($in =~ m/^[0-9]+$/s) { + return 0 + $in; + } else { + return $Name2character_number{$in}; # returns undef if unknown + } +} + +#-------------------------------------------------------------------------- + +%Code2USASCII = ( +# mostly generated by +# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)" + 32, ' ', + 33, '!', + 34, '"', + 35, '#', + 36, '$', + 37, '%', + 38, '&', + 39, "'", #! + 40, '(', + 41, ')', + 42, '*', + 43, '+', + 44, ',', + 45, '-', + 46, '.', + 47, '/', + 48, '0', + 49, '1', + 50, '2', + 51, '3', + 52, '4', + 53, '5', + 54, '6', + 55, '7', + 56, '8', + 57, '9', + 58, ':', + 59, ';', + 60, '<', + 61, '=', + 62, '>', + 63, '?', + 64, '@', + 65, 'A', + 66, 'B', + 67, 'C', + 68, 'D', + 69, 'E', + 70, 'F', + 71, 'G', + 72, 'H', + 73, 'I', + 74, 'J', + 75, 'K', + 76, 'L', + 77, 'M', + 78, 'N', + 79, 'O', + 80, 'P', + 81, 'Q', + 82, 'R', + 83, 'S', + 84, 'T', + 85, 'U', + 86, 'V', + 87, 'W', + 88, 'X', + 89, 'Y', + 90, 'Z', + 91, '[', + 92, "\\", #! + 93, ']', + 94, '^', + 95, '_', + 96, '`', + 97, 'a', + 98, 'b', + 99, 'c', + 100, 'd', + 101, 'e', + 102, 'f', + 103, 'g', + 104, 'h', + 105, 'i', + 106, 'j', + 107, 'k', + 108, 'l', + 109, 'm', + 110, 'n', + 111, 'o', + 112, 'p', + 113, 'q', + 114, 'r', + 115, 's', + 116, 't', + 117, 'u', + 118, 'v', + 119, 'w', + 120, 'x', + 121, 'y', + 122, 'z', + 123, '{', + 124, '|', + 125, '}', + 126, '~', +); + +#-------------------------------------------------------------------------- + +%Latin1Code_to_fallback = (); +@Latin1Code_to_fallback{0xA0 .. 0xFF} = ( +# Copied from Text/Unidecode/x00.pm: + +' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-}, +'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?}, +'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I', +'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss', +'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i', +'d', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y', + +); + +{ + # Now stuff %Latin1Char_to_fallback: + %Latin1Char_to_fallback = (); + my($k,$v); + while( ($k,$v) = each %Latin1Code_to_fallback) { + $Latin1Char_to_fallback{chr $k} = $v; + #print chr($k), ' => ', $v, "\n"; + } +} + +#-------------------------------------------------------------------------- + +%Name2character_number = ( + # General XML/XHTML: + 'lt' => 60, + 'gt' => 62, + 'quot' => 34, + 'amp' => 38, + 'apos' => 39, + + # POD-specific: + 'sol' => 47, + 'verbar' => 124, + + 'lchevron' => 171, # legacy for laquo + 'rchevron' => 187, # legacy for raquo + + # Remember, grave looks like \ (as in virtu\) + # acute looks like / (as in re/sume/) + # circumflex looks like ^ (as in papier ma^che/) + # umlaut/dieresis looks like " (as in nai"ve, Chloe") + + # From the XHTML 1 .ent files: + 'nbsp' , 160, + 'iexcl' , 161, + 'cent' , 162, + 'pound' , 163, + 'curren' , 164, + 'yen' , 165, + 'brvbar' , 166, + 'sect' , 167, + 'uml' , 168, + 'copy' , 169, + 'ordf' , 170, + 'laquo' , 171, + 'not' , 172, + 'shy' , 173, + 'reg' , 174, + 'macr' , 175, + 'deg' , 176, + 'plusmn' , 177, + 'sup2' , 178, + 'sup3' , 179, + 'acute' , 180, + 'micro' , 181, + 'para' , 182, + 'middot' , 183, + 'cedil' , 184, + 'sup1' , 185, + 'ordm' , 186, + 'raquo' , 187, + 'frac14' , 188, + 'frac12' , 189, + 'frac34' , 190, + 'iquest' , 191, + 'Agrave' , 192, + 'Aacute' , 193, + 'Acirc' , 194, + 'Atilde' , 195, + 'Auml' , 196, + 'Aring' , 197, + 'AElig' , 198, + 'Ccedil' , 199, + 'Egrave' , 200, + 'Eacute' , 201, + 'Ecirc' , 202, + 'Euml' , 203, + 'Igrave' , 204, + 'Iacute' , 205, + 'Icirc' , 206, + 'Iuml' , 207, + 'ETH' , 208, + 'Ntilde' , 209, + 'Ograve' , 210, + 'Oacute' , 211, + 'Ocirc' , 212, + 'Otilde' , 213, + 'Ouml' , 214, + 'times' , 215, + 'Oslash' , 216, + 'Ugrave' , 217, + 'Uacute' , 218, + 'Ucirc' , 219, + 'Uuml' , 220, + 'Yacute' , 221, + 'THORN' , 222, + 'szlig' , 223, + 'agrave' , 224, + 'aacute' , 225, + 'acirc' , 226, + 'atilde' , 227, + 'auml' , 228, + 'aring' , 229, + 'aelig' , 230, + 'ccedil' , 231, + 'egrave' , 232, + 'eacute' , 233, + 'ecirc' , 234, + 'euml' , 235, + 'igrave' , 236, + 'iacute' , 237, + 'icirc' , 238, + 'iuml' , 239, + 'eth' , 240, + 'ntilde' , 241, + 'ograve' , 242, + 'oacute' , 243, + 'ocirc' , 244, + 'otilde' , 245, + 'ouml' , 246, + 'divide' , 247, + 'oslash' , 248, + 'ugrave' , 249, + 'uacute' , 250, + 'ucirc' , 251, + 'uuml' , 252, + 'yacute' , 253, + 'thorn' , 254, + 'yuml' , 255, + + 'fnof' , 402, + 'Alpha' , 913, + 'Beta' , 914, + 'Gamma' , 915, + 'Delta' , 916, + 'Epsilon' , 917, + 'Zeta' , 918, + 'Eta' , 919, + 'Theta' , 920, + 'Iota' , 921, + 'Kappa' , 922, + 'Lambda' , 923, + 'Mu' , 924, + 'Nu' , 925, + 'Xi' , 926, + 'Omicron' , 927, + 'Pi' , 928, + 'Rho' , 929, + 'Sigma' , 931, + 'Tau' , 932, + 'Upsilon' , 933, + 'Phi' , 934, + 'Chi' , 935, + 'Psi' , 936, + 'Omega' , 937, + 'alpha' , 945, + 'beta' , 946, + 'gamma' , 947, + 'delta' , 948, + 'epsilon' , 949, + 'zeta' , 950, + 'eta' , 951, + 'theta' , 952, + 'iota' , 953, + 'kappa' , 954, + 'lambda' , 955, + 'mu' , 956, + 'nu' , 957, + 'xi' , 958, + 'omicron' , 959, + 'pi' , 960, + 'rho' , 961, + 'sigmaf' , 962, + 'sigma' , 963, + 'tau' , 964, + 'upsilon' , 965, + 'phi' , 966, + 'chi' , 967, + 'psi' , 968, + 'omega' , 969, + 'thetasym' , 977, + 'upsih' , 978, + 'piv' , 982, + 'bull' , 8226, + 'hellip' , 8230, + 'prime' , 8242, + 'Prime' , 8243, + 'oline' , 8254, + 'frasl' , 8260, + 'weierp' , 8472, + 'image' , 8465, + 'real' , 8476, + 'trade' , 8482, + 'alefsym' , 8501, + 'larr' , 8592, + 'uarr' , 8593, + 'rarr' , 8594, + 'darr' , 8595, + 'harr' , 8596, + 'crarr' , 8629, + 'lArr' , 8656, + 'uArr' , 8657, + 'rArr' , 8658, + 'dArr' , 8659, + 'hArr' , 8660, + 'forall' , 8704, + 'part' , 8706, + 'exist' , 8707, + 'empty' , 8709, + 'nabla' , 8711, + 'isin' , 8712, + 'notin' , 8713, + 'ni' , 8715, + 'prod' , 8719, + 'sum' , 8721, + 'minus' , 8722, + 'lowast' , 8727, + 'radic' , 8730, + 'prop' , 8733, + 'infin' , 8734, + 'ang' , 8736, + 'and' , 8743, + 'or' , 8744, + 'cap' , 8745, + 'cup' , 8746, + 'int' , 8747, + 'there4' , 8756, + 'sim' , 8764, + 'cong' , 8773, + 'asymp' , 8776, + 'ne' , 8800, + 'equiv' , 8801, + 'le' , 8804, + 'ge' , 8805, + 'sub' , 8834, + 'sup' , 8835, + 'nsub' , 8836, + 'sube' , 8838, + 'supe' , 8839, + 'oplus' , 8853, + 'otimes' , 8855, + 'perp' , 8869, + 'sdot' , 8901, + 'lceil' , 8968, + 'rceil' , 8969, + 'lfloor' , 8970, + 'rfloor' , 8971, + 'lang' , 9001, + 'rang' , 9002, + 'loz' , 9674, + 'spades' , 9824, + 'clubs' , 9827, + 'hearts' , 9829, + 'diams' , 9830, + 'OElig' , 338, + 'oelig' , 339, + 'Scaron' , 352, + 'scaron' , 353, + 'Yuml' , 376, + 'circ' , 710, + 'tilde' , 732, + 'ensp' , 8194, + 'emsp' , 8195, + 'thinsp' , 8201, + 'zwnj' , 8204, + 'zwj' , 8205, + 'lrm' , 8206, + 'rlm' , 8207, + 'ndash' , 8211, + 'mdash' , 8212, + 'lsquo' , 8216, + 'rsquo' , 8217, + 'sbquo' , 8218, + 'ldquo' , 8220, + 'rdquo' , 8221, + 'bdquo' , 8222, + 'dagger' , 8224, + 'Dagger' , 8225, + 'permil' , 8240, + 'lsaquo' , 8249, + 'rsaquo' , 8250, + 'euro' , 8364, +); + + +# Fill out %Name2character... +{ + %Name2character = (); + my($name, $number); + while( ($name, $number) = each %Name2character_number) { + if($] < 5.007 and $number > 255) { + $Name2character{$name} = $FAR_CHAR; + # substitute for Unicode characters, for perls + # that can't reliably handle them + } elsif ($] >= 5.007003) { + $Name2character{$name} = chr utf8::unicode_to_native($number); + # normal case for more recent Perls where we can translate from Unicode + # to the native character set. + } + elsif (exists $Code2USASCII{$number}) { + $Name2character{$name} = $Code2USASCII{$number}; + # on older Perls, we can use the translations we have hard-coded in this + # file, but these don't include the non-ASCII-range characters + } + elsif ($NOT_ASCII && $number > 127 && $number < 256) { + # this range on old non-ASCII-platform perls is wrong + if (exists $Latin1Code_to_fallback{$number}) { + $Name2character{$name} = $Latin1Code_to_fallback{$number}; + } else { + $Name2character{$name} = $FAR_CHAR; + } + } else { + $Name2character{$name} = chr $number; + } + } +} + +#-------------------------------------------------------------------------- +1; +__END__ + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# What I used for reading the XHTML .ent files: + +my(@norms, @good, @bad); +my $dir = 'c:/sgml/docbook/'; +my %escapes; +foreach my $file (qw( + xhtml-symbol.ent + xhtml-lat1.ent + xhtml-special.ent +)) { + open(IN, "<$dir$file") or die "can't read-open $dir$file: $!"; + print "Reading $file...\n"; + while() { + if(m//) { + my($name, $value) = ($1,$2); + next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt'; + + $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s; + print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s; + if($value > 255) { + push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value; + push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value; + } else { + push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value; + } + } elsif(m/ 0) { + ## Too many arguments - assume that this is a hash and + ## the user forgot to pass a reference to it. + %opts = ($_, @_); + } + elsif (!defined $_) { + $_ = ''; + } + elsif (ref $_) { + ## User passed a ref to a hash + %opts = %{$_} if (ref($_) eq 'HASH'); + } + elsif (/^[-+]?\d+$/) { + ## User passed in the exit value to use + $opts{'-exitval'} = $_; + } + else { + ## User passed in a message to print before issuing usage. + $_ and $opts{'-message'} = $_; + } + + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + %opts = map { + my ($key, $val) = ($_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-msg/i and $key = '-message'; + $key =~ /^-exit/i and $key = '-exitval'; + lc($key) => $val; + } (keys %opts); + + ## Now determine default -exitval and -verbose values to use + if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) { + $opts{'-exitval'} = 2; + $opts{'-verbose'} = 0; + } + elsif (! defined $opts{'-exitval'}) { + $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2; + } + elsif (! defined $opts{'-verbose'}) { + $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2); + } + + ## Default the output file + $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' || + $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR + unless (defined $opts{'-output'}); + ## Default the input file + $opts{'-input'} = $0 unless (defined $opts{'-input'}); + + ## Look up input file in path if it doesn't exist. + unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) { + my $basename = $opts{'-input'}; + my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';' + : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':'); + my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB}; + + my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); + for my $dirname (@paths) { + $_ = File::Spec->catfile($dirname, $basename) if length; + last if (-e $_) && ($opts{'-input'} = $_); + } + } + + ## Now create a pod reader and constrain it to the desired sections. + my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); + if ($opts{'-verbose'} == 0) { + $parser->select('(?:SYNOPSIS|USAGE)\s*'); + } + elsif ($opts{'-verbose'} == 1) { + my $opt_re = '(?i)' . + '(?:OPTIONS|ARGUMENTS)' . + '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; + $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" ); + } + elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) { + $parser->select('.*'); + } + elsif ($opts{'-verbose'} == 99) { + my $sections = $opts{'-sections'}; + $parser->select( (ref $sections) ? @$sections : $sections ); + $opts{'-verbose'} = 1; + } + + ## Check for perldoc + my $progpath = $opts{'-perldoc'} ? $opts{'-perldoc'} : + File::Spec->catfile($Config{scriptdirexp} + || $Config{scriptdir}, 'perldoc'); + + my $version = sprintf("%vd",$^V); + if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) { + $progpath .= $version; + } + $opts{'-noperldoc'} = 1 unless -e $progpath; + + ## Now translate the pod document and then exit with the desired status + if ( !$opts{'-noperldoc'} + and $opts{'-verbose'} >= 2 + and !ref($opts{'-input'}) + and $opts{'-output'} == \*STDOUT ) + { + ## spit out the entire PODs. Might as well invoke perldoc + print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'}); + if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { + # the perldocs back to 5.005 should all have -F + # without -F there are warnings in -T scripts + my $f = $1; + my @perldoc_cmd = ($progpath); + if ($opts{'-perldocopt'}) { + $opts{'-perldocopt'} =~ s/^\s+|\s+$//g; + push @perldoc_cmd, split(/\s+/, $opts{'-perldocopt'}); + } + push @perldoc_cmd, ('-F', $f); + unshift @perldoc_cmd, $opts{'-perlcmd'} if $opts{'-perlcmd'}; + system(@perldoc_cmd); + if($?) { + # RT16091: fall back to more if perldoc failed + system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); + } + } else { + croak "Unspecified input file or insecure argument.\n"; + } + } + else { + $parser->parse_from_file($opts{'-input'}, $opts{'-output'}); + } + + exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit'); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + if ($self->can('initialize')) { + $self->initialize(); + } else { + # pass through options to Pod::Text + my %opts; + for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) { + my $val = $params{USAGE_OPTIONS}{"-$_"}; + $opts{$_} = $val if defined $val; + } + $self = $self->SUPER::new(%opts); + %$self = (%$self, %params); + } + return $self; +} + +# This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to +# allow the ejection of Pod::Select from the core without breaking Pod::Usage. +# -- rjbs, 2013-03-18 +sub _compile_section_spec { + my ($section_spec) = @_; + my (@regexs, $negated); + + ## Compile the spec into a list of regexs + local $_ = $section_spec; + s{\\\\}{\001}g; ## handle escaped backward slashes + s{\\/}{\002}g; ## handle escaped forward slashes + + ## Parse the regexs for the heading titles + @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); + + ## Set default regex for ommitted levels + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regexs[$i] = '.*' unless ((defined $regexs[$i]) + && (length $regexs[$i])); + } + ## Modify the regexs as needed and validate their syntax + my $bad_regexs = 0; + for (@regexs) { + $_ .= '.+' if ($_ eq '!'); + s{\001}{\\\\}g; ## restore escaped backward slashes + s{\002}{\\/}g; ## restore escaped forward slashes + $negated = s/^\!//; ## check for negation + eval "m{$_}"; ## check regex syntax + if ($@) { + ++$bad_regexs; + carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; + } + else { + ## Add the forward and rear anchors (and put the negator back) + $_ = '^' . $_ unless (/^\^/); + $_ = $_ . '$' unless (/\$$/); + $_ = '!' . $_ if ($negated); + } + } + return (! $bad_regexs) ? [ @regexs ] : undef; +} + +sub select { + my ($self, @sections) = @_; + if ($ISA[0]->can('select')) { + $self->SUPER::select(@sections); + } else { + # we're using Pod::Simple - need to mimic the behavior of Pod::Select + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; + ## Reset the set of sections to use + unless (@sections) { + delete $self->{USAGE_SELECT} unless ($add); + return; + } + $self->{USAGE_SELECT} = [] + unless ($add && $self->{USAGE_SELECT}); + my $sref = $self->{USAGE_SELECT}; + ## Compile each spec + for my $spec (@sections) { + my $cs = _compile_section_spec($spec); + if ( defined $cs ) { + ## Store them in our sections array + push(@$sref, $cs); + } else { + carp qq{Ignoring section spec "$spec"!\n}; + } + } + } +} + +# Override Pod::Text->seq_i to return just "arg", not "*arg*". +sub seq_i { return $_[1] } +# Override Pod::Text->cmd_i to return just "arg", not "*arg*". +# newer version based on Pod::Simple +sub cmd_i { return $_[2] } + +# This overrides the Pod::Text method to do something very akin to what +# Pod::Select did as well as the work done below by preprocess_paragraph. +# Note that the below is very, very specific to Pod::Text and Pod::Simple. +sub _handle_element_end { + my ($self, $element) = @_; + if ($element eq 'head1') { + $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ]; + if ($self->{USAGE_OPTIONS}->{-verbose} < 2) { + $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; + } + } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0 + my $idx = $1 - 1; + $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); + $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; + # we have to get rid of the lower headings + splice(@{$self->{USAGE_HEADINGS}},$idx+1); + } + if ($element =~ /^head\d+$/) { + $$self{USAGE_SKIPPING} = 1; + if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) { + $$self{USAGE_SKIPPING} = 0; + } else { + my @headings = @{$$self{USAGE_HEADINGS}}; + for my $section_spec ( @{$$self{USAGE_SELECT}} ) { + my $match = 1; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $headings[$i] = '' unless defined $headings[$i]; + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } # end heading levels + if ($match) { + $$self{USAGE_SKIPPING} = 0; + last; + } + } # end sections + } + + # Try to do some lowercasing instead of all-caps in headings, and use + # a colon to end all headings. + if($self->{USAGE_OPTIONS}->{-verbose} < 2) { + local $_ = $$self{PENDING}[-1][1]; + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + $$self{PENDING}[-1][1] = $_; + } + } + if ($$self{USAGE_SKIPPING} && $element !~ m/^over-|^[BCFILSZ]$/) { + pop @{ $$self{PENDING} }; + } else { + $self->SUPER::_handle_element_end($element); + } +} + +# required for Pod::Simple API +sub start_document { + my $self = shift; + $self->SUPER::start_document(); + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_fh(); + print $out_fh "$msg\n"; +} + +# required for old Pod::Parser API +sub begin_pod { + my $self = shift; + $self->SUPER::begin_pod(); ## Have to call superclass + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_handle(); + print $out_fh "$msg\n"; +} + +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + my $line = shift; + ## See if this is a heading and we aren't printing the entire manpage. + if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { + ## Change the title of the SYNOPSIS section to USAGE + s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; + ## Try to do some lowercasing instead of all-caps in headings + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + ## Use a colon to end all headings + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + } + return $self->SUPER::preprocess_paragraph($_); +} + +1; # keep require happy + +__END__ + + +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal +# +# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code +# from Nick Ing-Simmon's PodToHtml). All rights reserved. +# This file is part of "PodParser". Pod::Find is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Find; +use strict; + +use vars qw($VERSION); +$VERSION = '1.63'; ## Current version of this package +require 5.005; ## requires this Perl version or later +use Carp; + +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} + +############################################################################# + + +#use diagnostics; +use Exporter; +use File::Spec; +use File::Find; +use Cwd qw(abs_path cwd); + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); + +# package global variables +my $SIMPLIFY_RX; + + +# return a hash of the POD files found +# first argument may be a hashref (options), +# rest is a list of directories to search recursively +sub pod_find +{ + my %opts; + if(ref $_[0]) { + %opts = %{shift()}; + } + + $opts{-verbose} ||= 0; + $opts{-perl} ||= 0; + + my (@search) = @_; + + if($opts{-script}) { + require Config; + push(@search, $Config::Config{scriptdir}) + if -d $Config::Config{scriptdir}; + $opts{-perl} = 1; + } + + if($opts{-inc}) { + if ($^O eq 'MacOS') { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { + $_ = ':'. $_; + } else { + $_ =~ s{^\./}{:}; + } + } + push(@search, grep($_ ne File::Spec->curdir, @new_INC)); + } else { + my %seen; + my $curdir = File::Spec->curdir; + foreach(@INC) { + next if $_ eq $curdir; + my $path = abs_path($_); + push(@search, $path) unless $seen{$path}++; + } + } + + $opts{-perl} = 1; + } + + if($opts{-perl}) { + require Config; + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" (from 'archname') + # * remove e.g. 5.00503 + # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) + + # Mac OS: + # * remove ":?site_perl:" + # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) + + if ($^O eq 'MacOS') { + $SIMPLIFY_RX = + qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; + } else { + $SIMPLIFY_RX = + qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; + } + } + + my %dirs_visited; + my %pods; + my %names; + my $pwd = cwd(); + + foreach my $try (@search) { + unless(File::Spec->file_name_is_absolute($try)) { + # make path absolute + $try = File::Spec->catfile($pwd,$try); + } + # simplify path + # on VMS canonpath will vmsify:[the.path], but File::Find::find + # wants /unixy/paths + if ($^O eq 'VMS') { + $try = VMS::Filespec::unixify($try); + } + else { + $try = File::Spec->canonpath($try); + } + my $name; + if(-f $try) { + if($name = _check_and_extract_name($try, $opts{-verbose})) { + _check_for_duplicates($try, $name, \%names, \%pods); + } + next; + } + my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!; + $root_rx=~ s|//$|/|; # remove trailing double slash + File::Find::find( sub { + my $item = $File::Find::name; + if(-d) { + if($item =~ m{/(?:RCS|CVS|SCCS|\.svn|\.hg|\.git|\.sync)$}) { + $File::Find::prune = 1; + return; + } + elsif($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { + $File::Find::prune = 1; + warn "Perl $] version mismatch on $_, skipping.\n" + if($opts{-verbose}); + } + return; + } + if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { + _check_for_duplicates($item, $name, \%names, \%pods); + } + }, $try); # end of File::Find::find + } + chdir $pwd; + return %pods; +} + +sub _check_for_duplicates { + my ($file, $name, $names_ref, $pods_ref) = @_; + if($$names_ref{$name}) { + warn "Duplicate POD found (shadowing?): $name ($file)\n"; + warn ' Already seen in ', + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + } + else { + $$names_ref{$name} = 1; + } + return $$pods_ref{$file} = $name; +} + +sub _check_and_extract_name { + my ($file, $verbose, $root_rx) = @_; + + # check extension or executable flag + # this involves testing the .bat extension on Win32! + unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { + return; + } + + return unless contains_pod($file,$verbose); + + # strip non-significant path components + # TODO what happens on e.g. Win32? + my $name = $file; + if(defined $root_rx) { + $name =~ s/$root_rx//is; + $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX); + } + else { + if ($^O eq 'MacOS') { + $name =~ s/^.*://s; + } else { + $name =~ s{^.*/}{}s; + } + } + _simplify($name); + $name =~ s{/+}{::}g; + if ($^O eq 'MacOS') { + $name =~ s{:+}{::}g; # : -> :: + } else { + $name =~ s{/+}{::}g; # / -> :: + } + return $name; +} + + +# basic simplification of the POD name: +# basename & strip extension +sub simplify_name { + my ($str) = @_; + # remove all path components + if ($^O eq 'MacOS') { + $str =~ s/^.*://s; + } else { + $str =~ s{^.*/}{}s; + } + _simplify($str); + return $str; +} + +# internal sub only +sub _simplify { + # strip Perl's own extensions + $_[0] =~ s/\.(pod|pm|plx?)\z//i; + # strip meaningless extensions on Win32 and OS/2 + $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); + # strip meaningless extensions on VMS + $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); +} + +# contribution from Tim Jenness + + +sub pod_where { + + # default options + my %options = ( + '-inc' => 0, + '-verbose' => 0, + '-dirs' => [ File::Spec->curdir ], + ); + + # Check for an options hash as first argument + if (defined $_[0] && ref($_[0]) eq 'HASH') { + my $opt = shift; + + # Merge default options with supplied options + %options = (%options, %$opt); + } + + # Check usage + carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); + + # Read argument + my $pod = shift; + + # Split on :: and then join the name together using File::Spec + my @parts = split (/::/, $pod); + + # Get full directory list + my @search_dirs = @{ $options{'-dirs'} }; + + if ($options{'-inc'}) { + + require Config; + + # Add @INC + if ($^O eq 'MacOS' && $options{'-inc'}) { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { + $_ = ':'. $_; + } else { + $_ =~ s{^\./}{:}; + } + } + push (@search_dirs, @new_INC); + } elsif ($options{'-inc'}) { + push (@search_dirs, @INC); + } + + # Add location of pod documentation for perl man pages (eg perlfunc) + # This is a pod directory in the private install tree + #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, + # 'pod'); + #push (@search_dirs, $perlpoddir) + # if -d $perlpoddir; + + # Add location of binaries such as pod2text + push (@search_dirs, $Config::Config{'scriptdir'}) + if -d $Config::Config{'scriptdir'}; + } + + warn 'Search path is: '.join(' ', @search_dirs)."\n" + if $options{'-verbose'}; + + # Loop over directories + Dir: foreach my $dir ( @search_dirs ) { + + # Don't bother if can't find the directory + if (-d $dir) { + warn "Looking in directory $dir\n" + if $options{'-verbose'}; + + # Now concatenate this directory with the pod we are searching for + my $fullname = File::Spec->catfile($dir, @parts); + $fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS'; + warn "Filename is now $fullname\n" + if $options{'-verbose'}; + + # Loop over possible extensions + foreach my $ext ('', '.pod', '.pm', '.pl') { + my $fullext = $fullname . $ext; + if (-f $fullext && + contains_pod($fullext, $options{'-verbose'}) ) { + warn "FOUND: $fullext\n" if $options{'-verbose'}; + return $fullext; + } + } + } else { + warn "Directory $dir does not exist\n" + if $options{'-verbose'}; + next Dir; + } + # for some strange reason the path on MacOS/darwin/cygwin is + # 'pods' not 'pod' + # this could be the case also for other systems that + # have a case-tolerant file system, but File::Spec + # does not recognize 'darwin' yet. And cygwin also has "pods", + # but is not case tolerant. Oh well... + if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) + && -d File::Spec->catdir($dir,'pods')) { + $dir = File::Spec->catdir($dir,'pods'); + redo Dir; + } + if(-d File::Spec->catdir($dir,'pod')) { + $dir = File::Spec->catdir($dir,'pod'); + redo Dir; + } + } + # No match; + return; +} + + +sub contains_pod { + my $file = shift; + my $verbose = 0; + $verbose = shift if @_; + + # check for one line of POD + my $podfh; + if ($] < 5.006) { + $podfh = gensym(); + } + + unless(open($podfh,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return; + } + + local $/ = undef; + my $pod = <$podfh>; + close($podfh) || die "Error closing $file: $!\n"; + unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { + warn "No POD in $file, skipping.\n" + if($verbose); + return 0; + } + + return 1; +} + + +1; + +package Pod::Functions; +use strict; + + +our $VERSION = '1.13'; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); + +our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order); + +foreach ( + [String => 'Functions for SCALARs or strings'], + [Regexp => 'Regular expressions and pattern matching'], + [Math => 'Numeric functions'], + [ARRAY => 'Functions for real @ARRAYs'], + [LIST => 'Functions for list data'], + [HASH => 'Functions for real %HASHes'], + ['I/O' => 'Input and output functions'], + [Binary => 'Functions for fixed-length data or records'], + [File => 'Functions for filehandles, files, or directories'], + [Flow => 'Keywords related to the control flow of your Perl program'], + [Namespace => 'Keywords related to scoping'], + [Misc => 'Miscellaneous functions'], + [Process => 'Functions for processes and process groups'], + [Modules => 'Keywords related to Perl modules'], + [Objects => 'Keywords related to classes and object-orientation'], + [Socket => 'Low-level socket functions'], + [SysV => 'System V interprocess communication functions'], + [User => 'Fetching user and group info'], + [Network => 'Fetching network info'], + [Time => 'Time-related functions'], + ) { + push @Type_Order, $_->[0]; + $Type_Description{$_->[0]} = $_->[1]; +}; + +while () { + chomp; + s/^#.*//; + next unless $_; + my($name, @data) = split "\t", $_; + $Flavor{$name} = pop @data; + $Type{$name} = join ',', @data; + for my $t (@data) { + push @{$Kinds{$t}}, $name; + } +} + +close DATA; + +my( $typedesc, $list ); +unless (caller) { + foreach my $type ( @Type_Order ) { + $list = join(", ", sort @{$Kinds{$type}}); + $typedesc = $Type_Description{$type} . ":"; + write; + } +} + +format = + +^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc + ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $list +. + +1; + +__DATA__ +-X File a file test (-r, -x, etc) +abs Math absolute value function +accept Socket accept an incoming socket connect +alarm Process schedule a SIGALRM +atan2 Math arctangent of Y/X in the range -PI to PI +bind Socket binds an address to a socket +binmode I/O prepare binary files for I/O +bless Objects create an object +break Flow break out of a C block +caller Flow Namespace get context of the current subroutine call +chdir File change your current working directory +chmod File changes the permissions on a list of files +chomp String remove a trailing record separator from a string +chop String remove the last character from a string +chown File change the ownership on a list of files +chr String get character this number represents +chroot File make directory new root for path lookups +close I/O close file (or pipe or socket) handle +closedir I/O close directory handle +connect Socket connect to a remote socket +continue Flow optional trailing block in a while or foreach +cos Math cosine function +crypt String one-way passwd-style encryption +dbmclose I/O Objects breaks binding on a tied dbm file +dbmopen I/O Objects create binding on a tied dbm file +defined Misc test whether a value, variable, or function is defined +delete HASH deletes a value from a hash +die Flow I/O raise an exception or bail out +do Flow Modules turn a BLOCK into a TERM +dump Flow create an immediate core dump +each ARRAY HASH retrieve the next key/value pair from a hash +endgrent User be done using group file +endhostent User be done using hosts file +endnetent User be done using networks file +endprotoent Network be done using protocols file +endpwent User be done using passwd file +endservent Network be done using services file +eof I/O test a filehandle for its end +eval Flow catch exceptions or compile and run code +evalbytes Flow similar to string eval, but intend to parse a bytestream +exec Process abandon this program to run another +exists HASH test whether a hash key is present +exit Flow terminate this program +exp Math raise I to a power +fc String return casefolded version of a string +fcntl File file control system call +__FILE__ Flow the name of the current source file +fileno I/O return file descriptor from filehandle +flock I/O lock an entire file with an advisory lock +fork Process create a new process just like this one +format I/O declare a picture format with use by the write() function +formline Misc internal function used for formats +getc I/O get the next character from the filehandle +getgrent User get next group record +getgrgid User get group record given group user ID +getgrnam User get group record given group name +gethostbyaddr Network get host record given its address +gethostbyname Network get host record given name +gethostent Network get next hosts record +getlogin User return who logged in at this tty +getnetbyaddr Network get network record given its address +getnetbyname Network get networks record given name +getnetent Network get next networks record +getpeername Socket find the other end of a socket connection +getpgrp Process get process group +getppid Process get parent process ID +getpriority Process get current nice value +getprotobyname Network get protocol record given name +getprotobynumber Network get protocol record numeric protocol +getprotoent Network get next protocols record +getpwent User get next passwd record +getpwnam User get passwd record given user login name +getpwuid User get passwd record given user ID +getservbyname Network get services record given its name +getservbyport Network get services record given numeric port +getservent Network get next services record +getsockname Socket retrieve the sockaddr for a given socket +getsockopt Socket get socket options on a given socket +glob File expand filenames using wildcards +gmtime Time convert UNIX time into record or string using Greenwich time +goto Flow create spaghetti code +grep LIST locate elements in a list test true against a given criterion +hex Math String convert a hexadecimal string to a number +import Modules Namespace patch a module's namespace into your own +index String find a substring within a string +int Math get the integer portion of a number +ioctl File system-dependent device control system call +join LIST join a list into a string using a separator +keys ARRAY HASH retrieve list of indices from a hash +kill Process send a signal to a process or process group +last Flow exit a block prematurely +lc String return lower-case version of a string +lcfirst String return a string with just the next letter in lower case +length String return the number of characters in a string +__LINE__ Flow the current source line number +link File create a hard link in the filesystem +listen Socket register your socket as a server +local Namespace create a temporary value for a global variable (dynamic scoping) +localtime Time convert UNIX time into record or string using local time +lock Misc get a thread lock on a variable, subroutine, or method +log Math retrieve the natural logarithm for a number +lstat File stat a symbolic link +m// Regexp match a string with a regular expression pattern +map LIST apply a change to a list to get back a new list with the changes +mkdir File create a directory +msgctl SysV SysV IPC message control operations +msgget SysV get SysV IPC message queue +msgrcv SysV receive a SysV IPC message from a message queue +msgsnd SysV send a SysV IPC message to a message queue +my Namespace declare and assign a local variable (lexical scoping) +next Flow iterate a block prematurely +no Modules unimport some module symbols or semantics at compile time +oct Math String convert a string to an octal number +open File open a file, pipe, or descriptor +opendir File open a directory +ord String find a character's numeric representation +our Namespace declare and assign a package variable (lexical scoping) +pack Binary String convert a list into a binary representation +package Modules Namespace Objects declare a separate global namespace +__PACKAGE__ Flow the current package +pipe Process open a pair of connected filehandles +pop ARRAY remove the last element from an array and return it +pos Regexp find or set the offset for the last/next m//g search +print I/O output a list to a filehandle +printf I/O output a formatted list to a filehandle +prototype Misc get the prototype (if any) of a subroutine +push ARRAY append one or more elements to an array +q/STRING/ String singly quote a string +qq/STRING/ String doubly quote a string +qr/STRING/ Regexp compile pattern +quotemeta Regexp quote regular expression magic characters +qw/STRING/ LIST quote a list of words +qx/STRING/ Process backquote quote a string +rand Math retrieve the next pseudorandom number +read Binary I/O fixed-length buffered input from a filehandle +readdir I/O get a directory from a directory handle +readline I/O fetch a record from a file +readlink File determine where a symbolic link is pointing +readpipe Process execute a system command and collect standard output +recv Socket receive a message over a Socket +redo Flow start this loop iteration over again +ref Objects find out the type of thing being referenced +rename File change a filename +require Modules load in external functions from a library at runtime +reset Misc clear all variables of a given name +return Flow get out of a function early +reverse LIST String flip a string or a list +rewinddir I/O reset directory handle +rindex String right-to-left substring search +rmdir File remove a directory +s/// Regexp replace a pattern with a string +say I/O output a list to a filehandle, appending a newline +scalar Misc force a scalar context +seek I/O reposition file pointer for random-access I/O +seekdir I/O reposition directory pointer +select File I/O reset default output or do I/O multiplexing +semctl SysV SysV semaphore control operations +semget SysV get set of SysV semaphores +semop SysV SysV semaphore operations +send Socket send a message over a socket +setgrent User prepare group file for use +sethostent Network prepare hosts file for use +setnetent Network prepare networks file for use +setpgrp Process set the process group of a process +setpriority Process set a process's nice value +setprotoent Network prepare protocols file for use +setpwent User prepare passwd file for use +setservent Network prepare services file for use +setsockopt Socket set some socket options +shift ARRAY remove the first element of an array, and return it +shmctl SysV SysV shared memory operations +shmget SysV get SysV shared memory segment identifier +shmread SysV read SysV shared memory +shmwrite SysV write SysV shared memory +shutdown Socket close down just half of a socket connection +sin Math return the sine of a number +sleep Process block for some number of seconds +socket Socket create a socket +socketpair Socket create a pair of sockets +sort LIST sort a list of values +splice ARRAY add or remove elements anywhere in an array +split Regexp split up a string using a regexp delimiter +sprintf String formatted print into a string +sqrt Math square root function +srand Math seed the random number generator +stat File get a file's status information +state Namespace declare and assign a persistent lexical variable +study Regexp no-op, formerly optimized input data for repeated searches +sub Flow declare a subroutine, possibly anonymously +__SUB__ Flow the current subroutine, or C if not in a subroutine +substr String get or alter a portion of a string +symlink File create a symbolic link to a file +syscall Binary I/O execute an arbitrary system call +sysopen File open a file, pipe, or descriptor +sysread Binary I/O fixed-length unbuffered input from a filehandle +sysseek Binary I/O position I/O pointer on handle used with sysread and syswrite +system Process run a separate program +syswrite Binary I/O fixed-length unbuffered output to a filehandle +tell I/O get current seekpointer on a filehandle +telldir I/O get current seekpointer on a directory handle +tie Objects bind a variable to an object class +tied Objects get a reference to the object underlying a tied variable +time Time return number of seconds since 1970 +times Process Time return elapsed time for self and child processes +tr/// String transliterate a string +truncate I/O shorten a file +uc String return upper-case version of a string +ucfirst String return a string with just the next letter in upper case +umask File set file creation mode mask +undef Misc remove a variable or function definition +unlink File remove one link to a file +unpack Binary LIST convert binary structure into normal perl variables +unshift ARRAY prepend more elements to the beginning of a list +untie Objects break a tie binding to a variable +use Modules Namespace Objects load in a module at compile time and import its namespace +utime File set a file's last access and modify times +values ARRAY HASH return a list of the values in a hash +vec Binary test or set particular bits in a string +wait Process wait for any child process to die +waitpid Process wait for a particular child process to die +wantarray Flow get void vs scalar vs list context of current subroutine call +warn I/O print debugging info +write I/O print a picture record +y/// String transliterate a string + +require 5; +package Pod::Simple; +use strict; +use Carp (); +BEGIN { *DEBUG = sub () {0} unless defined &DEBUG } +use integer; +use Pod::Escapes 1.04 (); +use Pod::Simple::LinkSection (); +use Pod::Simple::BlackBox (); +#use utf8; + +use vars qw( + $VERSION @ISA + @Known_formatting_codes @Known_directives + %Known_formatting_codes %Known_directives + $NL +); + +@ISA = ('Pod::Simple::BlackBox'); +$VERSION = '3.35'; + +@Known_formatting_codes = qw(I B C L E F S X Z); +%Known_formatting_codes = map(($_=>1), @Known_formatting_codes); +@Known_directives = qw(head1 head2 head3 head4 item over back); +%Known_directives = map(($_=>'Plain'), @Known_directives); +$NL = $/ unless defined $NL; + +#----------------------------------------------------------------------------- +# Set up some constants: + +BEGIN { + if(defined &ASCII) { } + elsif(chr(65) eq 'A') { *ASCII = sub () {1} } + else { *ASCII = sub () {''} } + + unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} } + DEBUG > 4 and print STDERR "MANY_LINES is ", MANY_LINES(), "\n"; + unless(MANY_LINES() >= 1) { + die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting"; + } + if(defined &UNICODE) { } + elsif($] >= 5.008) { *UNICODE = sub() {1} } + else { *UNICODE = sub() {''} } +} +if(DEBUG > 2) { + print STDERR "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; + print STDERR "# We are under a Unicode-safe Perl.\n"; +} + +# The NO BREAK SPACE and SOFT HYHPEN are used in several submodules. +if ($] ge 5.007_003) { # On sufficiently modern Perls we can handle any + # character set + $Pod::Simple::nbsp = chr utf8::unicode_to_native(0xA0); + $Pod::Simple::shy = chr utf8::unicode_to_native(0xAD); +} +elsif (Pod::Simple::ASCII) { # Hard code ASCII early Perl + $Pod::Simple::nbsp = "\xA0"; + $Pod::Simple::shy = "\xAD"; +} +else { # EBCDIC on early Perl. We know what the values are for the code + # pages supported then. + $Pod::Simple::nbsp = "\x41"; + $Pod::Simple::shy = "\xCA"; +} + +# Design note: +# This is a parser for Pod. It is not a parser for the set of Pod-like +# languages which happens to contain Pod -- it is just for Pod, plus possibly +# some extensions. + +# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ +#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +__PACKAGE__->_accessorize( + 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters + 'source_filename', # Filename of the source, for use in warnings + 'source_dead', # Whether to consider this parser's source dead + + 'output_fh', # The filehandle we're writing to, if applicable. + # Used only in some derived classes. + + 'hide_line_numbers', # For some dumping subclasses: whether to pointedly + # suppress the start_line attribute + + 'line_count', # the current line number + 'pod_para_count', # count of pod paragraphs seen so far + + 'no_whining', # whether to suppress whining + 'no_errata_section', # whether to suppress the errata section + 'complain_stderr', # whether to complain to stderr + + 'doc_has_started', # whether we've fired the open-Document event yet + + 'bare_output', # For some subclasses: whether to prepend + # header-code and postpend footer-code + + 'keep_encoding_directive', # whether to emit =encoding + 'nix_X_codes', # whether to ignore X<...> codes + 'merge_text', # whether to avoid breaking a single piece of + # text up into several events + + 'preserve_whitespace', # whether to try to keep whitespace as-is + 'strip_verbatim_indent', # What indent to strip from verbatim + + 'parse_characters', # Whether parser should expect chars rather than octets + + 'content_seen', # whether we've seen any real Pod content + 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not) + + 'codes_in_verbatim', # for PseudoPod extensions + + 'code_handler', # coderef to call when a code (non-pod) line is seen + 'cut_handler', # ... when a =cut line is seen + 'pod_handler', # ... when a =pod line is seen + 'whiteline_handler', # ... when a line with only whitespace is seen + #Called like: + # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler; + # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler; + # $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler; + # $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler; + 'parse_empty_lists', # whether to acknowledge empty =over/=back blocks + 'raw_mode', # to report entire raw lines instead of Pod elements +); + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub any_errata_seen { # good for using as an exit() value... + return shift->{'errors_seen'} || 0; +} + +sub errata_seen { + return shift->{'all_errata'} || {}; +} + +# Returns the encoding only if it was recognized as being handled and set +sub detected_encoding { + return shift->{'detected_encoding'}; +} + +sub encoding { + my $this = shift; + return $this->{'encoding'} unless @_; # GET. + + $this->_handle_encoding_line("=encoding $_[0]"); + if ($this->{'_processed_encoding'}) { + delete $this->{'_processed_encoding'}; + if(! $this->{'encoding_command_statuses'} ) { + DEBUG > 2 and print STDERR " CRAZY ERROR: encoding wasn't really handled?!\n"; + } elsif( $this->{'encoding_command_statuses'}[-1] ) { + $this->scream( "=encoding $_[0]", + sprintf "Couldn't do %s: %s", + $this->{'encoding_command_reqs' }[-1], + $this->{'encoding_command_statuses'}[-1], + ); + } else { + DEBUG > 2 and print STDERR " (encoding successfully handled.)\n"; + } + return $this->{'encoding'}; + } else { + return undef; + } +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# Pull in some functions that, for some reason, I expect to see here too: +BEGIN { + *pretty = \&Pod::Simple::BlackBox::pretty; + *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub version_report { + my $class = ref($_[0]) || $_[0]; + if($class eq __PACKAGE__) { + return "$class $VERSION"; + } else { + my $v = $class->VERSION; + return "$class $v (" . __PACKAGE__ . " $VERSION)"; + } +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +#sub curr_open { # read-only list accessor +# return @{ $_[0]{'curr_open'} || return() }; +#} +#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] } + + +sub output_string { + # Works by faking out output_fh. Simplifies our code. + # + my $this = shift; + return $this->{'output_string'} unless @_; # GET. + + require Pod::Simple::TiedOutFH; + my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] ); + $$x = '' unless defined $$x; + DEBUG > 4 and print STDERR "# Output string set to $x ($$x)\n"; + $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]); + return + $this->{'output_string'} = $_[0]; + #${ ${ $this->{'output_fh'} } }; +} + +sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} } +sub abandon_output_fh { $_[0]->output_fh(undef) } +# These don't delete the string or close the FH -- they just delete our +# references to it/them. +# TODO: document these + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub new { + # takes no parameters + my $class = ref($_[0]) || $_[0]; + #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc " + # . __PACKAGE__ ); + return bless { + 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, + 'accept_directives' => { %Known_directives }, + 'accept_targets' => {}, + }, $class; +} + + + +# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes. + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { # OVERRIDE IN DERIVED CLASS + my($self, $element_name, $attr_hash_r) = @_; + return; +} + +sub _handle_element_end { # OVERRIDE IN DERIVED CLASS + my($self, $element_name) = @_; + return; +} + +sub _handle_text { # OVERRIDE IN DERIVED CLASS + my($self, $text) = @_; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now directives (not targets) + +sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) } +sub accept_directive_as_data { shift->_accept_directives('Data', @_) } +sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) } + +sub _accept_directives { + my($this, $type) = splice @_,0,2; + foreach my $d (@_) { + next unless defined $d and length $d; + Carp::croak "\"$d\" isn't a valid directive name" + unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; + Carp::croak "\"$d\" is already a reserved Pod directive name" + if exists $Known_directives{$d}; + $this->{'accept_directives'}{$d} = $type; + DEBUG > 2 and print STDERR "Learning to accept \"=$d\" as directive of type $type\n"; + } + DEBUG > 6 and print STDERR "$this\'s accept_directives : ", + pretty($this->{'accept_directives'}), "\n"; + + return sort keys %{ $this->{'accept_directives'} } if wantarray; + return; +} + +#-------------------------------------------------------------------------- +# TODO: document these: + +sub unaccept_directive { shift->unaccept_directives(@_) }; + +sub unaccept_directives { + my $this = shift; + foreach my $d (@_) { + next unless defined $d and length $d; + Carp::croak "\"$d\" isn't a valid directive name" + unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; + Carp::croak "But you must accept \"$d\" directives -- it's a builtin!" + if exists $Known_directives{$d}; + delete $this->{'accept_directives'}{$d}; + DEBUG > 2 and print STDERR "OK, won't accept \"=$d\" as directive.\n"; + } + return sort keys %{ $this->{'accept_directives'} } if wantarray; + return +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now targets (not directives) + +sub accept_target { shift->accept_targets(@_) } # alias +sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias + + +sub accept_targets { shift->_accept_targets('1', @_) } + +sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) } + # forces them to be processed, even when there's no ":". + +sub _accept_targets { + my($this, $type) = splice @_,0,2; + foreach my $t (@_) { + next unless defined $t and length $t; + # TODO: enforce some limitations on what a target name can be? + $this->{'accept_targets'}{$t} = $type; + DEBUG > 2 and print STDERR "Learning to accept \"$t\" as target of type $type\n"; + } + return sort keys %{ $this->{'accept_targets'} } if wantarray; + return; +} + +#-------------------------------------------------------------------------- +sub unaccept_target { shift->unaccept_targets(@_) } + +sub unaccept_targets { + my $this = shift; + foreach my $t (@_) { + next unless defined $t and length $t; + # TODO: enforce some limitations on what a target name can be? + delete $this->{'accept_targets'}{$t}; + DEBUG > 2 and print STDERR "OK, won't accept \"$t\" as target.\n"; + } + return sort keys %{ $this->{'accept_targets'} } if wantarray; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And now codes (not targets or directives) + +# XXX Probably it is an error that the digit '9' is excluded from these re's. +# Broken for early Perls on EBCDIC +my $xml_name_re = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/"; +if (! defined $xml_name_re) { + $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/; +} + +sub accept_code { shift->accept_codes(@_) } # alias + +sub accept_codes { # Add some codes + my $this = shift; + + foreach my $new_code (@_) { + next unless defined $new_code and length $new_code; + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ $xml_name_re + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + + $this->{'accept_codes'}{$new_code} = $new_code; + + # Yes, map to itself -- just so that when we + # see "=extend W [whatever] thatelementname", we say that W maps + # to whatever $this->{accept_codes}{thatelementname} is, + # i.e., "thatelementname". Then when we go re-mapping, + # a "W" in the treelet turns into "thatelementname". We only + # remap once. + # If we say we accept "W", then a "W" in the treelet simply turns + # into "W". + } + + return; +} + +#-------------------------------------------------------------------------- +sub unaccept_code { shift->unaccept_codes(@_) } + +sub unaccept_codes { # remove some codes + my $this = shift; + + foreach my $new_code (@_) { + next unless defined $new_code and length $new_code; + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ $xml_name_re + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + + Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!" + if grep $new_code eq $_, @Known_formatting_codes; + + delete $this->{'accept_codes'}{$new_code}; + + DEBUG > 2 and print STDERR "OK, won't accept the code $new_code<...>.\n"; + } + + return; +} + + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub parse_string_document { + my $self = shift; + my @lines; + foreach my $line_group (@_) { + next unless defined $line_group and length $line_group; + pos($line_group) = 0; + while($line_group =~ + m/([^\n\r]*)(\r?\n?)/g # supports \r, \n ,\r\n + #m/([^\n\r]*)((?:\r?\n)?)/g + ) { + #print(">> $1\n"), + $self->parse_lines($1) + if length($1) or length($2) + or pos($line_group) != length($line_group); + # I.e., unless it's a zero-length "empty line" at the very + # end of "foo\nbar\n" (i.e., between the \n and the EOS). + } + } + $self->parse_lines(undef); # to signal EOF + return $self; +} + +sub _init_fh_source { + my($self, $source) = @_; + + #DEBUG > 1 and print STDERR "Declaring $source as :raw for starters\n"; + #$self->_apply_binmode($source, ':raw'); + #binmode($source, ":raw"); + + return; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. +# + +sub parse_file { + my($self, $source) = (@_); + + if(!defined $source) { + Carp::croak("Can't use empty-string as a source for parse_file"); + } elsif(ref(\$source) eq 'GLOB') { + $self->{'source_filename'} = '' . ($source); + } elsif(ref $source) { + $self->{'source_filename'} = '' . ($source); + } elsif(!length $source) { + Carp::croak("Can't use empty-string as a source for parse_file"); + } else { + { + local *PODSOURCE; + open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!"); + $self->{'source_filename'} = $source; + $source = *PODSOURCE{IO}; + } + $self->_init_fh_source($source); + } + # By here, $source is a FH. + + $self->{'source_fh'} = $source; + + my($i, @lines); + until( $self->{'source_dead'} ) { + splice @lines; + + for($i = MANY_LINES; $i--;) { # read those many lines at a time + local $/ = $NL; + push @lines, scalar(<$source>); # readline + last unless defined $lines[-1]; + # but pass thru the undef, which will set source_dead to true + } + + my $at_eof = ! $lines[-1]; # keep track of the undef + pop @lines if $at_eof; # silence warnings + + # be eol agnostic + s/\r\n?/\n/g for @lines; + + # make sure there are only one line elements for parse_lines + @lines = split(/(?<=\n)/, join('', @lines)); + + # push the undef back after popping it to set source_dead to true + push @lines, undef if $at_eof; + + $self->parse_lines(@lines); + } + delete($self->{'source_fh'}); # so it can be GC'd + return $self; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub parse_from_file { + # An emulation of Pod::Parser's interface, for the sake of Perldoc. + # Basically just a wrapper around parse_file. + + my($self, $source, $to) = @_; + $self = $self->new unless ref($self); # so we tolerate being a class method + + if(!defined $source) { $source = *STDIN{IO} + } elsif(ref(\$source) eq 'GLOB') { # stet + } elsif(ref($source) ) { # stet + } elsif(!length $source + or $source eq '-' or $source =~ m/^<&(?:STDIN|0)$/i + ) { + $source = *STDIN{IO}; + } + + if(!defined $to) { $self->output_fh( *STDOUT{IO} ); + } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to ); + } elsif(ref($to)) { $self->output_fh( $to ); + } elsif(!length $to + or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i + ) { + $self->output_fh( *STDOUT{IO} ); + } elsif($to =~ m/^>&(?:STDERR|2)$/i) { + $self->output_fh( *STDERR{IO} ); + } else { + require Symbol; + my $out_fh = Symbol::gensym(); + DEBUG and print STDERR "Write-opening to $to\n"; + open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!"; + binmode($out_fh) + if $self->can('write_with_binmode') and $self->write_with_binmode; + $self->output_fh($out_fh); + } + + return $self->parse_file($source); +} + +#----------------------------------------------------------------------------- + +sub whine { + #my($self,$line,$complaint) = @_; + my $self = shift(@_); + ++$self->{'errors_seen'}; + if($self->{'no_whining'}) { + DEBUG > 9 and print STDERR "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; + return; + } + push @{$self->{'all_errata'}{$_[0]}}, $_[1]; + return $self->_complain_warn(@_) if $self->{'complain_stderr'}; + return $self->_complain_errata(@_); +} + +sub scream { # like whine, but not suppressible + #my($self,$line,$complaint) = @_; + my $self = shift(@_); + ++$self->{'errors_seen'}; + push @{$self->{'all_errata'}{$_[0]}}, $_[1]; + return $self->_complain_warn(@_) if $self->{'complain_stderr'}; + return $self->_complain_errata(@_); +} + +sub _complain_warn { + my($self,$line,$complaint) = @_; + return printf STDERR "%s around line %s: %s\n", + $self->{'source_filename'} || 'Pod input', $line, $complaint; +} + +sub _complain_errata { + my($self,$line,$complaint) = @_; + if( $self->{'no_errata_section'} ) { + DEBUG > 9 and print STDERR "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; + } else { + DEBUG > 9 and print STDERR "Queuing erratum (at line $line) $complaint\n"; + push @{$self->{'errata'}{$line}}, $complaint + # for a report to be generated later! + } + return 1; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _get_initial_item_type { + # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n" + my($self, $para) = @_; + return $para->[1]{'~type'} if $para->[1]{'~type'}; + + return $para->[1]{'~type'} = 'text' + if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1'; + # Else fall thru to the general case: + return $self->_get_item_type($para); +} + + + +sub _get_item_type { # mutates the item!! + my($self, $para) = @_; + return $para->[1]{'~type'} if $para->[1]{'~type'}; + + + # Otherwise we haven't yet been to this node. Maybe alter it... + + my $content = join "\n", @{$para}[2 .. $#$para]; + + if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) { + # Like: "=item *", "=item * ", "=item" + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + $para->[1]{'~orig_content'} = $content; + return $para->[1]{'~type'} = 'bullet'; + + } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance + + # Like: "=item * Foo bar baz"; + $para->[1]{'~orig_content'} = $content; + $para->[1]{'~_freaky_para_hack'} = $1; + DEBUG > 2 and print STDERR " Tolerating $$para[2] as =item *\\n\\n$1\n"; + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + return $para->[1]{'~type'} = 'bullet'; + + } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) { + # Like: "=item 1.", "=item 123412" + + $para->[1]{'~orig_content'} = $content; + $para->[1]{'number'} = $1; # Yes, stores the number there! + + splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] + return $para->[1]{'~type'} = 'number'; + + } else { + # It's anything else. + return $para->[1]{'~type'} = 'text'; + + } +} + +#----------------------------------------------------------------------------- + +sub _make_treelet { + my $self = shift; # and ($para, $start_line) + my $treelet; + if(!@_) { + return ['']; + } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') { + # Hack so we can pass in fake-o pre-cooked paragraphs: + # just have the first line be a reference to a ['~Top', {}, ...] + # We use this feechure in gen_errata and stuff. + + DEBUG and print STDERR "Applying precooked treelet hack to $_[0][0]\n"; + $treelet = $_[0][0]; + splice @$treelet, 0, 2; # lop the top off + return $treelet; + } else { + $treelet = $self->_treelet_from_formatting_codes(@_); + } + + if( $self->_remap_sequences($treelet) ) { + $self->_treat_Zs($treelet); # Might as well nix these first + $self->_treat_Ls($treelet); # L has to precede E and S + $self->_treat_Es($treelet); + $self->_treat_Ss($treelet); # S has to come after E + + $self->_wrap_up($treelet); # Nix X's and merge texties + + } else { + DEBUG and print STDERR "Formatless treelet gets fast-tracked.\n"; + # Very common case! + } + + splice @$treelet, 0, 2; # lop the top off + + return $treelet; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _wrap_up { + my($self, @stack) = @_; + my $nixx = $self->{'nix_X_codes'}; + my $merge = $self->{'merge_text' }; + return unless $nixx or $merge; + + DEBUG > 2 and print STDERR "\nStarting _wrap_up traversal.\n", + $merge ? (" Merge mode on\n") : (), + $nixx ? (" Nix-X mode on\n") : (), + ; + + + my($i, $treelet); + while($treelet = shift @stack) { + DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n"; + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + DEBUG > 3 and print STDERR " Considering child at $i ", pretty($treelet->[$i]), "\n"; + if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') { + DEBUG > 3 and print STDERR " Nixing X node at $i\n"; + splice(@$treelet, $i, 1); # just nix this node (and its descendants) + # no need to back-update the counter just yet + redo; + + } elsif($merge and $i != 2 and # non-initial + !ref $treelet->[$i] and !ref $treelet->[$i - 1] + ) { + DEBUG > 3 and print STDERR " Merging ", $i-1, + ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n"; + $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0]; + DEBUG > 4 and print STDERR " Now: ", $i-1, ":[$treelet->[$i-1]]\n"; + --$i; + next; + # since we just pulled the possibly last node out from under + # ourselves, we can't just redo() + + } elsif( ref $treelet->[$i] ) { + DEBUG > 4 and print STDERR " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n"; + push @stack, $treelet->[$i]; + + if($treelet->[$i][0] eq 'L') { + my $thing; + foreach my $attrname ('section', 'to') { + if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { + unshift @stack, $thing; + DEBUG > 4 and print STDERR " +Enqueuing ", + pretty( $treelet->[$i][1]{$attrname} ), + " as an attribute value to tweak.\n"; + } + } + } + } + } + } + DEBUG > 2 and print STDERR "End of _wrap_up traversal.\n\n"; + + return; +} + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _remap_sequences { + my($self,@stack) = @_; + + if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) { + # VERY common case: abort it. + DEBUG and print STDERR "Skipping _remap_sequences: formatless treelet.\n"; + return 0; + } + + my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?"); + + my $start_line = $stack[0][1]{'start_line'}; + DEBUG > 2 and printf + "\nAbout to start _remap_sequences on treelet from line %s.\n", + $start_line || '[?]' + ; + DEBUG > 3 and print STDERR " Map: ", + join('; ', map "$_=" . ( + ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_} + ), + sort keys %$map ), + ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map) + ? " (all normal)\n" : "\n" + ; + + # A recursive algorithm implemented iteratively! Whee! + + my($is, $was, $i, $treelet); # scratch + while($treelet = shift @stack) { + DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n"; + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + + DEBUG > 4 and print STDERR " Noting child $i : $treelet->[$i][0]<...>\n"; + + $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] }; + if( DEBUG > 3 ) { + if(!defined $is) { + print STDERR " Code $was<> is UNKNOWN!\n"; + } elsif($is eq $was) { + DEBUG > 4 and print STDERR " Code $was<> stays the same.\n"; + } else { + print STDERR " Code $was<> maps to ", + ref($is) + ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" ) + : "tag $is<...>.\n"; + } + } + + if(!defined $is) { + $self->whine($start_line, "Deleting unknown formatting code $was<>"); + $is = $treelet->[$i][0] = '1'; # But saving the children! + # I could also insert a leading "$was<" and tailing ">" as + # children of this node, but something about that seems icky. + } + if(ref $is) { + my @dynasty = @$is; + DEBUG > 4 and print STDERR " Renaming $was node to $dynasty[-1]\n"; + $treelet->[$i][0] = pop @dynasty; + my $nugget; + while(@dynasty) { + DEBUG > 4 and printf + " Grafting a new %s node between %s and %s\n", + $dynasty[-1], $treelet->[0], $treelet->[$i][0], + ; + + #$nugget = ; + splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]]; + # relace node with a new parent + } + } elsif($is eq '0') { + splice(@$treelet, $i, 1); # just nix this node (and its descendants) + --$i; # back-update the counter + } elsif($is eq '1') { + splice(@$treelet, $i, 1 # replace this node with its children! + => splice @{ $treelet->[$i] },2 + # (not catching its first two (non-child) items) + ); + --$i; # back up for new stuff + } else { + # otherwise it's unremarkable + unshift @stack, $treelet->[$i]; # just recurse + } + } + } + + DEBUG > 2 and print STDERR "End of _remap_sequences traversal.\n\n"; + + if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) { + DEBUG and print STDERR "Noting that the treelet is now formatless.\n"; + return 0; + } + return 1; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _ponder_extend { + + # "Go to an extreme, move back to a more comfortable place" + # -- /Oblique Strategies/, Brian Eno and Peter Schmidt + + my($self, $para) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + + DEBUG > 2 and print STDERR "Ogling extensor: =extend $content\n"; + + if($content =~ + m/^ + (\S+) # 1 : new item + \s+ + (\S+) # 2 : fallback(s) + (?:\s+(\S+))? # 3 : element name(s) + \s* + $ + /xs + ) { + my $new_letter = $1; + my $fallbacks_one = $2; + my $elements_one; + $elements_one = defined($3) ? $3 : $1; + + DEBUG > 2 and print STDERR "Extensor has good syntax.\n"; + + unless($new_letter =~ m/^[A-Z]$/s or $new_letter) { + DEBUG > 2 and print STDERR " $new_letter isn't a valid thing to entend.\n"; + $self->whine( + $para->[1]{'start_line'}, + "You can extend only formatting codes A-Z, not like \"$new_letter\"" + ); + return; + } + + if(grep $new_letter eq $_, @Known_formatting_codes) { + DEBUG > 2 and print STDERR " $new_letter isn't a good thing to extend, because known.\n"; + $self->whine( + $para->[1]{'start_line'}, + "You can't extend an established code like \"$new_letter\"" + ); + + #TODO: or allow if last bit is same? + + return; + } + + unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc. + or $fallbacks_one eq '0' or $fallbacks_one eq '1' + ) { + $self->whine( + $para->[1]{'start_line'}, + "Format for second =extend parameter must be like" + . " M or 1 or 0 or M,N or M,N,O but you have it like " + . $fallbacks_one + ); + return; + } + + unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc. + $self->whine( + $para->[1]{'start_line'}, + "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like " + . $elements_one + ); + return; + } + + my @fallbacks = split ',', $fallbacks_one, -1; + my @elements = split ',', $elements_one, -1; + + foreach my $f (@fallbacks) { + next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1'; + DEBUG > 2 and print STDERR " Can't fall back on unknown code $f\n"; + $self->whine( + $para->[1]{'start_line'}, + "Can't use unknown formatting code '$f' as a fallback for '$new_letter'" + ); + return; + } + + DEBUG > 3 and printf STDERR "Extensor: Fallbacks <%s> Elements <%s>.\n", + @fallbacks, @elements; + + my $canonical_form; + foreach my $e (@elements) { + if(exists $self->{'accept_codes'}{$e}) { + DEBUG > 1 and print STDERR " Mapping '$new_letter' to known extension '$e'\n"; + $canonical_form = $e; + last; # first acceptable elementname wins! + } else { + DEBUG > 1 and print STDERR " Can't map '$new_letter' to unknown extension '$e'\n"; + } + } + + + if( defined $canonical_form ) { + # We found a good N => elementname mapping + $self->{'accept_codes'}{$new_letter} = $canonical_form; + DEBUG > 2 and print + "Extensor maps $new_letter => known element $canonical_form.\n"; + } else { + # We have to use the fallback(s), which might be '0', or '1'. + $self->{'accept_codes'}{$new_letter} + = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks; + DEBUG > 2 and print + "Extensor maps $new_letter => fallbacks @fallbacks.\n"; + } + + } else { + DEBUG > 2 and print STDERR "Extensor has bad syntax.\n"; + $self->whine( + $para->[1]{'start_line'}, + "Unknown =extend syntax: $content" + ) + } + return; +} + + +#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. + +sub _treat_Zs { # Nix Z<...>'s + my($self,@stack) = @_; + + my($i, $treelet); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + while($treelet = shift @stack) { + for($i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + unless($treelet->[$i][0] eq 'Z') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + DEBUG > 1 and print STDERR "Nixing Z node @{$treelet->[$i]}\n"; + + # bitch UNLESS it's empty + unless( @{$treelet->[$i]} == 2 + or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') + ) { + $self->whine( $start_line, "A non-empty Z<>" ); + } # but kill it anyway + + splice(@$treelet, $i, 1); # thereby just nix this node. + --$i; + + } + } + + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +# Quoting perlpodspec: + +# In parsing an L<...> code, Pod parsers must distinguish at least four +# attributes: + +############# Not used. Expressed via the element children plus +############# the value of the "content-implicit" flag. +# First: +# The link-text. If there is none, this must be undef. (E.g., in "L", the link-text is "Perl Functions". In +# "L" and even "L<|Time::HiRes>", there is no link text. Note +# that link text may contain formatting.) +# + +############# The element children +# Second: +# The possibly inferred link-text -- i.e., if there was no real link text, +# then this is the text that we'll infer in its place. (E.g., for +# "L", the inferred link text is "Getopt::Std".) +# + +############# The "to" attribute (which might be text, or a treelet) +# Third: +# The name or URL, or undef if none. (E.g., in "L", the name -- also sometimes called the page -- is +# "perlfunc". In "L", the name is undef.) +# + +############# The "section" attribute (which might be next, or a treelet) +# Fourth: +# The section (AKA "item" in older perlpods), or undef if none. E.g., in +# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this +# is not the same as a manpage section like the "5" in "man 5 crontab". +# "Section Foo" in the Pod sense means the part of the text that's +# introduced by the heading or item whose text is "Foo".) +# +# Pod parsers may also note additional attributes including: +# + +############# The "type" attribute. +# Fifth: +# A flag for whether item 3 (if present) is a URL (like +# "http://lists.perl.org" is), in which case there should be no section +# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or +# possibly a man page name (like "crontab(5)" is). +# + +############# The "raw" attribute that is already there. +# Sixth: +# The raw original L<...> content, before text is split on "|", "/", etc, +# and before E<...> codes are expanded. + + +# For L<...> codes without a "name|" part, only E<...> and Z<> codes may +# occur -- no other formatting codes. That is, authors should not use +# "L>". +# +# Note, however, that formatting codes and Z<>'s can occur in any and all +# parts of an L<...> (i.e., in name, section, text, and url). + +sub _treat_Ls { # Process our dear dear friends, the L<...> sequences + + # L + # L or L + # L or L or L<"sec"> + # L + # L or L + # L or L or L + # L + # L + + my($self,@stack) = @_; + + my($i, $treelet); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + while($treelet = shift @stack) { + for(my $i = 2; $i < @$treelet; ++$i) { + # iterate over children of current tree node + next unless ref $treelet->[$i]; # text nodes are uninteresting + unless($treelet->[$i][0] eq 'L') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + + # By here, $treelet->[$i] is definitely an L node + my $ell = $treelet->[$i]; + DEBUG > 1 and print STDERR "Ogling L node $ell\n"; + + # bitch if it's empty + if( @{$ell} == 2 + or (@{$ell} == 3 and $ell->[2] eq '') + ) { + $self->whine( $start_line, "An empty L<>" ); + $treelet->[$i] = 'L<>'; # just make it a text node + next; # and move on + } + + if( (! ref $ell->[2] && $ell->[2] =~ /\A\s/) + ||(! ref $ell->[-1] && $ell->[-1] =~ /\s\z/) + ) { + $self->whine( $start_line, "L<> starts or ends with whitespace" ); + } + + # Catch URLs: + + # there are a number of possible cases: + # 1) text node containing url: http://foo.com + # -> [ 'http://foo.com' ] + # 2) text node containing url and text: foo|http://foo.com + # -> [ 'foo|http://foo.com' ] + # 3) text node containing url start: mailto:xEfoo.com + # -> [ 'mailto:x', [ E ... ], 'foo.com' ] + # 4) text node containing url start and text: foo|mailto:xEfoo.com + # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ] + # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com + # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ] + # ... etc. + + # anything before the url is part of the text. + # anything after it is part of the url. + # the url text node itself may contain parts of both. + + if (my ($url_index, $text_part, $url_part) = + # grep is no good here; we want to bail out immediately so that we can + # use $1, $2, etc. without having to do the match twice. + sub { + for (2..$#$ell) { + next if ref $ell->[$_]; + next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s; + return ($_, $1, $2); + } + return; + }->() + ) { + $ell->[1]{'type'} = 'url'; + + my @text = @{$ell}[2..$url_index-1]; + push @text, $text_part if defined $text_part; + + my @url = @{$ell}[$url_index+1..$#$ell]; + unshift @url, $url_part; + + unless (@text) { + $ell->[1]{'content-implicit'} = 'yes'; + @text = @url; + } + + $ell->[1]{to} = Pod::Simple::LinkSection->new( + @url == 1 + ? $url[0] + : [ '', {}, @url ], + ); + + splice @$ell, 2, $#$ell, @text; + + next; + } + + # Catch some very simple and/or common cases + if(@{$ell} == 3 and ! ref $ell->[2]) { + my $it = $ell->[2]; + if($it =~ m{^[^/|]+[(][-a-zA-Z0-9]+[)]$}s) { # man sections + # Hopefully neither too broad nor too restrictive a RE + DEBUG > 1 and print STDERR "Catching \"$it\" as manpage link.\n"; + $ell->[1]{'type'} = 'man'; + # This's the only place where man links can get made. + $ell->[1]{'content-implicit'} = 'yes'; + $ell->[1]{'to' } = + Pod::Simple::LinkSection->new( $it ); # treelet! + + next; + } + if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) { + # Extremely forgiving idea of what constitutes a bare + # modulename link like L or even L + DEBUG > 1 and print STDERR "Catching \"$it\" as ho-hum L link.\n"; + $ell->[1]{'type'} = 'pod'; + $ell->[1]{'content-implicit'} = 'yes'; + $ell->[1]{'to' } = + Pod::Simple::LinkSection->new( $it ); # treelet! + next; + } + # else fall thru... + } + + + + # ...Uhoh, here's the real L<...> parsing stuff... + # "With the ill behavior, with the ill behavior, with the ill behavior..." + + DEBUG > 1 and print STDERR "Running a real parse on this non-trivial L\n"; + + + my $link_text; # set to an arrayref if found + my @ell_content = @$ell; + splice @ell_content,0,2; # Knock off the 'L' and {} bits + + DEBUG > 3 and print STDERR " Ell content to start: ", + pretty(@ell_content), "\n"; + + + # Look for the "|" -- only in CHILDREN (not all underlings!) + # Like L + DEBUG > 3 and + print STDERR " Peering at L content for a '|' ...\n"; + for(my $j = 0; $j < @ell_content; ++$j) { + next if ref $ell_content[$j]; + DEBUG > 3 and + print STDERR " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n"; + + if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) { + my @link_text = ($1); # might be 0-length + $ell_content[$j] = $2; # might be 0-length + + DEBUG > 3 and + print STDERR " FOUND a '|' in it. Splitting into [$1] + [$2]\n"; + + if ($link_text[0] =~ m{[|/]}) { + $self->whine( + $start_line, + "alternative text '$link_text[0]' contains non-escaped | or /" + ); + } + + unshift @link_text, splice @ell_content, 0, $j; + # leaving only things at J and after + @ell_content = grep ref($_)||length($_), @ell_content ; + $link_text = [grep ref($_)||length($_), @link_text ]; + DEBUG > 3 and printf + " So link text is %s\n and remaining ell content is %s\n", + pretty($link_text), pretty(@ell_content); + last; + } + } + + + # Now look for the "/" -- only in CHILDREN (not all underlings!) + # And afterward, anything left in @ell_content will be the raw name + # Like L + my $section_name; # set to arrayref if found + DEBUG > 3 and print STDERR " Peering at L-content for a '/' ...\n"; + for(my $j = 0; $j < @ell_content; ++$j) { + next if ref $ell_content[$j]; + DEBUG > 3 and + print STDERR " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n"; + + if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) { + my @section_name = ($2); # might be 0-length + $ell_content[$j] = $1; # might be 0-length + + DEBUG > 3 and + print STDERR " FOUND a '/' in it.", + " Splitting to page [...$1] + section [$2...]\n"; + + push @section_name, splice @ell_content, 1+$j; + # leaving only things before and including J + + @ell_content = grep ref($_)||length($_), @ell_content ; + @section_name = grep ref($_)||length($_), @section_name ; + + # Turn L<.../"foo"> into L<.../foo> + if(@section_name + and !ref($section_name[0]) and !ref($section_name[-1]) + and $section_name[ 0] =~ m/^\"/s + and $section_name[-1] =~ m/\"$/s + and !( # catch weird degenerate case of L<"> ! + @section_name == 1 and $section_name[0] eq '"' + ) + ) { + $section_name[ 0] =~ s/^\"//s; + $section_name[-1] =~ s/\"$//s; + DEBUG > 3 and + print STDERR " Quotes removed: ", pretty(@section_name), "\n"; + } else { + DEBUG > 3 and + print STDERR " No need to remove quotes in ", pretty(@section_name), "\n"; + } + + $section_name = \@section_name; + last; + } + } + + # Turn L<"Foo Bar"> into L + if(!$section_name and @ell_content + and !ref($ell_content[0]) and !ref($ell_content[-1]) + and $ell_content[ 0] =~ m/^\"/s + and $ell_content[-1] =~ m/\"$/s + and !( # catch weird degenerate case of L<"> ! + @ell_content == 1 and $ell_content[0] eq '"' + ) + ) { + $section_name = [splice @ell_content]; + $section_name->[ 0] =~ s/^\"//s; + $section_name->[-1] =~ s/\"$//s; + } + + # Turn L into L. + if(!$section_name and !$link_text and @ell_content + and grep !ref($_) && m/ /s, @ell_content + ) { + $section_name = [splice @ell_content]; + # That's support for the now-deprecated syntax. + # (Maybe generate a warning eventually?) + # Note that it deliberately won't work on L<...|Foo Bar> + } + + + # Now make up the link_text + # L -> L + # L -> L<"Bar"|Bar> + # L -> L<"Bar" in Foo/Foo> + unless($link_text) { + $ell->[1]{'content-implicit'} = 'yes'; + $link_text = []; + push @$link_text, '"', @$section_name, '"' if $section_name; + + if(@ell_content) { + $link_text->[-1] .= ' in ' if $section_name; + push @$link_text, @ell_content; + } + } + + + # And the E resolver will have to deal with all our treeletty things: + + if(@ell_content == 1 and !ref($ell_content[0]) + and $ell_content[0] =~ m{^[^/]+[(][-a-zA-Z0-9]+[)]$}s + ) { + $ell->[1]{'type'} = 'man'; + DEBUG > 3 and print STDERR "Considering this ($ell_content[0]) a man link.\n"; + } else { + $ell->[1]{'type'} = 'pod'; + DEBUG > 3 and print STDERR "Considering this a pod link (not man or url).\n"; + } + + if( defined $section_name ) { + $ell->[1]{'section'} = Pod::Simple::LinkSection->new( + ['', {}, @$section_name] + ); + DEBUG > 3 and print STDERR "L-section content: ", pretty($ell->[1]{'section'}), "\n"; + } + + if( @ell_content ) { + $ell->[1]{'to'} = Pod::Simple::LinkSection->new( + ['', {}, @ell_content] + ); + DEBUG > 3 and print STDERR "L-to content: ", pretty($ell->[1]{'to'}), "\n"; + } + + # And update children to be the link-text: + @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); + + DEBUG > 2 and print STDERR "End of L-parsing for this node $treelet->[$i]\n"; + + unshift @stack, $treelet->[$i]; # might as well recurse + } + } + + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _treat_Es { + my($self,@stack) = @_; + + my($i, $treelet, $content, $replacer, $charnum); + my $start_line = $stack[0][1]{'start_line'}; + + # A recursive algorithm implemented iteratively! Whee! + + + # Has frightening side effects on L nodes' attributes. + + #my @ells_to_tweak; + + while($treelet = shift @stack) { + for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children + next unless ref $treelet->[$i]; # text nodes are uninteresting + if($treelet->[$i][0] eq 'L') { + # SPECIAL STUFF for semi-processed L<>'s + + my $thing; + foreach my $attrname ('section', 'to') { + if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { + unshift @stack, $thing; + DEBUG > 2 and print STDERR " Enqueuing ", + pretty( $treelet->[$i][1]{$attrname} ), + " as an attribute value to tweak.\n"; + } + } + + unshift @stack, $treelet->[$i]; # recurse + next; + } elsif($treelet->[$i][0] ne 'E') { + unshift @stack, $treelet->[$i]; # recurse + next; + } + + DEBUG > 1 and print STDERR "Ogling E node ", pretty($treelet->[$i]), "\n"; + + # bitch if it's empty + if( @{$treelet->[$i]} == 2 + or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') + ) { + $self->whine( $start_line, "An empty E<>" ); + $treelet->[$i] = 'E<>'; # splice in a literal + next; + } + + # bitch if content is weird + unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) { + $self->whine( $start_line, "An E<...> surrounding strange content" ); + $replacer = $treelet->[$i]; # scratch + splice(@$treelet, $i, 1, # fake out a literal + 'E<', + splice(@$replacer,2), # promote its content + '>' + ); + # Don't need to do --$i, as the 'E<' we just added isn't interesting. + next; + } + + DEBUG > 1 and print STDERR "Ogling E<$content>\n"; + + # XXX E<>'s contents *should* be a valid char in the scope of the current + # =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the + # future sometime. + + $charnum = Pod::Escapes::e2charnum($content); + DEBUG > 1 and print STDERR " Considering E<$content> with char ", + defined($charnum) ? $charnum : "undef", ".\n"; + + if(!defined( $charnum )) { + DEBUG > 1 and print STDERR "I don't know how to deal with E<$content>.\n"; + $self->whine( $start_line, "Unknown E content in E<$content>" ); + $replacer = "E<$content>"; # better than nothing + } elsif($charnum >= 255 and !UNICODE) { + $replacer = ASCII ? "\xA4" : "?"; + DEBUG > 1 and print STDERR "This Perl version can't handle ", + "E<$content> (chr $charnum), so replacing with $replacer\n"; + } else { + $replacer = Pod::Escapes::e2char($content); + DEBUG > 1 and print STDERR " Replacing E<$content> with $replacer\n"; + } + + splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho + } + } + + return; +} + + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _treat_Ss { + my($self,$treelet) = @_; + + _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'}; + + # TODO: or a change_nbsp_to_S + # Normalizing nbsp's to S is harder: for each text node, make S content + # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/ + + + return; +} + +sub _change_S_to_nbsp { # a recursive function + # Sanely assumes that the top node in the excursion won't be an S node. + my($treelet, $in_s) = @_; + + my $is_s = ('S' eq $treelet->[0]); + $in_s ||= $is_s; # So in_s is on either by this being an S element, + # or by an ancestor being an S element. + + for(my $i = 2; $i < @$treelet; ++$i) { + if(ref $treelet->[$i]) { + if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) { + my $to_pull_up = $treelet->[$i]; + splice @$to_pull_up,0,2; # ...leaving just its content + splice @$treelet, $i, 1, @$to_pull_up; # Pull up content + $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff + } + } else { + $treelet->[$i] =~ s/\s/$Pod::Simple::nbsp/g if $in_s; + + # Note that if you apply nbsp_for_S to text, and so turn + # "foo S quux" into "foo bar faz quux", you + # end up with something that fails to say "and don't hyphenate + # any part of 'bar baz'". However, hyphenation is such a vexing + # problem anyway, that most Pod renderers just don't render it + # at all. But if you do want to implement hyphenation, I guess + # that you'd better have nbsp_for_S off. + } + } + + return $is_s; +} + +#----------------------------------------------------------------------------- + +sub _accessorize { # A simple-minded method-maker + no strict 'refs'; + foreach my $attrname (@_) { + next if $attrname =~ m/::/; # a hack + *{caller() . '::' . $attrname} = sub { + use strict; + $Carp::CarpLevel = 1, Carp::croak( + "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" + ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + (@_ == 1) ? $_[0]->{$attrname} + : ($_[0]->{$attrname} = $_[1]); + }; + } + # Ya know, they say accessories make the ensemble! + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +#============================================================================= + +sub filter { + my($class, $source) = @_; + my $new = $class->new; + $new->output_fh(*STDOUT{IO}); + + if(ref($source || '') eq 'SCALAR') { + $new->parse_string_document( $$source ); + } elsif(ref($source)) { # it's a file handle + $new->parse_file($source); + } else { # it's a filename + $new->parse_file($source); + } + + return $new; +} + + +#----------------------------------------------------------------------------- + +sub _out { + # For use in testing: Class->_out($source) + # returns the transformation of $source + + my $class = shift(@_); + + my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; + + DEBUG and print STDERR "\n\n", '#' x 76, + "\nAbout to parse source: {{\n$_[0]\n}}\n\n"; + + + my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new; + $parser->hide_line_numbers(1); + + my $out = ''; + $parser->output_string( \$out ); + DEBUG and print STDERR " _out to ", \$out, "\n"; + + $mutor->($parser) if $mutor; + + $parser->parse_string_document( $_[0] ); + # use Data::Dumper; print STDERR Dumper($parser), "\n"; + return $out; +} + + +sub _duo { + # For use in testing: Class->_duo($source1, $source2) + # returns the parse trees of $source1 and $source2. + # Good in things like: &ok( Class->duo(... , ...) ); + + my $class = shift(@_); + + Carp::croak "But $class->_duo is useful only in list context!" + unless wantarray; + + my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; + + Carp::croak "But $class->_duo takes two parameters, not: @_" + unless @_ == 2; + + my(@out); + + while( @_ ) { + my $parser = $class->new; + + push @out, ''; + $parser->output_string( \( $out[-1] ) ); + + DEBUG and print STDERR " _duo out to ", $parser->output_string(), + " = $parser->{'output_string'}\n"; + + $parser->hide_line_numbers(1); + $mutor->($parser) if $mutor; + $parser->parse_string_document( shift( @_ ) ); + # use Data::Dumper; print STDERR Dumper($parser), "\n"; + } + + return @out; +} + + + +#----------------------------------------------------------------------------- +1; +__END__ + +TODO: +A start_formatting_code and end_formatting_code methods, which in the +base class call start_L, end_L, start_C, end_C, etc., if they are +defined. + +have the POD FORMATTING ERRORS section note the localtime, and the +version of Pod::Simple. + +option to delete all Es? +option to scream if under-0x20 literals are found in the input, or +under-E<32> E codes are found in the tree. And ditto \x7f-\x9f + +Option to turn highbit characters into their compromised form? (applies +to E parsing too) + +TODO: BOM/encoding things. + +TODO: ascii-compat things in the XML classes? + +############################################################################# +# Pod/ParseUtils.pm -- helpers for POD parsing and conversion +# +# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::ParseUtils; +use strict; + +use vars qw($VERSION); +$VERSION = '1.63'; ## Current version of this package +require 5.005; ## requires this Perl version or later + + +#----------------------------------------------------------------------------- +# Pod::List +# +# class to hold POD list info (=over, =item, =back) +#----------------------------------------------------------------------------- + +package Pod::List; + +use Carp; + + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-file} ||= 'unknown'; + $self->{-start} ||= 'unknown'; + $self->{-indent} ||= 4; # perlpod: "should be the default" + $self->{_items} = []; + $self->{-type} ||= ''; +} + + +# The POD file name the list appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + + +# The line in the file the node appears +sub start { + return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; +} + + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + + +# The individual =items of this list +sub item { + my ($self,$item) = @_; + if(defined $item) { + push(@{$self->{_items}}, $item); + return $item; + } + else { + return @{$self->{_items}}; + } +} + + +# possibility for parsers/translators to store information about the +# lists's parent object +sub parent { + return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; +} + + +# possibility for parsers/translators to store information about the +# list's object +sub tag { + return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; +} + +#----------------------------------------------------------------------------- +# Pod::Hyperlink +# +# class to manipulate POD hyperlinks (L<>) +#----------------------------------------------------------------------------- + +package Pod::Hyperlink; + + +use Carp; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = +{}; + bless $self, $class; + $self->initialize(); + if(defined $_[0]) { + if(ref($_[0])) { + # called with a list of parameters + %$self = %{$_[0]}; + $self->_construct_text(); + } + else { + # called with L<> contents + return unless($self->parse($_[0])); + } + } + return $self; +} + +sub initialize { + my $self = shift; + $self->{-line} ||= 'undef'; + $self->{-file} ||= 'undef'; + $self->{-page} ||= ''; + $self->{-node} ||= ''; + $self->{-alttext} ||= ''; + $self->{-type} ||= 'undef'; + $self->{_warnings} = []; +} + + +sub parse { + my $self = shift; + local($_) = $_[0]; + # syntax check the link and extract destination + my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); + + $self->{_warnings} = []; + + # collapse newlines with whitespace + s/\s*\n+\s*/ /g; + + # strip leading/trailing whitespace + if(s/^[\s\n]+//) { + $self->warning('ignoring leading whitespace in link'); + } + if(s/[\s\n]+$//) { + $self->warning('ignoring trailing whitespace in link'); + } + unless(length($_)) { + _invalid_link('empty link'); + return; + } + + ## Check for different possibilities. This is tedious and error-prone + # we match all possibilities (alttext, page, section/item) + #warn "DEBUG: link=$_\n"; + + # only page + # problem: a lot of people use (), or (1) or the like to indicate + # man page sections. But this collides with L that is supposed + # to point to an internal function... + my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; + # page name only + if(/^($page_rx)$/o) { + $page = $1; + $type = 'page'; + } + # alttext, page and "section" + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'section'; + $quoted = 1; #... therefore | and / are allowed + } + # alttext and page + elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { + ($alttext, $page) = ($1, $2); + $type = 'page'; + } + # alttext and "section" + elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + $quoted = 1; + } + # page and "section" + elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { + ($page, $node) = ($1, $2); + $type = 'section'; + $quoted = 1; + } + # page and item + elsif(m{^($page_rx)\s*/\s*(.+)$}o) { + ($page, $node) = ($1, $2); + $type = 'item'; + } + # only "section" + elsif(m{^/?"(.+)"$}) { + $node = $1; + $type = 'section'; + $quoted = 1; + } + # only item + elsif(m{^\s*/(.+)$}) { + $node = $1; + $type = 'item'; + } + + # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? + elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { + ($alttext,$node) = ($1,$2); + $type = 'hyperlink'; + } + + # non-standard: Hyperlink + elsif(/^(\w+:[^:\s]\S*)$/i) { + $node = $1; + $type = 'hyperlink'; + } + # alttext, page and item + elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'item'; + } + # alttext and item + elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { + ($alttext, $node) = ($1,$2); + } + # must be an item or a "malformed" section (without "") + else { + $node = $_; + $type = 'item'; + } + # collapse whitespace in nodes + $node =~ s/\s+/ /gs; + + # empty alternative text expands to node name + if(defined $alttext) { + if(!length($alttext)) { + $alttext = $node || $page; + } + } + else { + $alttext = ''; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("(section) in '$page' deprecated"); + } + if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { + $self->warning("node '$node' contains non-escaped | or /"); + } + if($alttext =~ m{[|/]}) { + $self->warning("alternative text '$node' contains non-escaped | or /"); + } + $self->{-page} = $page; + $self->{-node} = $node; + $self->{-alttext} = $alttext; + #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; + $self->{-type} = $type; + $self->_construct_text(); + 1; +} + +sub _construct_text { + my $self = shift; + my $alttext = $self->alttext(); + my $type = $self->type(); + my $section = $self->node(); + my $page = $self->page(); + my $page_ext = ''; + $page =~ s/([(]\w*[)])$// && ($page_ext = $1); + if($alttext) { + $self->{_text} = $alttext; + } + elsif($type eq 'hyperlink') { + $self->{_text} = $section; + } + else { + $self->{_text} = ($section || '') . + (($page && $section) ? ' in ' : '') . + "$page$page_ext"; + } + # for being marked up later + # use the non-standard markers P<> and Q<>, so that the resulting + # text can be parsed by the translators. It's their job to put + # the correct hypertext around the linktext + if($alttext) { + $self->{_markup} = "Q<$alttext>"; + } + elsif($type eq 'hyperlink') { + $self->{_markup} = "Q<$section>"; + } + else { + $self->{_markup} = (!$section ? '' : "Q<$section>") . + ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); + } +} + + +#' retrieve/set markuped text +sub markup { + return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; +} + + +# The complete link's text +sub text { + return $_[0]->{_text}; +} + + +# Set/retrieve warnings +sub warning { + my $self = shift; + if(@_) { + push(@{$self->{_warnings}}, @_); + return @_; + } + return @{$self->{_warnings}}; +} + + +# The line in the file the link appears +sub line { + return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; +} + +# The POD file name the link appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + + +# The POD page the link appears on +sub page { + if (@_ > 1) { + $_[0]->{-page} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-page}; +} + + +# The link destination +sub node { + if (@_ > 1) { + $_[0]->{-node} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-node}; +} + + +# Potential alternative text +sub alttext { + if (@_ > 1) { + $_[0]->{-alttext} = $_[1]; + $_[0]->_construct_text(); + } + return $_[0]->{-alttext}; +} + + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + my $node = $self->node(); + $node =~ s/\|/E/g; + $node =~ s{/}{E}g; + if($self->type() eq 'section') { + $link .= ($link ? '/' : '') . '"' . $node . '"'; + } + elsif($self->type() eq 'hyperlink') { + $link = $self->node(); + } + else { # item + $link .= '/' . $node; + } + } + if($self->alttext()) { + my $text = $self->alttext(); + $text =~ s/\|/E/g; + $text =~ s{/}{E}g; + $link = "$text|$link"; + } + return $link; +} + +sub _invalid_link { + my ($msg) = @_; + # this sets @_ + #eval { die "$msg\n" }; + #chomp $@; + $@ = $msg; # this seems to work, too! + return; +} + +#----------------------------------------------------------------------------- +# Pod::Cache +# +# class to hold POD page details +#----------------------------------------------------------------------------- + +package Pod::Cache; + + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = []; + bless $self, $class; + return $self; +} + + +sub item { + my ($self,%param) = @_; + if(%param) { + my $item = Pod::Cache::Item->new(%param); + push(@$self, $item); + return $item; + } + else { + return @{$self}; + } +} + + +sub find_page { + my ($self,$page) = @_; + foreach(@$self) { + if($_->page() eq $page) { + return $_; + } + } + return; +} + +package Pod::Cache::Item; + + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-nodes} = [] unless(defined $self->{-nodes}); +} + + +# The POD page +sub page { + return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; +} + + +# The POD description, taken out of NAME if present +sub description { + return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; +} + + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + + +# The POD nodes +sub nodes { + my ($self,@nodes) = @_; + if(@nodes) { + push(@{$self->{-nodes}}, @nodes); + return @nodes; + } + else { + return @{$self->{-nodes}}; + } +} + + +sub find_node { + my ($self,$node) = @_; + my @search; + push(@search, @{$self->{-nodes}}) if($self->{-nodes}); + push(@search, @{$self->{-idx}}) if($self->{-idx}); + foreach(@search) { + if($_->[0] eq $node) { + return $_->[1]; # id + } + } + return; +} + + +# The POD index entries +sub idx { + my ($self,@idx) = @_; + if(@idx) { + push(@{$self->{-idx}}, @idx); + return @idx; + } + else { + return @{$self->{-idx}}; + } +} + + +1; +############################################################################# +# Pod/Parser.pm -- package which defines a base class for parsing POD docs. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Parser; +use strict; + +## These "variables" are used as local "glob aliases" for performance +use vars qw($VERSION @ISA %myData %myOpts @input_stack); +$VERSION = '1.63'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + + +############################################################################# + +#use diagnostics; +use Pod::InputObjects; +use Carp; +use Exporter; +BEGIN { + if ($] < 5.006) { + require Symbol; + import Symbol; + } +} +@ISA = qw(Exporter); + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub command { + my ($self, $cmd, $text, $line_num, $pod_para) = @_; + ## Just treat this like a textblock + $self->textblock($pod_para->raw_text(), $line_num, $pod_para); +} + +##--------------------------------------------------------------------------- + + +sub verbatim { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $text; +} + +##--------------------------------------------------------------------------- + + +sub textblock { + my ($self, $text, $line_num, $pod_para) = @_; + my $out_fh = $self->{_OUTPUT}; + print $out_fh $self->interpolate($text, $line_num); +} + +##--------------------------------------------------------------------------- + + +sub interior_sequence { + my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; + ## Just return the raw text of the interior sequence + return $pod_seq->raw_text(); +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub new { + ## Determine if we were called via an object-ref or a classname + my ($this,%params) = @_; + my $class = ref($this) || $this; + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. + my $self = { %params }; + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + $self->initialize(); + return $self; +} + +##--------------------------------------------------------------------------- + + +sub initialize { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + + +sub begin_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + + +sub begin_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + + +sub end_input { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + + +sub end_pod { + #my $self = shift; + #return; +} + +##--------------------------------------------------------------------------- + + +sub preprocess_line { + my ($self, $text, $line_num) = @_; + return $text; +} + +##--------------------------------------------------------------------------- + + +sub preprocess_paragraph { + my ($self, $text, $line_num) = @_; + return $text; +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub parse_text { + my $self = shift; + local $_ = ''; + + ## Get options and set any defaults + my %opts = (ref $_[0]) ? %{ shift() } : (); + my $expand_seq = $opts{'-expand_seq'} || undef; + my $expand_text = $opts{'-expand_text'} || undef; + my $expand_ptree = $opts{'-expand_ptree'} || undef; + + my $text = shift; + my $line = shift; + my $file = $self->input_file(); + my $cmd = ""; + + ## Convert method calls into closures, for our convenience + my $xseq_sub = $expand_seq; + my $xtext_sub = $expand_text; + my $xptree_sub = $expand_ptree; + if (defined $expand_seq and $expand_seq eq 'interior_sequence') { + ## If 'interior_sequence' is the method to use, we have to pass + ## more than just the sequence object, we also need to pass the + ## sequence name and text. + $xseq_sub = sub { + my ($sself, $iseq) = @_; + my $args = join('', $iseq->parse_tree->children); + return $sself->interior_sequence($iseq->name, $args, $iseq); + }; + } + ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; + ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; + ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; + + ## Keep track of the "current" interior sequence, and maintain a stack + ## of "in progress" sequences. + ## + ## NOTE that we push our own "accumulator" at the very beginning of the + ## stack. It's really a parse-tree, not a sequence; but it implements + ## the methods we need so we can use it to gather-up all the sequences + ## and strings we parse. Thus, by the end of our parsing, it should be + ## the only thing left on our stack and all we have to do is return it! + ## + my $seq = Pod::ParseTree->new(); + my @seq_stack = ($seq); + my ($ldelim, $rdelim) = ('', ''); + + ## Iterate over all sequence starts text (NOTE: split with + ## capturing parens keeps the delimiters) + $_ = $text; + my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/; + while ( @tokens ) { + $_ = shift @tokens; + ## Look for the beginning of a sequence + if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) { + ## Push a new sequence onto the stack of those "in-progress" + my $ldelim_orig; + ($cmd, $ldelim_orig) = ($1, $2); + ($ldelim = $ldelim_orig) =~ s/\s+$//; + ($rdelim = $ldelim) =~ tr//; + $seq = Pod::InteriorSequence->new( + -name => $cmd, + -ldelim => $ldelim_orig, -rdelim => $rdelim, + -file => $file, -line => $line + ); + (@seq_stack > 1) and $seq->nested($seq_stack[-1]); + push @seq_stack, $seq; + } + ## Look for sequence ending + elsif ( @seq_stack > 1 ) { + ## Make sure we match the right kind of closing delimiter + my ($seq_end, $post_seq) = ('', ''); + if ( ($ldelim eq '<' and /\A(.*?)(>)/s) + or /\A(.*?)(\s+$rdelim)/s ) + { + ## Found end-of-sequence, capture the interior and the + ## closing the delimiter, and put the rest back on the + ## token-list + $post_seq = substr($_, length($1) + length($2)); + ($_, $seq_end) = ($1, $2); + (length $post_seq) and unshift @tokens, $post_seq; + } + if (length) { + ## In the middle of a sequence, append this text to it, and + ## don't forget to "expand" it if that's what the caller wanted + $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); + $_ .= $seq_end; + } + if (length $seq_end) { + ## End of current sequence, record terminating delimiter + $seq->rdelim($seq_end); + ## Pop it off the stack of "in progress" sequences + pop @seq_stack; + ## Append result to its parent in current parse tree + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) + : $seq); + ## Remember the current cmd-name and left-delimiter + if(@seq_stack > 1) { + $cmd = $seq_stack[-1]->name; + $ldelim = $seq_stack[-1]->ldelim; + $rdelim = $seq_stack[-1]->rdelim; + } else { + $cmd = $ldelim = $rdelim = ''; + } + } + } + elsif (length) { + ## In the middle of a sequence, append this text to it, and + ## don't forget to "expand" it if that's what the caller wanted + $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); + } + ## Keep track of line count + $line += /\n/; + ## Remember the "current" sequence + $seq = $seq_stack[-1]; + } + + ## Handle unterminated sequences + my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; + while (@seq_stack > 1) { + ($cmd, $file, $line) = ($seq->name, $seq->file_line); + $ldelim = $seq->ldelim; + ($rdelim = $ldelim) =~ tr//; + $rdelim =~ s/^(\S+)(\s*)$/$2$1/; + pop @seq_stack; + my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}". + " at line $line in file $file\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $self->$errorsub($errmsg) + or carp($errmsg); + $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); + $seq = $seq_stack[-1]; + } + + ## Return the resulting parse-tree + my $ptree = (pop @seq_stack)->parse_tree; + return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; +} + +##--------------------------------------------------------------------------- + + +sub interpolate { + my($self, $text, $line_num) = @_; + my %parse_opts = ( -expand_seq => 'interior_sequence' ); + my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); + return join '', $ptree->children(); +} + +##--------------------------------------------------------------------------- + + +sub parse_paragraph { + my ($self, $text, $line_num) = @_; + local *myData = $self; ## alias to avoid deref-ing overhead + local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options + local $_; + + ## See if we want to preprocess nonPOD paragraphs as well as POD ones. + my $wantNonPods = $myOpts{'-want_nonPODs'}; + + ## Update cutting status + $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/; + + ## Perform any desired preprocessing if we wanted it this early + $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); + + ## Ignore up until next POD directive if we are cutting + return if $myData{_CUTTING}; + + ## Now we know this is block of text in a POD section! + + ##----------------------------------------------------------------- + ## This is a hook (hack ;-) for Pod::Select to do its thing without + ## having to override methods, but also without Pod::Parser assuming + ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS + ## field exists then we assume there is an is_selected() method for + ## us to invoke (calling $self->can('is_selected') could verify this + ## but that is more overhead than I want to incur) + ##----------------------------------------------------------------- + + ## Ignore this block if it isn't in one of the selected sections + if (exists $myData{_SELECTED_SECTIONS}) { + $self->is_selected($text) or return ($myData{_CUTTING} = 1); + } + + ## If we haven't already, perform any desired preprocessing and + ## then re-check the "cutting" state + unless ($wantNonPods) { + $text = $self->preprocess_paragraph($text, $line_num); + return 1 unless ((defined $text) and (length $text)); + return 1 if ($myData{_CUTTING}); + } + + ## Look for one of the three types of paragraphs + my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); + my $pod_para = undef; + if ($text =~ /^(={1,2})(?=\S)/) { + ## Looks like a command paragraph. Capture the command prefix used + ## ("=" or "=="), as well as the command-name, its paragraph text, + ## and whatever sequence of characters was used to separate them + $pfx = $1; + $_ = substr($text, length $pfx); + ($cmd, $sep, $text) = split /(\s+)/, $_, 2; + $sep = '' unless defined $sep; + $text = '' unless defined $text; + ## If this is a "cut" directive then we don't need to do anything + ## except return to "cutting" mode. + if ($cmd eq 'cut') { + $myData{_CUTTING} = 1; + return unless $myOpts{'-process_cut_cmd'}; + } + } + ## Save the attributes indicating how the command was specified. + $pod_para = new Pod::Paragraph( + -name => $cmd, + -text => $text, + -prefix => $pfx, + -separator => $sep, + -file => $myData{_INFILE}, + -line => $line_num + ); + # ## Invoke appropriate callbacks + # if (exists $myData{_CALLBACKS}) { + # ## Look through the callback list, invoke callbacks, + # ## then see if we need to do the default actions + # ## (invoke_callbacks will return true if we do). + # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); + # } + + # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp + if ($myData{_WHITESPACE} and $myOpts{'-warnings'} + and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) { + my $errorsub = $self->errorsub(); + my $line = $line_num - 1; + my $errmsg = "*** WARNING: line containing nothing but whitespace". + " in paragraph at line $line in file $myData{_INFILE}\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $self->$errorsub($errmsg) + or carp($errmsg); + } + + if (length $cmd) { + ## A command paragraph + $self->command($cmd, $text, $line_num, $pod_para); + $myData{_PREVIOUS} = $cmd; + } + elsif ($text =~ /^\s+/) { + ## Indented text - must be a verbatim paragraph + $self->verbatim($text, $line_num, $pod_para); + $myData{_PREVIOUS} = "verbatim"; + } + else { + ## Looks like an ordinary block of text + $self->textblock($text, $line_num, $pod_para); + $myData{_PREVIOUS} = "textblock"; + } + + # Update the whitespace for the next time around + #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0; + $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0; + + return 1; +} + +##--------------------------------------------------------------------------- + + +sub parse_from_filehandle { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($in_fh, $out_fh) = @_; + $in_fh = \*STDIN unless ($in_fh); + local *myData = $self; ## alias to avoid deref-ing overhead + local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options + local $_; + + ## Put this stream at the top of the stack and do beginning-of-input + ## processing. NOTE that $in_fh might be reset during this process. + my $topstream = $self->_push_input_stream($in_fh, $out_fh); + (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); + + ## Initialize line/paragraph + my ($textline, $paragraph) = ('', ''); + my ($nlines, $plines) = (0, 0); + + ## Use <$fh> instead of $fh->getline where possible (for speed) + $_ = ref $in_fh; + my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); + + ## Read paragraphs line-by-line + while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { + $textline = $self->preprocess_line($textline, ++$nlines); + next unless ((defined $textline) && (length $textline)); + + if ((! length $paragraph) && ($textline =~ /^==/)) { + ## '==' denotes a one-line command paragraph + $paragraph = $textline; + $plines = 1; + $textline = ''; + } else { + ## Append this line to the current paragraph + $paragraph .= $textline; + ++$plines; + } + + ## See if this line is blank and ends the current paragraph. + ## If it isn't, then keep iterating until it is. + next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/) + && (length $paragraph)); + + ## Now process the paragraph + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); + $paragraph = ''; + $plines = 0; + } + ## Don't forget about the last paragraph in the file + if (length $paragraph) { + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) + } + + ## Now pop the input stream off the top of the input stack. + $self->_pop_input_stream(); +} + +##--------------------------------------------------------------------------- + + +sub parse_from_file { + my $self = shift; + my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); + my ($infile, $outfile) = @_; + my ($in_fh, $out_fh); + if ($] < 5.006) { + ($in_fh, $out_fh) = (gensym(), gensym()); + } + my ($close_input, $close_output) = (0, 0); + local *myData = $self; + local *_; + + ## Is $infile a filename or a (possibly implied) filehandle + if (defined $infile && ref $infile) { + if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { + croak "Input from $1 reference not supported!\n"; + } + ## Must be a filehandle-ref (or else assume its a ref to an object + ## that supports the common IO read operations). + $myData{_INFILE} = ${$infile}; + $in_fh = $infile; + } + elsif (!defined($infile) || !length($infile) || ($infile eq '-') + || ($infile =~ /^<&(?:STDIN|0)$/i)) + { + ## Not a filename, just a string implying STDIN + $infile ||= '-'; + $myData{_INFILE} = ''; + $in_fh = \*STDIN; + } + else { + ## We have a filename, open it for reading + $myData{_INFILE} = $infile; + open($in_fh, "< $infile") or + croak "Can't open $infile for reading: $!\n"; + $close_input = 1; + } + + ## NOTE: we need to be *very* careful when "defaulting" the output + ## file. We only want to use a default if this is the beginning of + ## the entire document (but *not* if this is an included file). We + ## determine this by seeing if the input stream stack has been set-up + ## already + + ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? + if (ref $outfile) { + ## we need to check for ref() first, as other checks involve reading + if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { + croak "Output to $1 reference not supported!\n"; + } + elsif (ref($outfile) eq 'SCALAR') { +# # NOTE: IO::String isn't a part of the perl distribution, +# # so probably we shouldn't support this case... +# require IO::String; +# $myData{_OUTFILE} = "$outfile"; +# $out_fh = IO::String->new($outfile); + croak "Output to SCALAR reference not supported!\n"; + } + else { + ## Must be a filehandle-ref (or else assume its a ref to an + ## object that supports the common IO write operations). + $myData{_OUTFILE} = ${$outfile}; + $out_fh = $outfile; + } + } + elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') + || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) + { + if (defined $myData{_TOP_STREAM}) { + $out_fh = $myData{_OUTPUT}; + } + else { + ## Not a filename, just a string implying STDOUT + $outfile ||= '-'; + $myData{_OUTFILE} = ''; + $out_fh = \*STDOUT; + } + } + elsif ($outfile =~ /^>&(STDERR|2)$/i) { + ## Not a filename, just a string implying STDERR + $myData{_OUTFILE} = ''; + $out_fh = \*STDERR; + } + else { + ## We have a filename, open it for writing + $myData{_OUTFILE} = $outfile; + (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; + open($out_fh, "> $outfile") or + croak "Can't open $outfile for writing: $!\n"; + $close_output = 1; + } + + ## Whew! That was a lot of work to set up reasonably/robust behavior + ## in the case of a non-filename for reading and writing. Now we just + ## have to parse the input and close the handles when we're finished. + $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); + + $close_input and + close($in_fh) || croak "Can't close $infile after reading: $!\n"; + $close_output and + close($out_fh) || croak "Can't close $outfile after writing: $!\n"; +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub errorsub { + return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; +} + +##--------------------------------------------------------------------------- + + +sub cutting { + return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; +} + +##--------------------------------------------------------------------------- + +##--------------------------------------------------------------------------- + + +sub parseopts { + local *myData = shift; + local *myOpts = ($myData{_PARSEOPTS} ||= {}); + return %myOpts if (@_ == 0); + if (@_ == 1) { + local $_ = shift; + return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; + } + my @newOpts = (%myOpts, @_); + $myData{_PARSEOPTS} = { @newOpts }; +} + +##--------------------------------------------------------------------------- + + +sub output_file { + return $_[0]->{_OUTFILE}; +} + +##--------------------------------------------------------------------------- + + +sub output_handle { + return $_[0]->{_OUTPUT}; +} + +##--------------------------------------------------------------------------- + + +sub input_file { + return $_[0]->{_INFILE}; +} + +##--------------------------------------------------------------------------- + + +sub input_handle { + return $_[0]->{_INPUT}; +} + +##--------------------------------------------------------------------------- + + +sub input_streams { + return $_[0]->{_INPUT_STREAMS}; +} + +##--------------------------------------------------------------------------- + + +sub top_stream { + return $_[0]->{_TOP_STREAM} || undef; +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub _push_input_stream { + my ($self, $in_fh, $out_fh) = @_; + local *myData = $self; + + ## Initialize stuff for the entire document if this is *not* + ## an included file. + ## + ## NOTE: we need to be *very* careful when "defaulting" the output + ## filehandle. We only want to use a default value if this is the + ## beginning of the entire document (but *not* if this is an included + ## file). + unless (defined $myData{_TOP_STREAM}) { + $out_fh = \*STDOUT unless (defined $out_fh); + $myData{_CUTTING} = 1; ## current "cutting" state + $myData{_INPUT_STREAMS} = []; ## stack of all input streams + } + + ## Initialize input indicators + $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); + $myData{_OUTPUT} = $out_fh if (defined $out_fh); + $in_fh = \*STDIN unless (defined $in_fh); + $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); + $myData{_INPUT} = $in_fh; + my $input_top = $myData{_TOP_STREAM} + = new Pod::InputSource( + -name => $myData{_INFILE}, + -handle => $in_fh, + -was_cutting => $myData{_CUTTING} + ); + local *input_stack = $myData{_INPUT_STREAMS}; + push(@input_stack, $input_top); + + ## Perform beginning-of-document and/or beginning-of-input processing + $self->begin_pod() if (@input_stack == 1); + $self->begin_input(); + + return $input_top; +} + +##--------------------------------------------------------------------------- + + +sub _pop_input_stream { + my ($self) = @_; + local *myData = $self; + local *input_stack = $myData{_INPUT_STREAMS}; + + ## Perform end-of-input and/or end-of-document processing + $self->end_input() if (@input_stack > 0); + $self->end_pod() if (@input_stack == 1); + + ## Restore cutting state to whatever it was before we started + ## parsing this file. + my $old_top = pop(@input_stack); + $myData{_CUTTING} = $old_top->was_cutting(); + + ## Don't forget to reset the input indicators + my $input_top = undef; + if (@input_stack > 0) { + $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; + $myData{_INFILE} = $input_top->name(); + $myData{_INPUT} = $input_top->handle(); + } else { + delete $myData{_TOP_STREAM}; + delete $myData{_INPUT_STREAMS}; + } + + return $input_top; +} + +############################################################################# + + +1; +# vim: ts=4 sw=4 et +package Pod::Html; +use strict; +require Exporter; + +our $VERSION = 1.24; +our @ISA = qw(Exporter); +our @EXPORT = qw(pod2html htmlify); +our @EXPORT_OK = qw(anchorify relativize_url); + +use Carp; +use Config; +use Cwd; +use File::Basename; +use File::Spec; +use File::Spec::Unix; +use Getopt::Long; +use Pod::Simple::Search; +use Pod::Simple::SimpleTree (); +use locale; # make \w work right in non-ASCII lands + + +# This sub duplicates the guts of Pod::Simple::FromTree. We could have +# used that module, except that it would have been a non-core dependency. +sub feed_tree_to_parser { + my($parser, $tree) = @_; + if(ref($tree) eq "") { + $parser->_handle_text($tree); + } elsif(!($tree->[0] eq "X" && $parser->nix_X_codes)) { + $parser->_handle_element_start($tree->[0], $tree->[1]); + feed_tree_to_parser($parser, $_) foreach @{$tree}[2..$#$tree]; + $parser->_handle_element_end($tree->[0]); + } +} + +my $Cachedir; +my $Dircache; +my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl); +my($Podfile, @Podpath, $Podroot); +my $Poderrors; +my $Css; + +my $Recurse; +my $Quiet; +my $Verbose; +my $Doindex; + +my $Backlink; + +my($Title, $Header); + +my %Pages = (); # associative array used to find the location + # of pages referenced by L<> links. + +my $Curdir = File::Spec->curdir; + +init_globals(); + +sub init_globals { + $Cachedir = "."; # The directory to which directory caches + # will be written. + + $Dircache = "pod2htmd.tmp"; + + $Htmlroot = "/"; # http-server base directory from which all + # relative paths in $podpath stem. + $Htmldir = ""; # The directory to which the html pages + # will (eventually) be written. + $Htmlfile = ""; # write to stdout by default + $Htmlfileurl = ""; # The url that other files would use to + # refer to this file. This is only used + # to make relative urls that point to + # other files. + + $Poderrors = 1; + $Podfile = ""; # read from stdin by default + @Podpath = (); # list of directories containing library pods. + $Podroot = $Curdir; # filesystem base directory from which all + # relative paths in $podpath stem. + $Css = ''; # Cascading style sheet + $Recurse = 1; # recurse on subdirectories in $podpath. + $Quiet = 0; # not quiet by default + $Verbose = 0; # not verbose by default + $Doindex = 1; # non-zero if we should generate an index + $Backlink = 0; # no backlinks added by default + $Header = 0; # produce block header/footer + $Title = undef; # title to give the pod(s) +} + +sub pod2html { + local(@ARGV) = @_; + local $_; + + init_globals(); + parse_command_line(); + + # prevent '//' in urls + $Htmlroot = "" if $Htmlroot eq "/"; + $Htmldir =~ s#/\z##; + + if ( $Htmlroot eq '' + && defined( $Htmldir ) + && $Htmldir ne '' + && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir + ) { + # Set the 'base' url for this file, so that we can use it + # as the location from which to calculate relative links + # to other files. If this is '', then absolute links will + # be used throughout. + #$Htmlfileurl = "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1); + # Is the above not just "$Htmlfileurl = $Htmlfile"? + $Htmlfileurl = Pod::Html::_unixify($Htmlfile); + + } + + # load or generate/cache %Pages + unless (get_cache($Dircache, \@Podpath, $Podroot, $Recurse)) { + # generate %Pages + my $pwd = getcwd(); + chdir($Podroot) || + die "$0: error changing to directory $Podroot: $!\n"; + + # find all pod modules/pages in podpath, store in %Pages + # - callback used to remove Podroot and extension from each file + # - laborious to allow '.' in dirnames (e.g., /usr/share/perl/5.14.1) + Pod::Simple::Search->new->inc(0)->verbose($Verbose)->laborious(1) + ->callback(\&_save_page)->recurse($Recurse)->survey(@Podpath); + + chdir($pwd) || die "$0: error changing to directory $pwd: $!\n"; + + # cache the directory list for later use + warn "caching directories for later use\n" if $Verbose; + open my $cache, '>', $Dircache + or die "$0: error open $Dircache for writing: $!\n"; + + print $cache join(":", @Podpath) . "\n$Podroot\n"; + my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/); + foreach my $key (keys %Pages) { + if($_updirs_only) { + my $_dirlevel = $Podroot; + while($_dirlevel =~ /\.\./) { + $_dirlevel =~ s/\.\.//; + # Assume $Pages{$key} has '/' separators (html dir separators). + $Pages{$key} =~ s/^[\w\s\-\.]+\///; + } + } + print $cache "$key $Pages{$key}\n"; + } + + close $cache or die "error closing $Dircache: $!"; + } + + my $input; + unless (@ARGV && $ARGV[0]) { + if ($Podfile and $Podfile ne '-') { + $input = $Podfile; + } else { + $input = '-'; # XXX: make a test case for this + } + } else { + $Podfile = $ARGV[0]; + $input = *ARGV; + } + + # set options for input parser + my $parser = Pod::Simple::SimpleTree->new; + $parser->codes_in_verbatim(0); + $parser->accept_targets(qw(html HTML)); + $parser->no_errata_section(!$Poderrors); # note the inverse + + warn "Converting input file $Podfile\n" if $Verbose; + my $podtree = $parser->parse_file($input)->root; + + unless(defined $Title) { + if($podtree->[0] eq "Document" && ref($podtree->[2]) eq "ARRAY" && + $podtree->[2]->[0] eq "head1" && @{$podtree->[2]} == 3 && + ref($podtree->[2]->[2]) eq "" && $podtree->[2]->[2] eq "NAME" && + ref($podtree->[3]) eq "ARRAY" && $podtree->[3]->[0] eq "Para" && + @{$podtree->[3]} >= 3 && + !(grep { ref($_) ne "" } + @{$podtree->[3]}[2..$#{$podtree->[3]}]) && + (@$podtree == 4 || + (ref($podtree->[4]) eq "ARRAY" && + $podtree->[4]->[0] eq "head1"))) { + $Title = join("", @{$podtree->[3]}[2..$#{$podtree->[3]}]); + } + } + + $Title //= ""; + $Title = html_escape($Title); + + # set options for the HTML generator + $parser = Pod::Simple::XHTML::LocalPodLinks->new(); + $parser->codes_in_verbatim(0); + $parser->anchor_items(1); # the old Pod::Html always did + $parser->backlink($Backlink); # linkify =head1 directives + $parser->force_title($Title); + $parser->htmldir($Htmldir); + $parser->htmlfileurl($Htmlfileurl); + $parser->htmlroot($Htmlroot); + $parser->index($Doindex); + $parser->output_string(\my $output); # written to file later + $parser->pages(\%Pages); + $parser->quiet($Quiet); + $parser->verbose($Verbose); + + # We need to add this ourselves because we use our own header, not + # ::XHTML's header. We need to set $parser->backlink to linkify + # the =head1 directives + my $bodyid = $Backlink ? ' id="_podtop_"' : ''; + + my $csslink = ''; + my $tdstyle = ' style="background-color: #cccccc; color: #000"'; + + if ($Css) { + $csslink = qq(\n); + $csslink =~ s,\\,/,g; + $csslink =~ s,(/.):,$1|,; + $tdstyle= ''; + } + + # header/footer block + my $block = $Header ? < + + $Title + + +END_OF_BLOCK + + # create own header/footer because of --header + $parser->html_header(<<"HTMLHEAD"); + + + + +$Title$csslink + + + + + +$block +HTMLHEAD + + $parser->html_footer(<<"HTMLFOOT"); +$block + + + +HTMLFOOT + + feed_tree_to_parser($parser, $podtree); + + # Write output to file + $Htmlfile = "-" unless $Htmlfile; # stdout + my $fhout; + if($Htmlfile and $Htmlfile ne '-') { + open $fhout, ">", $Htmlfile + or die "$0: cannot open $Htmlfile file for output: $!\n"; + } else { + open $fhout, ">-"; + } + binmode $fhout, ":utf8"; + print $fhout $output; + close $fhout or die "Failed to close $Htmlfile: $!"; + chmod 0644, $Htmlfile unless $Htmlfile eq '-'; +} + +############################################################################## + +sub usage { + my $podfile = shift; + warn "$0: $podfile: @_\n" if @_; + die < --htmlroot= + --infile= --outfile= + --podpath=:...: --podroot= + --cachedir= --flush --recurse --norecurse + --quiet --noquiet --verbose --noverbose + --index --noindex --backlink --nobacklink + --header --noheader --poderrors --nopoderrors + --css= --title= + + --[no]backlink - turn =head1 directives into links pointing to the top of + the page (off by default). + --cachedir - directory for the directory cache files. + --css - stylesheet URL + --flush - flushes the directory cache. + --[no]header - produce block header/footer (default is no headers). + --help - prints this message. + --htmldir - directory for resulting HTML files. + --htmlroot - http-server base directory from which all relative paths + in podpath stem (default is /). + --[no]index - generate an index at the top of the resulting html + (default behaviour). + --infile - filename for the pod to convert (input taken from stdin + by default). + --outfile - filename for the resulting html file (output sent to + stdout by default). + --[no]poderrors - include a POD ERRORS section in the output if there were + any POD errors in the input (default behavior). + --podpath - colon-separated list of directories containing library + pods (empty by default). + --podroot - filesystem base directory from which all relative paths + in podpath stem (default is .). + --[no]quiet - suppress some benign warning messages (default is off). + --[no]recurse - recurse on those subdirectories listed in podpath + (default behaviour). + --title - title that will appear in resulting html file. + --[no]verbose - self-explanatory (off by default). + +END_OF_USAGE + +} + +sub parse_command_line { + my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header, + $opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile, + $opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot, + $opt_quiet,$opt_recurse,$opt_title,$opt_verbose); + + unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; + my $result = GetOptions( + 'backlink!' => \$opt_backlink, + 'cachedir=s' => \$opt_cachedir, + 'css=s' => \$opt_css, + 'flush' => \$opt_flush, + 'help' => \$opt_help, + 'header!' => \$opt_header, + 'htmldir=s' => \$opt_htmldir, + 'htmlroot=s' => \$opt_htmlroot, + 'index!' => \$opt_index, + 'infile=s' => \$opt_infile, + 'outfile=s' => \$opt_outfile, + 'poderrors!' => \$opt_poderrors, + 'podpath=s' => \$opt_podpath, + 'podroot=s' => \$opt_podroot, + 'quiet!' => \$opt_quiet, + 'recurse!' => \$opt_recurse, + 'title=s' => \$opt_title, + 'verbose!' => \$opt_verbose, + ); + usage("-", "invalid parameters") if not $result; + + usage("-") if defined $opt_help; # see if the user asked for help + $opt_help = ""; # just to make -w shut-up. + + @Podpath = split(":", $opt_podpath) if defined $opt_podpath; + + $Backlink = $opt_backlink if defined $opt_backlink; + $Cachedir = _unixify($opt_cachedir) if defined $opt_cachedir; + $Css = $opt_css if defined $opt_css; + $Header = $opt_header if defined $opt_header; + $Htmldir = _unixify($opt_htmldir) if defined $opt_htmldir; + $Htmlroot = _unixify($opt_htmlroot) if defined $opt_htmlroot; + $Doindex = $opt_index if defined $opt_index; + $Podfile = _unixify($opt_infile) if defined $opt_infile; + $Htmlfile = _unixify($opt_outfile) if defined $opt_outfile; + $Poderrors = $opt_poderrors if defined $opt_poderrors; + $Podroot = _unixify($opt_podroot) if defined $opt_podroot; + $Quiet = $opt_quiet if defined $opt_quiet; + $Recurse = $opt_recurse if defined $opt_recurse; + $Title = $opt_title if defined $opt_title; + $Verbose = $opt_verbose if defined $opt_verbose; + + warn "Flushing directory caches\n" + if $opt_verbose && defined $opt_flush; + $Dircache = "$Cachedir/pod2htmd.tmp"; + if (defined $opt_flush) { + 1 while unlink($Dircache); + } +} + +my $Saved_Cache_Key; + +sub get_cache { + my($dircache, $podpath, $podroot, $recurse) = @_; + my @cache_key_args = @_; + + # A first-level cache: + # Don't bother reading the cache files if they still apply + # and haven't changed since we last read them. + + my $this_cache_key = cache_key(@cache_key_args); + return 1 if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key; + $Saved_Cache_Key = $this_cache_key; + + # load the cache of %Pages if possible. $tests will be + # non-zero if successful. + my $tests = 0; + if (-f $dircache) { + warn "scanning for directory cache\n" if $Verbose; + $tests = load_cache($dircache, $podpath, $podroot); + } + + return $tests; +} + +sub cache_key { + my($dircache, $podpath, $podroot, $recurse) = @_; + return join('!',$dircache,$recurse,@$podpath,$podroot,stat($dircache)); +} + +# +# load_cache - tries to find if the cache stored in $dircache is a valid +# cache of %Pages. if so, it loads them and returns a non-zero value. +# +sub load_cache { + my($dircache, $podpath, $podroot) = @_; + my $tests = 0; + local $_; + + warn "scanning for directory cache\n" if $Verbose; + open(my $cachefh, '<', $dircache) || + die "$0: error opening $dircache for reading: $!\n"; + $/ = "\n"; + + # is it the same podpath? + $_ = <$cachefh>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <$cachefh>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close($cachefh); + return 0; + } + + warn "loading directory cache\n" if $Verbose; + while (<$cachefh>) { + /(.*?) (.*)$/; + $Pages{$1} = $2; + } + + close($cachefh); + return 1; +} + + +# +# html_escape: make text safe for HTML +# +sub html_escape { + my $rest = $_[0]; + $rest =~ s/&/&/g; + $rest =~ s//>/g; + $rest =~ s/"/"/g; + $rest =~ s/([[:^print:]])/sprintf("&#x%x;", ord($1))/aeg; + return $rest; +} + +# +# htmlify - converts a pod section specification to a suitable section +# specification for HTML. We adopt the mechanism used by the formatter +# that we use. +# +sub htmlify { + my( $heading) = @_; + return Pod::Simple::XHTML->can("idify")->(undef, $heading, 1); +} + +# +# similar to htmlify, but turns non-alphanumerics into underscores +# +sub anchorify { + my ($anchor) = @_; + $anchor = htmlify($anchor); + $anchor =~ s/\W/_/g; + return $anchor; +} + +# +# store POD files in %Pages +# +sub _save_page { + my ($modspec, $modname) = @_; + + # Remove Podroot from path + $modspec = $Podroot eq File::Spec->curdir + ? File::Spec->abs2rel($modspec) + : File::Spec->abs2rel($modspec, + File::Spec->canonpath($Podroot)); + + # Convert path to unix style path + $modspec = Pod::Html::_unixify($modspec); + + my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext + $Pages{$modname} = $dir.$file; +} + +sub _unixify { + my $full_path = shift; + return '' unless $full_path; + return $full_path if $full_path eq '/'; + + my ($vol, $dirs, $file) = File::Spec->splitpath($full_path); + my @dirs = $dirs eq File::Spec->curdir() + ? (File::Spec::Unix->curdir()) + : File::Spec->splitdir($dirs); + if (defined($vol) && $vol) { + $vol =~ s/:$// if $^O eq 'VMS'; + $vol = uc $vol if $^O eq 'MSWin32'; + + if( $dirs[0] ) { + unshift @dirs, $vol; + } + else { + $dirs[0] = $vol; + } + } + unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path); + return $file unless scalar(@dirs); + $full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs), + $file); + $full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't + $full_path =~ s/\^\././g if $^O eq 'VMS'; # unescape dots + return $full_path; +} + +package Pod::Simple::XHTML::LocalPodLinks; +use strict; +use warnings; +use parent 'Pod::Simple::XHTML'; + +use File::Spec; +use File::Spec::Unix; + +__PACKAGE__->_accessorize( + 'htmldir', + 'htmlfileurl', + 'htmlroot', + 'pages', # Page name => relative/path/to/page from root POD dir + 'quiet', + 'verbose', +); + +sub resolve_pod_page_link { + my ($self, $to, $section) = @_; + + return undef unless defined $to || defined $section; + if (defined $section) { + $section = '#' . $self->idify($section, 1); + return $section unless defined $to; + } else { + $section = ''; + } + + my $path; # path to $to according to %Pages + unless (exists $self->pages->{$to}) { + # Try to find a POD that ends with $to and use that. + # e.g., given L, if there is no $Podpath/XHTML in %Pages, + # look for $Podpath/*/XHTML in %Pages, with * being any path, + # as a substitute (e.g., $Podpath/Pod/Simple/XHTML) + my @matches; + foreach my $modname (keys %{$self->pages}) { + push @matches, $modname if $modname =~ /::\Q$to\E\z/; + } + + if ($#matches == -1) { + warn "Cannot find \"$to\" in podpath: " . + "cannot find suitable replacement path, cannot resolve link\n" + unless $self->quiet; + return ''; + } elsif ($#matches == 0) { + warn "Cannot find \"$to\" in podpath: " . + "using $matches[0] as replacement path to $to\n" + unless $self->quiet; + $path = $self->pages->{$matches[0]}; + } else { + warn "Cannot find \"$to\" in podpath: " . + "more than one possible replacement path to $to, " . + "using $matches[-1]\n" unless $self->quiet; + # Use [-1] so newer (higher numbered) perl PODs are used + $path = $self->pages->{$matches[-1]}; + } + } else { + $path = $self->pages->{$to}; + } + + my $url = File::Spec::Unix->catfile(Pod::Html::_unixify($self->htmlroot), + $path); + + if ($self->htmlfileurl ne '') { + # then $self->htmlroot eq '' (by definition of htmlfileurl) so + # $self->htmldir needs to be prepended to link to get the absolute path + # that will be relativized + $url = Pod::Html::relativize_url( + File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url), + $self->htmlfileurl # already unixified + ); + } + + return $url . ".html$section"; +} + +package Pod::Html; + +# +# relativize_url - convert an absolute URL to one relative to a base URL. +# Assumes both end in a filename. +# +sub relativize_url { + my ($dest, $source) = @_; + + # Remove each file from its path + my ($dest_volume, $dest_directory, $dest_file) = + File::Spec::Unix->splitpath( $dest ); + $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ); + + my ($source_volume, $source_directory, $source_file) = + File::Spec::Unix->splitpath( $source ); + $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ); + + my $rel_path = ''; + if ($dest ne '') { + $rel_path = File::Spec::Unix->abs2rel( $dest, $source ); + } + + if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') { + $rel_path .= "/$dest_file"; + } else { + $rel_path .= "$dest_file"; + } + + return $rel_path; +} + +1; +############################################################################# +# Pod/Select.pm -- function to select portions of POD docs +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Select; +use strict; + +use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); +$VERSION = '1.63'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + + +############################################################################# + +#use diagnostics; +use Carp; +use Pod::Parser 1.04; + +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podselect); + +## Maximum number of heading levels supported for '=headN' directives +*MAX_HEADING_LEVEL = \3; + +############################################################################# + + +##--------------------------------------------------------------------------- + +## =begin _PRIVATE_ +## +## =head1 B<_init_headings()> +## +## Initialize the current set of active section headings. +## +## =cut +## +## =end _PRIVATE_ + +sub _init_headings { + my $self = shift; + local *myData = $self; + + ## Initialize current section heading titles if necessary + unless (defined $myData{_SECTION_HEADINGS}) { + local *section_headings = $myData{_SECTION_HEADINGS} = []; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $section_headings[$i] = ''; + } + } +} + +##--------------------------------------------------------------------------- + + +sub curr_headings { + my $self = shift; + $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); + my @headings = @{ $self->{_SECTION_HEADINGS} }; + return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; +} + +##--------------------------------------------------------------------------- + + +sub select { + my ($self, @sections) = @_; + local *myData = $self; + local $_; + +### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) + + ##--------------------------------------------------------------------- + ## The following is a blatant hack for backward compatibility, and for + ## implementing add_selection(). If the *first* *argument* is the + ## string "+", then the remaining section specifications are *added* + ## to the current set of selections; otherwise the given section + ## specifications will *replace* the current set of selections. + ## + ## This should probably be fixed someday, but for the present time, + ## it seems incredibly unlikely that "+" would ever correspond to + ## a legitimate section heading + ##--------------------------------------------------------------------- + my $add = ($sections[0] eq '+') ? shift(@sections) : ''; + + ## Reset the set of sections to use + unless (@sections) { + delete $myData{_SELECTED_SECTIONS} unless ($add); + return; + } + $myData{_SELECTED_SECTIONS} = [] + unless ($add && exists $myData{_SELECTED_SECTIONS}); + local *selected_sections = $myData{_SELECTED_SECTIONS}; + + ## Compile each spec + for my $spec (@sections) { + if ( defined($_ = _compile_section_spec($spec)) ) { + ## Store them in our sections array + push(@selected_sections, $_); + } + else { + carp qq{Ignoring section spec "$spec"!\n}; + } + } +} + +##--------------------------------------------------------------------------- + + +sub add_selection { + my $self = shift; + return $self->select('+', @_); +} + +##--------------------------------------------------------------------------- + + +sub clear_selections { + my $self = shift; + return $self->select(); +} + +##--------------------------------------------------------------------------- + + +sub match_section { + my $self = shift; + my (@headings) = @_; + local *myData = $self; + + ## Return true if no restrictions were explicitly specified + my $selections = (exists $myData{_SELECTED_SECTIONS}) + ? $myData{_SELECTED_SECTIONS} : undef; + return 1 unless ((defined $selections) && @{$selections}); + + ## Default any unspecified sections to the current one + my @current_headings = $self->curr_headings(); + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; + } + + ## Look for a match against the specified section expressions + for my $section_spec ( @{$selections} ) { + ##------------------------------------------------------ + ## Each portion of this spec must match in order for + ## the spec to be matched. So we will start with a + ## match-value of 'true' and logically 'and' it with + ## the results of matching a given element of the spec. + ##------------------------------------------------------ + my $match = 1; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + my $regex = $section_spec->[$i]; + my $negated = ($regex =~ s/^\!//); + $match &= ($negated ? ($headings[$i] !~ /${regex}/) + : ($headings[$i] =~ /${regex}/)); + last unless ($match); + } + return 1 if ($match); + } + return 0; ## no match +} + +##--------------------------------------------------------------------------- + + +sub is_selected { + my ($self, $paragraph) = @_; + local $_; + local *myData = $self; + + $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); + + ## Keep track of current sections levels and headings + $_ = $paragraph; + if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/) + { + ## This is a section heading command + my ($level, $heading) = ($2, $3); + $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); + ## Reset the current section heading at this level + $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; + ## Reset subsection headings of this one to empty + for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { + $myData{_SECTION_HEADINGS}->[$i] = ''; + } + } + + return $self->match_section(); +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub podselect { + my(@argv) = @_; + my %defaults = (); + my $pod_parser = new Pod::Select(%defaults); + my $num_inputs = 0; + my $output = '>&STDOUT'; + my %opts; + local $_; + for (@argv) { + my $ref = ref($_); + if ($ref && $ref eq 'HASH') { + %opts = (%defaults, %{$_}); + + ##------------------------------------------------------------- + ## Need this for backward compatibility since we formerly used + ## options that were all uppercase words rather than ones that + ## looked like Unix command-line options. + ## to be uppercase keywords) + ##------------------------------------------------------------- + %opts = map { + my ($key, $val) = (lc $_, $opts{$_}); + $key =~ s/^(?=\w)/-/; + $key =~ /^-se[cl]/ and $key = '-sections'; + #! $key eq '-range' and $key .= 's'; + ($key => $val); + } (keys %opts); + + ## Process the options + (exists $opts{'-output'}) and $output = $opts{'-output'}; + + ## Select the desired sections + $pod_parser->select(@{ $opts{'-sections'} }) + if ( (defined $opts{'-sections'}) + && ((ref $opts{'-sections'}) eq 'ARRAY') ); + + #! ## Select the desired paragraph ranges + #! $pod_parser->select(@{ $opts{'-ranges'} }) + #! if ( (defined $opts{'-ranges'}) + #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); + } + elsif(!$ref || $ref eq 'GLOB') { + $pod_parser->parse_from_file($_, $output); + ++$num_inputs; + } + else { + croak "Input from $ref reference not supported!\n"; + } + } + $pod_parser->parse_from_file('-') unless ($num_inputs > 0); +} + +############################################################################# + + +##--------------------------------------------------------------------------- + + +sub _compile_section_spec { + my ($section_spec) = @_; + my (@regexs, $negated); + + ## Compile the spec into a list of regexs + local $_ = $section_spec; + s{\\\\}{\001}g; ## handle escaped backward slashes + s{\\/}{\002}g; ## handle escaped forward slashes + + ## Parse the regexs for the heading titles + @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); + + ## Set default regex for omitted levels + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regexs[$i] = '.*' unless ((defined $regexs[$i]) + && (length $regexs[$i])); + } + ## Modify the regexs as needed and validate their syntax + my $bad_regexs = 0; + for (@regexs) { + $_ .= '.+' if ($_ eq '!'); + s{\001}{\\\\}g; ## restore escaped backward slashes + s{\002}{\\/}g; ## restore escaped forward slashes + $negated = s/^\!//; ## check for negation + eval "m{$_}"; ## check regex syntax + if ($@) { + ++$bad_regexs; + carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; + } + else { + ## Add the forward and rear anchors (and put the negator back) + $_ = '^' . $_ unless (/^\^/); + $_ = $_ . '$' unless (/\$$/); + $_ = '!' . $_ if ($negated); + } + } + return (! $bad_regexs) ? [ @regexs ] : undef; +} + +##--------------------------------------------------------------------------- + + +##--------------------------------------------------------------------------- + + +############################################################################# + + +1; +# vim: ts=4 sw=4 et +############################################################################# +# Pod/InputObjects.pm -- package which defines objects for input streams +# and paragraphs and commands when parsing POD docs. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::InputObjects; +use strict; + +use vars qw($VERSION); +$VERSION = '1.63'; ## Current version of this package +require 5.005; ## requires this Perl version or later + +############################################################################# + + +############################################################################# + +package Pod::InputSource; + +##--------------------------------------------------------------------------- + + +##--------------------------------------------------------------------------- + + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { -name => '(unknown)', + -handle => undef, + -was_cutting => 0, + @_ }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + + +sub name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## allow 'filename' as an alias for 'name' +*filename = \&name; + +##--------------------------------------------------------------------------- + + +sub handle { + return $_[0]->{'-handle'}; +} + +##--------------------------------------------------------------------------- + + +sub was_cutting { + (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; + return $_[0]->{-was_cutting}; +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::Paragraph; + +##--------------------------------------------------------------------------- + + +##--------------------------------------------------------------------------- + + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => undef, + -text => (@_ == 1) ? shift : undef, + -file => '', + -line => 0, + -prefix => '=', + -separator => ' ', + -ptree => [], + @_ + }; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + + +sub text { + (@_ > 1) and $_[0]->{'-text'} = $_[1]; + return $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + + +sub raw_text { + return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); + return $_[0]->{'-prefix'} . $_[0]->{'-name'} . + $_[0]->{'-separator'} . $_[0]->{'-text'}; +} + +##--------------------------------------------------------------------------- + + +sub cmd_prefix { + return $_[0]->{'-prefix'}; +} + +##--------------------------------------------------------------------------- + + +sub cmd_separator { + return $_[0]->{'-separator'}; +} + +##--------------------------------------------------------------------------- + + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + + +sub file_line { + my @loc = ($_[0]->{'-file'} || '', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::InteriorSequence; + +##--------------------------------------------------------------------------- + + +##--------------------------------------------------------------------------- + + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + ## See if first argument has no keyword + if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { + ## Yup - need an implicit '-name' before first parameter + unshift @_, '-name'; + } + + ## See if odd number of args + if ((@_ % 2) != 0) { + ## Yup - need an implicit '-ptree' before the last parameter + splice @_, $#_, 0, '-ptree'; + } + + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. Note that we default + ## certain values by specifying them *before* the arguments passed. + ## If they are in the argument list, they will override the defaults. + my $self = { + -name => (@_ == 1) ? $_[0] : undef, + -file => '', + -line => 0, + -ldelim => '<', + -rdelim => '>', + @_ + }; + + ## Initialize contents if they haven't been already + my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); + if ( ref $ptree =~ /^(ARRAY)?$/ ) { + ## We have an array-ref, or a normal scalar. Pass it as an + ## an argument to the ptree-constructor + $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); + } + $self->{'-ptree'} = $ptree; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + + +sub cmd_name { + (@_ > 1) and $_[0]->{'-name'} = $_[1]; + return $_[0]->{'-name'}; +} + +## let name() be an alias for cmd_name() +*name = \&cmd_name; + +##--------------------------------------------------------------------------- + +## Private subroutine to set the parent pointer of all the given +## children that are interior-sequences to be $self + +sub _set_child2parent_links { + my ($self, @children) = @_; + ## Make sure any sequences know who their parent is + for (@children) { + next unless (length and ref and ref ne 'SCALAR'); + if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or + UNIVERSAL::can($_, 'nested')) + { + $_->nested($self); + } + } +} + +## Private subroutine to unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + $self->{'-parent_sequence'} = undef; + my $ptree = $self->{'-ptree'}; + for (@$ptree) { + next unless (length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() + if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); + } +} + +##--------------------------------------------------------------------------- + + +sub prepend { + my $self = shift; + $self->{'-ptree'}->prepend(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + + +sub append { + my $self = shift; + $self->{'-ptree'}->append(@_); + _set_child2parent_links($self, @_); + return $self; +} + +##--------------------------------------------------------------------------- + + +sub nested { + my $self = shift; + (@_ == 1) and $self->{'-parent_sequence'} = shift; + return $self->{'-parent_sequence'} || undef; +} + +##--------------------------------------------------------------------------- + + +sub raw_text { + my $self = shift; + my $text = $self->{'-name'} . $self->{'-ldelim'}; + for ( $self->{'-ptree'}->children ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + $text .= $self->{'-rdelim'}; + return $text; +} + +##--------------------------------------------------------------------------- + + +sub left_delimiter { + (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; + return $_[0]->{'-ldelim'}; +} + +## let ldelim() be an alias for left_delimiter() +*ldelim = \&left_delimiter; + +##--------------------------------------------------------------------------- + + +sub right_delimiter { + (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; + return $_[0]->{'-rdelim'}; +} + +## let rdelim() be an alias for right_delimiter() +*rdelim = \&right_delimiter; + +##--------------------------------------------------------------------------- + + +sub parse_tree { + (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; + return $_[0]->{'-ptree'}; +} + +## let ptree() be an alias for parse_tree() +*ptree = \&parse_tree; + +##--------------------------------------------------------------------------- + + +sub file_line { + my @loc = ($_[0]->{'-file'} || '', + $_[0]->{'-line'} || 0); + return (wantarray) ? @loc : join(':', @loc); +} + +##--------------------------------------------------------------------------- + + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +##--------------------------------------------------------------------------- + +############################################################################# + +package Pod::ParseTree; + +##--------------------------------------------------------------------------- + + +##--------------------------------------------------------------------------- + + +sub new { + ## Determine if we were called via an object-ref or a classname + my $this = shift; + my $class = ref($this) || $this; + + my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; + + ## Bless ourselves into the desired class and perform any initialization + bless $self, $class; + return $self; +} + +##--------------------------------------------------------------------------- + + +sub top { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return $self; +} + +## let parse_tree() & ptree() be aliases for the 'top' method +*parse_tree = *ptree = \⊤ + +##--------------------------------------------------------------------------- + + +sub children { + my $self = shift; + if (@_ > 0) { + @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; + } + return @{ $self }; +} + +##--------------------------------------------------------------------------- + + +use vars qw(@ptree); ## an alias used for performance reasons + +sub prepend { + my $self = shift; + local *ptree = $self; + for (@_) { + next unless length; + if (@ptree && !(ref $ptree[0]) && !(ref $_)) { + $ptree[0] = $_ . $ptree[0]; + } + else { + unshift @ptree, $_; + } + } +} + +##--------------------------------------------------------------------------- + + +sub append { + my $self = shift; + local *ptree = $self; + my $can_append = @ptree && !(ref $ptree[-1]); + for (@_) { + if (ref) { + push @ptree, $_; + } + elsif(!length) { + next; + } + elsif ($can_append) { + $ptree[-1] .= $_; + } + else { + push @ptree, $_; + } + } +} + + +sub raw_text { + my $self = shift; + my $text = ''; + for ( @$self ) { + $text .= (ref $_) ? $_->raw_text : $_; + } + return $text; +} + +##--------------------------------------------------------------------------- + +## Private routines to set/unset child->parent links + +sub _unset_child2parent_links { + my $self = shift; + local *ptree = $self; + for (@ptree) { + next unless (defined and length and ref and ref ne 'SCALAR'); + $_->_unset_child2parent_links() + if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); + } +} + +sub _set_child2parent_links { + ## nothing to do, Pod::ParseTrees cant have parent pointers +} + + +sub DESTROY { + ## We need to get rid of all child->parent pointers throughout the + ## tree so their reference counts will go to zero and they can be + ## garbage-collected + _unset_child2parent_links(@_); +} + +############################################################################# + + +1; +############################################################################# +# Pod/Checker.pm -- check pod documents for syntax errors +# +# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved. +# This is free software; you can redistribute it and/or modify it under the +# same terms as Perl itself. +############################################################################# + +package Pod::Checker; +use strict; +use warnings; + +our $VERSION = '1.73'; ## Current version of this package + + +############################################################################# + +#use diagnostics; +use Carp qw(croak); +use Exporter 'import'; +use base qw/Pod::Simple::Methody/; + +our @EXPORT = qw(&podchecker); + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub podchecker { + my ($infile, $outfile, %options) = @_; + local $_; + + ## Set defaults + $infile ||= \*STDIN; + $outfile ||= \*STDERR; + + ## Now create a pod checker + my $checker = Pod::Checker->new(%options); + + ## Now check the pod document for errors + $checker->parse_from_file($infile, $outfile); + + ## Return the number of errors found + return $checker->num_errors(); +} + + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +################################## + + +sub new { + my $new = shift->SUPER::new(@_); + $new->{'output_fh'} ||= *STDERR{IO}; + + # Set options + my %opts = @_; + $new->{'-warnings'} = defined $opts{'-warnings'} ? + $opts{'-warnings'} : 1; # default on + $new->{'-quiet'} = $opts{'-quiet'} || 0; # default off + + # Initialize number of errors/warnings + $new->{'_NUM_ERRORS'} = 0; + $new->{'_NUM_WARNINGS'} = 0; + + # 'current' also means 'most recent' in the follow comments + $new->{'_thispara'} = ''; # current POD paragraph + $new->{'_line'} = 0; # current line number + $new->{'_head_num'} = 0; # current =head level (set to 0 to make + # logic easier down the road) + $new->{'_cmds_since_head'} = 0; # num of POD directives since prev. =headN + $new->{'_nodes'} = []; # stack for =head/=item nodes + $new->{'_fcode_stack'} = []; # stack for nested formatting codes + $new->{'_fcode_pos'} = []; # stack for position in paragraph of fcodes + $new->{'_begin_stack'} = []; # stack for =begins: [line #, target] + $new->{'_links'} = []; # stack for hyperlinks to external entities + $new->{'_internal_links'} = []; # set of linked-to internal sections + $new->{'_index'} = []; # stack for text in X<>s + + $new->accept_targets('*'); # check all =begin/=for blocks + $new->cut_handler( \&handle_pod_and_cut ); # warn if text after =cut + $new->pod_handler( \&handle_pod_and_cut ); # warn if text after =pod + $new->whiteline_handler( \&handle_whiteline ); # warn if whiteline + $new->parse_empty_lists(1); # warn if they are empty + + return $new; +} + +################################## + + +# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +sub poderror { + my $self = shift; + my %opts = (ref $_[0]) ? %{shift()} : (); + + ## Retrieve options + chomp( my $msg = ($opts{'-msg'} || '')."@_" ); + my $line = (exists $opts{'-line'}) ? " at line $opts{'-line'}" : ''; + my $file = ' in file ' . ((exists $opts{'-file'}) + ? $opts{'-file'} + : ((defined $self->source_filename) + ? $self->source_filename + : "???")); + unless (exists $opts{'-severity'}) { + ## See if can find severity in message prefix + $opts{'-severity'} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// ); + } + my $severity = (exists $opts{'-severity'}) ? "*** $opts{-severity}: " : ''; + + ## Increment error count and print message " + ++($self->{'_NUM_ERRORS'}) + if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'ERROR')); + ++($self->{'_NUM_WARNINGS'}) + if(!%opts || ($opts{-severity} && $opts{'-severity'} eq 'WARNING')); + unless($self->{'-quiet'}) { + my $out_fh = $self->{'output_fh'} || \*STDERR; + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{'-warnings'} || !%opts || $opts{'-severity'} ne 'WARNING'); + } +} + +################################## + + +sub num_errors { + return (@_ > 1) ? ($_[0]->{'_NUM_ERRORS'} = $_[1]) : $_[0]->{'_NUM_ERRORS'}; +} + +################################## + + +sub num_warnings { + return (@_ > 1) ? ($_[0]->{'_NUM_WARNINGS'} = $_[1]) : + $_[0]->{'_NUM_WARNINGS'}; +} + +################################## + + +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{'_pod_name'} = $_[1]) : $_[0]->{'_pod_name'}; +} + +################################## + + +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{'_nodes'}}, $text); + # keep also a uniqueness counter + $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{'_nodes'}}; +} + +################################## + + +# set/return index entries of current POD +sub idx { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{'_index'}}, $text); + # keep also a uniqueness counter + $self->{'_unique_nodes'}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{'_index'}}; +} + +################################## + +# add a hyperlink to the list of those of the current POD; returns current +# list after the addition has been done +sub hyperlink { + my $self = shift; + push(@{$self->{'_links'}}, $_[0]); + return $_[0]; +} + + +sub hyperlinks { + @{shift->{'_links'}}; +} + +################################## + +# override Pod::Simple's whine() and scream() to use poderror() + +# Note: +# Ignore $self->{'no_whining'} b/c $self->{'quiet'} takes care of it in poderror +# Don't bother incrementing $self->{'errors_seen'} -- it's not used +# Don't bother pushing to $self->{'errata'} b/c poderror() outputs immediately +# We don't need to set $self->no_errata_section(1) b/c of these overrides + + +sub whine { + my ($self, $line, $complaint) = @_; + + my $severity = 'ERROR'; + + if (0) { + # XXX: Let's standardize what's a warning and what's an error. Let's not + # move stuff up and down the severity tree. -- rjbs, 2013-04-12 + # Convert errors in Pod::Simple that are warnings in Pod::Checker + # XXX Do differently so the $complaint can be reworded without this breaking + $severity = 'WARNING' if + $complaint =~ /^Expected '=item .+?'$/ || + $complaint =~ /^You can't have =items \(as at line .+?\) unless the first thing after the =over is an =item$/ || + $complaint =~ /^You have '=item .+?' instead of the expected '=item .+?'$/; + } + + $self->poderror({ -line => $line, + -severity => $severity, + -msg => $complaint }); + + return 1; # assume everything is peachy keen +} + +sub scream { + my ($self, $line, $complaint) = @_; + + $self->poderror({ -line => $line, + -severity => 'ERROR', # consider making severity 'FATAL' + -msg => $complaint }); + + return 1; +} + + +################################## + +# Some helper subroutines + +sub _init_event { # assignments done at the start of most events + $_[0]{'_thispara'} = ''; + $_[0]{'_line'} = $_[1]{'start_line'}; + $_[0]{'_cmds_since_head'}++; +} + +sub _check_fcode { + my ($self, $inner, $outers) = @_; + # Check for an fcode inside another of the same fcode + # XXX line number is the line of the start of the paragraph that the warning + # is in, not the line that the warning is on. Fix this + + # Later versions of Pod::Simple forbid nested L<>'s + return if $inner eq 'L' && $Pod::Simple::VERSION ge '3.33'; + + if (grep { $_ eq $inner } @$outers) { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => "nested commands $inner<...$inner<...>...>"}); + } +} + +################################## + +sub handle_text { $_[0]{'_thispara'} .= $_[1] } + +# whiteline is a seemingly blank line that matches /[^\S\r\n]/ +sub handle_whiteline { + my ($line, $line_n, $self) = @_; + $self->poderror({ + -line => $line_n, + -severity => 'WARNING', + -msg => 'line containing nothing but whitespace in paragraph'}); +} + +######## Directives +sub handle_pod_and_cut { + my ($line, $line_n, $self) = @_; + $self->{'_cmds_since_head'}++; + if ($line =~ /=(pod|cut)\s+\S/) { + $self->poderror({ -line => $line_n, + -severity => 'ERROR', + -msg => "Spurious text after =$1"}); + } +} + +sub start_Para { shift->_init_event(@_); } +sub end_Para { + my $self = shift; + # Get the NAME of the pod document + if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') { + if ($self->{'_thispara'} =~ /^\s*(\S+?)\s*[,-]/) { + $self->{'_pod_name'} = $1 unless defined $self->{'_pod_name'}; + } + } +} + +sub start_Verbatim { + my $self = shift; + $self->_init_event(@_); + + if ($self->{'_head_num'} == 1 && $self->{'_head_text'} eq 'NAME') { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => 'Verbatim paragraph in NAME section' }); + } +} +# Don't need an end_Verbatim + +# Do I need to do anything else with this? +sub start_Data { shift->_init_event() } + +sub start_head1 { shift->start_head(1, @_) } +sub start_head2 { shift->start_head(2, @_) } +sub start_head3 { shift->start_head(3, @_) } +sub start_head4 { shift->start_head(4, @_) } +sub start_head { + my $self = shift; + my $h = shift; + $self->_init_event(@_); + my $prev_h = $self->{'_head_num'}; + $self->{'_head_num'} = $h; + $self->{"_count_head$h"}++; + + if ($h > 1 && !$self->{'_count_head'.($h-1)}) { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => "=head$h without preceding higher level"}); + } + + # If this is the first =head of the doc, $prev_h is 0, thus less than $h + if ($self->{'_cmds_since_head'} == 1 && $prev_h >= $h) { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => 'empty section in previous paragraph'}); + } +} + +sub end_head1 { shift->end_head(@_) } +sub end_head2 { shift->end_head(@_) } +sub end_head3 { shift->end_head(@_) } +sub end_head4 { shift->end_head(@_) } +sub end_head { + my $self = shift; + my $arg = $self->{'_thispara'}; + $arg =~ s/\s+$//; + $self->{'_head_text'} = $arg; + $self->{'_cmds_since_head'} = 0; + my $h = $self->{'_head_num'}; + $self->node($arg); # remember this node + if ($arg eq '') { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'ERROR', + -msg => "empty =head$h" }); + } +} + +sub start_over_bullet { shift->start_over(@_, 'bullet') } +sub start_over_number { shift->start_over(@_, 'number') } +sub start_over_text { shift->start_over(@_, 'definition') } +sub start_over_block { shift->start_over(@_, 'block') } +sub start_over_empty { + my $self = shift; + $self->start_over(@_, 'empty'); + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => 'empty =over/=back block' }); +} +sub start_over { + my $self = shift; + my $type = pop; + $self->_init_event(@_); +} + +sub start_item_bullet { shift->_init_event(@_) } +sub start_item_number { shift->_init_event(@_) } +sub start_item_text { shift->_init_event(@_) } +sub end_item_bullet { shift->end_item('bullet') } +sub end_item_number { shift->end_item('number') } +sub end_item_text { shift->end_item('definition') } +sub end_item { + my $self = shift; + my $type = shift; + # If there is verbatim text in this item, it will show up as part of + # 'paras', and not part of '_thispara'. If the first para after this is a + # verbatim one, it actually will be (part of) the contents for this item. + if ( $self->{'_thispara'} eq '' + && ( ! @{$self->{'paras'}} + || $self->{'paras'}[0][0] !~ /Verbatim/i)) + { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'WARNING', + -msg => '=item has no contents' }); + } + + $self->node($self->{'_thispara'}); # remember this node +} + +sub start_for { # =for and =begin directives + my ($self, $flags) = @_; + $self->_init_event($flags); + push @{$self->{'_begin_stack'}}, [$self->{'_line'}, $flags->{'target'}]; +} + +sub end_for { + my ($self, $flags) = @_; + my ($line, $target) = @{pop @{$self->{'_begin_stack'}}}; + if ($flags->{'fake-closer'}) { # meaning Pod::Simple generated this =end + $self->poderror({ -line => $line, + -severity => 'ERROR', + -msg => "=begin $target without matching =end $target" + }); + } +} + +sub end_Document { + # Some final error checks + my $self = shift; + + # no POD found here + $self->num_errors(-1) && return unless $self->content_seen; + + my %nodes; + for ($self->node()) { + $nodes{$_} = 1; + if(/^(\S+)\s+\S/) { + # we have more than one word. Use the first as a node, too. + # This is used heavily in perlfunc.pod + $nodes{$1} ||= 2; # derived node + } + } + for ($self->idx()) { + $nodes{$_} = 3; # index node + } + + # XXX update unresolved internal link POD -- single word not enclosed in ""? + # I don't know what I was thinking when I made the above TODO, and I don't + # know what it means... + + for my $link (@{ $self->{'_internal_links'} }) { + my ($name, $line) = @$link; + unless ( $nodes{$name} ) { + $self->poderror({ -line => $line, + -severity => 'ERROR', + -msg => "unresolved internal link '$name'"}); + } + } + + # check the internal nodes for uniqueness. This pertains to + # =headX, =item and X<...> + if ($self->{'-warnings'} > 1 ) { + for my $node (sort keys %{ $self->{'_unique_nodes'} }) { + my $count = $self->{'_unique_nodes'}{$node}; + if ($count > 1) { # not unique + $self->poderror({ + -line => '-', + -severity => 'WARNING', + -msg => "multiple occurrences ($count) of link target ". + "'$node'"}); + } + } + } +} + +######## Formatting codes + +sub start_B { shift->start_fcode('B') } +sub start_C { shift->start_fcode('C') } +sub start_F { shift->start_fcode('F') } +sub start_I { shift->start_fcode('I') } +sub start_S { shift->start_fcode('S') } +sub start_fcode { + my ($self, $fcode) = @_; + unshift @{$self->{'_fcode_stack'}}, $fcode; +} + +sub end_B { shift->end_fcode() } +sub end_C { shift->end_fcode() } +sub end_F { shift->end_fcode() } +sub end_I { shift->end_fcode() } +sub end_S { shift->end_fcode() } +sub end_fcode { + my $self = shift; + $self->_check_fcode(shift @{$self->{'_fcode_stack'}}, # current fcode removed + $self->{'_fcode_stack'}); # previous fcodes +} + +sub start_L { + my ($self, $flags) = @_; + $self->start_fcode('L'); + + my $link = Pod::Checker::Hyperlink->new($flags, $self); + if ($link) { + if ( $link->type eq 'pod' + && $link->node + # It's an internal-to-this-page link if no page is given, or + # if the given one is to our NAME. + && (! $link->page || ( $self->{'_pod_name'} + && $link->page eq $self->{'_pod_name'}))) + { + push @{ $self->{'_internal_links'} }, [ $link->{'-raw_node'}, $link->line ]; + } + else { + $self->hyperlink($link); + } + } +} + +sub end_L { + my $self = shift; + $self->end_fcode(); +} + +sub start_X { + my $self = shift; + $self->start_fcode('X'); + # keep track of where X<> starts in the paragraph + # (this is a stack so nested X<>s are handled correctly) + push @{$self->{'_fcode_pos'}}, length $self->{'_thispara'}; +} +sub end_X { + my $self = shift; + # extract contents of X<> and replace with '' + my $start = pop @{$self->{'_fcode_pos'}}; # start at the beginning of X<> + my $end = length($self->{'_thispara'}) - $start; # end at end of X<> + my $x = substr($self->{'_thispara'}, $start, $end, ''); + if ($x eq "") { + $self->poderror({ -line => $self->{'_line'}, + -severity => 'ERROR', + -msg => "An empty X<>" }); + } + $self->idx($x); # remember this node + $self->end_fcode(); +} + +package Pod::Checker::Hyperlink; + +# This class is used to represent L<> link structures, so that the individual +# elements are easily accessible. It is based on code in Pod::Hyperlink + +sub new { + my ($class, + $simple_link, # The link structure returned by Pod::Simple + $caller # The caller class + ) = @_; + + my $self = +{}; + bless $self, $class; + + $self->{'-line'} ||= $caller->{'_line'}; + $self->{'-type'} ||= $simple_link->{'type'}; + + # Force stringification of page and node. (This expands any E<>.) + $self->{'-page'} = exists $simple_link->{'to'} ? "$simple_link->{'to'}" : ""; + $self->{'-node'} = exists $simple_link->{'section'} ? "$simple_link->{'section'}" : ""; + + # Save the unmodified node text, as the .t files are expecting the message + # for internal link failures to include it (hence this preserves backward + # compatibility). + $self->{'-raw_node'} = $self->{'-node'}; + + # Remove leading/trailing white space. Pod::Simple already warns about + # these, so if the only error is this, and the link is otherwise correct, + # only the Pod::Simple warning will be output, avoiding unnecessary + # confusion. + $self->{'-page'} =~ s/ ^ \s+ //x; + $self->{'-page'} =~ s/ \s+ $ //x; + + $self->{'-node'} =~ s/ ^ \s+ //x; + $self->{'-node'} =~ s/ \s+ $ //x; + + # Pod::Simple warns about L<> and L< >, but not L + if ($self->{'-page'} eq "" && $self->{'-node'} eq "") { + $caller->poderror({ -line => $caller->{'_line'}, + -severity => 'WARNING', + -msg => 'empty link'}); + return; + } + + return $self; +} + + +sub line { + return $_[0]->{-line}; +} + + +sub type { + return $_[0]->{-type}; +} + + +sub page { + return $_[0]->{-page}; +} + + +sub node { + return $_[0]->{-node}; +} + + +1 +# Pod::Man -- Convert POD data to formatted *roff input. +# +# This module translates POD documentation into *roff markup using the man +# macro set, and is intended for converting POD documents written as Unix +# manual pages to manual pages that can be read by the man(1) command. It is +# a replacement for the pod2man command distributed with versions of Perl +# prior to 5.6. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. +# +# Written by Russ Allbery +# Substantial contributions by Sean Burke +# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +# 2010, 2012, 2013, 2014, 2015, 2016, 2017 Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Man; + +use 5.006; +use strict; +use warnings; + +use subs qw(makespace); +use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); + +use Carp qw(carp croak); +use Pod::Simple (); + +# Conditionally import Encode and set $HAS_ENCODE if it is available. +our $HAS_ENCODE; +BEGIN { + $HAS_ENCODE = eval { require Encode }; +} + +@ISA = qw(Pod::Simple); + +$VERSION = '4.10'; + +# Set the debugging level. If someone has inserted a debug function into this +# class already, use that. Otherwise, use any Pod::Simple debug function +# that's defined, and failing that, define a debug level of 10. +BEGIN { + my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef; + unless (defined &DEBUG) { + *DEBUG = $parent || sub () { 10 }; + } +} + +# Import the ASCII constant from Pod::Simple. This is true iff we're in an +# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is +# generally only false for EBCDIC. +BEGIN { *ASCII = \&Pod::Simple::ASCII } + +# Pretty-print a data structure. Only used for debugging. +BEGIN { *pretty = \&Pod::Simple::pretty } + +# Formatting instructions for various types of blocks. cleanup makes hyphens +# hard, adds spaces between consecutive underscores, and escapes backslashes. +# convert translates characters into escapes. guesswork means to apply the +# transformations done by the guesswork sub. literal says to protect literal +# quotes from being turned into UTF-8 quotes. By default, all transformations +# are on except literal, but some elements override. +# +# DEFAULT specifies the default settings. All other elements should list only +# those settings that they are overriding. Data indicates =for roff blocks, +# which should be passed along completely verbatim. +# +# Formatting inherits negatively, in the sense that if the parent has turned +# off guesswork, all child elements should leave it off. +my %FORMATTING = ( + DEFAULT => { cleanup => 1, convert => 1, guesswork => 1, literal => 0 }, + Data => { cleanup => 0, convert => 0, guesswork => 0, literal => 0 }, + Verbatim => { guesswork => 0, literal => 1 }, + C => { guesswork => 0, literal => 1 }, + X => { cleanup => 0, guesswork => 0 }, +); + +############################################################################## +# Object initialization +############################################################################## + +# Initialize the object and set various Pod::Simple options that we need. +# Here, we also process any additional options passed to the constructor or +# set up defaults if none were given. Note that all internal object keys are +# in all-caps, reserving all lower-case object keys for Pod::Simple and user +# arguments. +sub new { + my $class = shift; + my $self = $class->SUPER::new; + + # Tell Pod::Simple not to handle S<> by automatically inserting  . + $self->nbsp_for_S (1); + + # Tell Pod::Simple to keep whitespace whenever possible. + if (my $preserve_whitespace = $self->can ('preserve_whitespace')) { + $self->$preserve_whitespace (1); + } else { + $self->fullstop_space_harden (1); + } + + # The =for and =begin targets that we accept. + $self->accept_targets (qw/man MAN roff ROFF/); + + # Ensure that contiguous blocks of code are merged together. Otherwise, + # some of the guesswork heuristics don't work right. + $self->merge_text (1); + + # Pod::Simple doesn't do anything useful with our arguments, but we want + # to put them in our object as hash keys and values. This could cause + # problems if we ever clash with Pod::Simple's own internal class + # variables. + %$self = (%$self, @_); + + # Send errors to stderr if requested. + if ($$self{stderr} and not $$self{errors}) { + $$self{errors} = 'stderr'; + } + delete $$self{stderr}; + + # Validate the errors parameter and act on it. + if (not defined $$self{errors}) { + $$self{errors} = 'pod'; + } + if ($$self{errors} eq 'stderr' || $$self{errors} eq 'die') { + $self->no_errata_section (1); + $self->complain_stderr (1); + if ($$self{errors} eq 'die') { + $$self{complain_die} = 1; + } + } elsif ($$self{errors} eq 'pod') { + $self->no_errata_section (0); + $self->complain_stderr (0); + } elsif ($$self{errors} eq 'none') { + $self->no_whining (1); + } else { + croak (qq(Invalid errors setting: "$$self{errors}")); + } + delete $$self{errors}; + + # Degrade back to non-utf8 if Encode is not available. + # + # Suppress the warning message when PERL_CORE is set, indicating this is + # running as part of the core Perl build. Perl builds podlators (and all + # pure Perl modules) before Encode and other XS modules, so Encode won't + # yet be available. Rely on the Perl core build to generate man pages + # later, after all the modules are available, so that UTF-8 handling will + # be correct. + if ($$self{utf8} and !$HAS_ENCODE) { + if (!$ENV{PERL_CORE}) { + carp ('utf8 mode requested but Encode module not available,' + . ' falling back to non-utf8'); + } + delete $$self{utf8}; + } + + # Initialize various other internal constants based on our arguments. + $self->init_fonts; + $self->init_quotes; + $self->init_page; + + # For right now, default to turning on all of the magic. + $$self{MAGIC_CPP} = 1; + $$self{MAGIC_EMDASH} = 1; + $$self{MAGIC_FUNC} = 1; + $$self{MAGIC_MANREF} = 1; + $$self{MAGIC_SMALLCAPS} = 1; + $$self{MAGIC_VARS} = 1; + + return $self; +} + +# Translate a font string into an escape. +sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } + +# Determine which fonts the user wishes to use and store them in the object. +# Regular, italic, bold, and bold-italic are constants, but the fixed width +# fonts may be set by the user. Sets the internal hash key FONTS which is +# used to map our internal font escapes to actual *roff sequences later. +sub init_fonts { + my ($self) = @_; + + # Figure out the fixed-width font. If user-supplied, make sure that they + # are the right length. + for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { + my $font = $$self{$_}; + if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) { + croak qq(roff font should be 1 or 2 chars, not "$font"); + } + } + + # Set the default fonts. We can't be sure portably across different + # implementations what fixed bold-italic may be called (if it's even + # available), so default to just bold. + $$self{fixed} ||= 'CW'; + $$self{fixedbold} ||= 'CB'; + $$self{fixeditalic} ||= 'CI'; + $$self{fixedbolditalic} ||= 'CB'; + + # Set up a table of font escapes. First number is fixed-width, second is + # bold, third is italic. + $$self{FONTS} = { '000' => '\fR', '001' => '\fI', + '010' => '\fB', '011' => '\f(BI', + '100' => toescape ($$self{fixed}), + '101' => toescape ($$self{fixeditalic}), + '110' => toescape ($$self{fixedbold}), + '111' => toescape ($$self{fixedbolditalic}) }; +} + +# Initialize the quotes that we'll be using for C<> text. This requires some +# special handling, both to parse the user parameters if given and to make +# sure that the quotes will be safe against *roff. Sets the internal hash +# keys LQUOTE and RQUOTE. +sub init_quotes { + my ($self) = (@_); + + # Handle the quotes option first, which sets both quotes at once. + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif (length ($$self{quotes}) % 2 == 0) { + my $length = length ($$self{quotes}) / 2; + $$self{LQUOTE} = substr ($$self{quotes}, 0, $length); + $$self{RQUOTE} = substr ($$self{quotes}, $length); + } else { + croak(qq(Invalid quote specification "$$self{quotes}")) + } + + # Now handle the lquote and rquote options. + if (defined $$self{lquote}) { + $$self{LQUOTE} = $$self{lquote} eq 'none' ? q{} : $$self{lquote}; + } + if (defined $$self{rquote}) { + $$self{RQUOTE} = $$self{rquote} eq 'none' ? q{} : $$self{rquote}; + } + + # Double the first quote; note that this should not be s///g as two double + # quotes is represented in *roff as three double quotes, not four. Weird, + # I know. + $$self{LQUOTE} =~ s/\"/\"\"/; + $$self{RQUOTE} =~ s/\"/\"\"/; +} + +# Initialize the page title information and indentation from our arguments. +sub init_page { + my ($self) = @_; + + # We used to try first to get the version number from a local binary, but + # we shouldn't need that any more. Get the version from the running Perl. + # Work a little magic to handle subversions correctly under both the + # pre-5.6 and the post-5.6 version numbering schemes. + my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); + $version[2] ||= 0; + $version[2] *= 10 ** (3 - length $version[2]); + for (@version) { $_ += 0 } + my $version = join ('.', @version); + + # Set the defaults for page titles and indentation if the user didn't + # override anything. + $$self{center} = 'User Contributed Perl Documentation' + unless defined $$self{center}; + $$self{release} = 'perl v' . $version + unless defined $$self{release}; + $$self{indent} = 4 + unless defined $$self{indent}; + + # Double quotes in things that will be quoted. + for (qw/center release/) { + $$self{$_} =~ s/\"/\"\"/g if $$self{$_}; + } +} + +############################################################################## +# Core parsing +############################################################################## + +# This is the glue that connects the code below with Pod::Simple itself. The +# goal is to convert the event stream coming from the POD parser into method +# calls to handlers once the complete content of a tag has been seen. Each +# paragraph or POD command will have textual content associated with it, and +# as soon as all of a paragraph or POD command has been seen, that content +# will be passed in to the corresponding method for handling that type of +# object. The exceptions are handlers for lists, which have opening tag +# handlers and closing tag handlers that will be called right away. +# +# The internal hash key PENDING is used to store the contents of a tag until +# all of it has been seen. It holds a stack of open tags, each one +# represented by a tuple of the attributes hash for the tag, formatting +# options for the tag (which are inherited), and the contents of the tag. + +# Add a block of text to the contents of the current node, formatting it +# according to the current formatting instructions as we do. +sub _handle_text { + my ($self, $text) = @_; + DEBUG > 3 and print "== $text\n"; + my $tag = $$self{PENDING}[-1]; + $$tag[2] .= $self->format_text ($$tag[1], $text); +} + +# Given an element name, get the corresponding method name. +sub method_for_element { + my ($self, $element) = @_; + $element =~ tr/A-Z-/a-z_/; + $element =~ tr/_a-z0-9//cd; + return $element; +} + +# Handle the start of a new element. If cmd_element is defined, assume that +# we need to collect the entire tree for this element before passing it to the +# element method, and create a new tree into which we'll collect blocks of +# text and nested elements. Otherwise, if start_element is defined, call it. +sub _handle_element_start { + my ($self, $element, $attrs) = @_; + DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n"; + my $method = $self->method_for_element ($element); + + # If we have a command handler, we need to accumulate the contents of the + # tag before calling it. Turn off IN_NAME for any command other than + # and the formatting codes so that IN_NAME isn't still set for the + # first heading after the NAME heading. + if ($self->can ("cmd_$method")) { + DEBUG > 2 and print "<$element> starts saving a tag\n"; + $$self{IN_NAME} = 0 if ($element ne 'Para' && length ($element) > 1); + + # How we're going to format embedded text blocks depends on the tag + # and also depends on our parent tags. Thankfully, inside tags that + # turn off guesswork and reformatting, nothing else can turn it back + # on, so this can be strictly inherited. + my $formatting = { + %{ $$self{PENDING}[-1][1] || $FORMATTING{DEFAULT} }, + %{ $FORMATTING{$element} || {} }, + }; + push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]); + DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n"; + } elsif (my $start_method = $self->can ("start_$method")) { + $self->$start_method ($attrs, ''); + } else { + DEBUG > 2 and print "No $method start method, skipping\n"; + } +} + +# Handle the end of an element. If we had a cmd_ method for this element, +# this is where we pass along the tree that we built. Otherwise, if we have +# an end_ method for the element, call that. +sub _handle_element_end { + my ($self, $element) = @_; + DEBUG > 3 and print "-- $element\n"; + my $method = $self->method_for_element ($element); + + # If we have a command handler, pull off the pending text and pass it to + # the handler along with the saved attribute hash. + if (my $cmd_method = $self->can ("cmd_$method")) { + DEBUG > 2 and print " stops saving a tag\n"; + my $tag = pop @{ $$self{PENDING} }; + DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n"; + DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n"; + my $text = $self->$cmd_method ($$tag[0], $$tag[2]); + if (defined $text) { + if (@{ $$self{PENDING} } > 1) { + $$self{PENDING}[-1][2] .= $text; + } else { + $self->output ($text); + } + } + } elsif (my $end_method = $self->can ("end_$method")) { + $self->$end_method (); + } else { + DEBUG > 2 and print "No $method end method, skipping\n"; + } +} + +############################################################################## +# General formatting +############################################################################## + +# Format a text block. Takes a hash of formatting options and the text to +# format. Currently, the only formatting options are guesswork, cleanup, and +# convert, all of which are boolean. +sub format_text { + my ($self, $options, $text) = @_; + my $guesswork = $$options{guesswork} && !$$self{IN_NAME}; + my $cleanup = $$options{cleanup}; + my $convert = $$options{convert}; + my $literal = $$options{literal}; + + # Cleanup just tidies up a few things, telling *roff that the hyphens are + # hard, putting a bit of space between consecutive underscores, and + # escaping backslashes. Be careful not to mangle our character + # translations by doing this before processing character translation. + if ($cleanup) { + $text =~ s/\\/\\e/g; + $text =~ s/-/\\-/g; + $text =~ s/_(?=_)/_\\|/g; + } + + # Normally we do character translation, but we won't even do that in + # blocks or if UTF-8 output is desired. + if ($convert && !$$self{utf8} && ASCII) { + $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg; + } + + # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes, + # but don't mess up our accept escapes. + if ($literal) { + $text =~ s/(?guesswork ($text); + } + + return $text; +} + +# Handles C<> text, deciding whether to put \*C` around it or not. This is a +# whole bunch of messy heuristics to try to avoid overquoting, originally from +# Barrie Slaymaker. This largely duplicates similar code in Pod::Text. +sub quote_literal { + my $self = shift; + local $_ = shift; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # If in NAME section, just return an ASCII quoted string to avoid + # confusing tools like whatis. + return qq{"$_"} if $$self{IN_NAME}; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \\\*\(Aq .* \\\*\(Aq # quoted and escaped + | \\?\` .* ( \' | \\\*\(Aq ) # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xso and return '\f(FS' . $_ . '\f(FE'; + + # If we didn't return, go ahead and quote the text. + return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"; +} + +# Takes a text block to perform guesswork on. Returns the text block with +# formatting codes added. This is the code that marks up various Perl +# constructs and things commonly used in man pages without requiring the user +# to add any explicit markup, and is applied to all non-literal text. We're +# guaranteed that the text we're applying guesswork to does not contain any +# *roff formatting codes. Note that the inserted font sequences must be +# treated later with mapfonts or textmapfonts. +# +# This method is very fragile, both in the regular expressions it uses and in +# the ordering of those modifications. Care and testing is required when +# modifying it. +sub guesswork { + my $self = shift; + local $_ = shift; + DEBUG > 5 and print " Guesswork called on [$_]\n"; + + # By the time we reach this point, all hyphens will be escaped by adding a + # backslash. We want to undo that escaping if they're part of regular + # words and there's only a single dash, since that's a real hyphen that + # *roff gets to consider a possible break point. Make sure that a dash + # after the first character of a word stays non-breaking, however. + # + # Note that this is not user-controllable; we pretty much have to do this + # transformation or *roff will mangle the output in unacceptable ways. + s{ + ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )? + ( (?: [a-zA-Z\']+ \\-)+ ) + ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) ) + \b + } { + my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4); + $hyphen ||= ''; + $main =~ s/\\-/-/g; + $prefix . $hyphen . $main . $suffix; + }egx; + + # Translate "--" into a real em-dash if it's used like one. This means + # that it's either surrounded by whitespace, it follows a regular word, or + # it occurs between two regular words. + if ($$self{MAGIC_EMDASH}) { + s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx; + s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx; + } + + # Make words in all-caps a little bit smaller; they look better that way. + # However, we don't want to change Perl code (like @ARGV), nor do we want + # to fix the MIME in MIME-Version since it looks weird with the + # full-height V. + # + # We change only a string of all caps (2) either at the beginning of the + # line or following regular punctuation (like quotes) or whitespace (1), + # and followed by either similar punctuation, an em-dash, or the end of + # the line (3). + # + # Allow the text we're changing to small caps to include double quotes, + # commas, newlines, and periods as long as it doesn't otherwise interrupt + # the string of small caps and still fits the criteria. This lets us turn + # entire warranty disclaimers in man page output into small caps. + if ($$self{MAGIC_SMALLCAPS}) { + s{ + ( ^ | [\s\(\"\'\`\[\{<>] | \\[ ] ) # (1) + ( [A-Z] [A-Z] (?: \s? [/A-Z+:\d_\$&] | \\- | \s? [.,\"] )* ) # (2) + (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\[ ] | $ ) # (3) + } { + $1 . '\s-1' . $2 . '\s0' + }egx; + } + + # Note that from this point forward, we have to adjust for \s-1 and \s-0 + # strings inserted around things that we've made small-caps if later + # transforms should work on those strings. + + # Embolden functions in the form func(), including functions that are in + # all capitals, but don't embolden if there's anything between the parens. + # The function must start with an alphabetic character or underscore and + # then consist of word characters or colons. + if ($$self{MAGIC_FUNC}) { + s{ + ( \b | \\s-1 ) + ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) ) + } { + $1 . '\f(BS' . $2 . '\f(BE' + }egx; + } + + # Change references to manual pages to put the page name in bold but + # the number in the regular font, with a thin space between the name and + # the number. Only recognize func(n) where func starts with an alphabetic + # character or underscore and contains only word characters, periods (for + # configuration file man pages), or colons, and n is a single digit, + # optionally followed by some number of lowercase letters. Note that this + # does not recognize man page references like perl(l) or socket(3SOCKET). + if ($$self{MAGIC_MANREF}) { + s{ + ( \b | \\s-1 ) + (? 5 and print " Guesswork returning [$_]\n"; + return $_; +} + +############################################################################## +# Output +############################################################################## + +# When building up the *roff code, we don't use real *roff fonts. Instead, we +# embed font codes of the form \f([SE] where is one of B, I, or +# F, S stands for start, and E stands for end. This method turns these into +# the right start and end codes. +# +# We add this level of complexity because the old pod2man didn't get code like +# B else> right; after I<> it switched back to normal text rather +# than bold. We take care of this by using variables that state whether bold, +# italic, or fixed are turned on as a combined pointer to our current font +# sequence, and set each to the number of current nestings of start tags for +# that font. +# +# \fP changes to the previous font, but only one previous font is kept. We +# don't know what the outside level font is; normally it's R, but if we're +# inside a heading it could be something else. So arrange things so that the +# outside font is always the "previous" font and end with \fP instead of \fR. +# Idea from Zack Weinberg. +sub mapfonts { + my ($self, $text) = @_; + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + my $last = '\fR'; + $text =~ s< + \\f\((.)(.) + > < + my $sequence = ''; + my $f; + if ($last ne '\fR') { $sequence = '\fP' } + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) }; + if ($f eq $last) { + ''; + } else { + if ($f ne '\fR') { $sequence .= $f } + $last = $f; + $sequence; + } + >gxe; + return $text; +} + +# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU +# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather +# than R, presumably because \f(CW doesn't actually do a font change. To work +# around this, use a separate textmapfonts for text blocks where the default +# font is always R and only use the smart mapfonts for headings. +sub textmapfonts { + my ($self, $text) = @_; + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + $text =~ s< + \\f\((.)(.) + > < + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) }; + >gxe; + return $text; +} + +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to LQUOTE and RQUOTE. +sub switchquotes { + my ($self, $command, $text, $extra) = @_; + $text =~ s/\\\*\([LR]\"/\"/g; + + # We also have to deal with \*C` and \*C', which are used to add the + # quotes around C<> text, since they may expand to " and if they do this + # confuses the .SH macros and the like no end. Expand them ourselves. + # Also separate troff from nroff if there are any fixed-width fonts in use + # to work around problems with Solaris nroff. + my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); + my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'}; + $fixedpat =~ s/\\/\\\\/g; + $fixedpat =~ s/\(/\\\(/g; + if ($text =~ m/\"/ || $text =~ m/$fixedpat/) { + $text =~ s/\"/\"\"/g; + my $nroff = $text; + my $troff = $text; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) { + $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g; + $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g; + $troff =~ s/\\\*\(C[\'\`]//g; + } + $nroff = qq("$nroff") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + + # Work around the Solaris nroff bug where \f(CW\fP leaves the font set + # to Roman rather than the actual previous font when used in headings. + # troff output may still be broken, but at least we can fix nroff by + # just switching the font changes to the non-fixed versions. + my $font_end = "(?:\\f[PR]|\Q$$self{FONTS}{100}\E)"; + $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f([PR])/$1/g; + $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)$font_end/\\fI$1\\fP/g; + $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)$font_end/\\fB$1\\fP/g; + $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)$font_end/\\f\(BI$1\\fP/g; + + # Now finally output the command. Bother with .ie only if the nroff + # and troff output aren't the same. + if ($nroff ne $troff) { + return ".ie n $command $nroff\n.el $command $troff\n"; + } else { + return "$command $nroff\n"; + } + } else { + $text = qq("$text") . ($extra ? " $extra" : ''); + return "$command $text\n"; + } +} + +# Protect leading quotes and periods against interpretation as commands. Also +# protect anything starting with a backslash, since it could expand or hide +# something that *roff would interpret as a command. This is overkill, but +# it's much simpler than trying to parse *roff here. +sub protect { + my ($self, $text) = @_; + $text =~ s/^([.\'\\])/\\&$1/mg; + return $text; +} + +# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation +# level the situation. This function is needed since in *roff one has to +# create vertical whitespace after paragraphs and between some things, but +# other macros create their own whitespace. Also close out a sequence of +# repeated =items, since calling makespace means we're about to begin the item +# body. +sub makespace { + my ($self) = @_; + $self->output (".PD\n") if $$self{ITEMS} > 1; + $$self{ITEMS} = 0; + $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n") + if $$self{NEEDSPACE}; +} + +# Output any pending index entries, and optionally an index entry given as an +# argument. Support multiple index entries in X<> separated by slashes, and +# strip special escapes from index entries. +sub outindex { + my ($self, $section, $index) = @_; + my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} }; + return unless ($section || @entries); + + # We're about to output all pending entries, so clear our pending queue. + $$self{INDEX} = []; + + # Build the output. Regular index entries are marked Xref, and headings + # pass in their own section. Undo some *roff formatting on headings. + my @output; + if (@entries) { + push @output, [ 'Xref', join (' ', @entries) ]; + } + if ($section) { + $index =~ s/\\-/-/g; + $index =~ s/\\(?:s-?\d|.\(..|.)//g; + push @output, [ $section, $index ]; + } + + # Print out the .IX commands. + for (@output) { + my ($type, $entry) = @$_; + $entry =~ s/\s+/ /g; + $entry =~ s/\"/\"\"/g; + $entry =~ s/\\/\\\\/g; + $self->output (".IX $type " . '"' . $entry . '"' . "\n"); + } +} + +# Output some text, without any additional changes. +sub output { + my ($self, @text) = @_; + if ($$self{ENCODE}) { + print { $$self{output_fh} } Encode::encode ('UTF-8', join ('', @text)); + } else { + print { $$self{output_fh} } @text; + } +} + +############################################################################## +# Document initialization +############################################################################## + +# Handle the start of the document. Here we handle empty documents, as well +# as setting up our basic macros in a preamble and building the page title. +sub start_document { + my ($self, $attrs) = @_; + if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) { + DEBUG and print "Document is contentless\n"; + $$self{CONTENTLESS} = 1; + } else { + delete $$self{CONTENTLESS}; + } + + # When UTF-8 output is set, check whether our output file handle already + # has a PerlIO encoding layer set. If it does not, we'll need to encode + # our output before printing it (handled in the output() sub). Wrap the + # check in an eval to handle versions of Perl without PerlIO. + # + # PerlIO::get_layers still requires its argument be a glob, so coerce the + # file handle to a glob. + $$self{ENCODE} = 0; + if ($$self{utf8}) { + $$self{ENCODE} = 1; + eval { + my @options = (output => 1, details => 1); + my @layers = PerlIO::get_layers (*{$$self{output_fh}}, @options); + if ($layers[-1] & PerlIO::F_UTF8 ()) { + $$self{ENCODE} = 0; + } + } + } + + # Determine information for the preamble and then output it unless the + # document was content-free. + if (!$$self{CONTENTLESS}) { + my ($name, $section); + if (defined $$self{name}) { + $name = $$self{name}; + $section = $$self{section} || 1; + } else { + ($name, $section) = $self->devise_title; + } + my $date = defined($$self{date}) ? $$self{date} : $self->devise_date; + $self->preamble ($name, $section, $date) + unless $self->bare_output or DEBUG > 9; + } + + # Initialize a few per-document variables. + $$self{INDENT} = 0; # Current indentation level. + $$self{INDENTS} = []; # Stack of indentations. + $$self{INDEX} = []; # Index keys waiting to be printed. + $$self{IN_NAME} = 0; # Whether processing the NAME section. + $$self{ITEMS} = 0; # The number of consecutive =items. + $$self{ITEMTYPES} = []; # Stack of =item types, one per list. + $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting. + $$self{SHIFTS} = []; # Stack of .RS shifts. + $$self{PENDING} = [[]]; # Pending output. +} + +# Handle the end of the document. This handles dying on POD errors, since +# Pod::Parser currently doesn't. Otherwise, does nothing but print out a +# final comment at the end of the document under debugging. +sub end_document { + my ($self) = @_; + if ($$self{complain_die} && $self->errors_seen) { + croak ("POD document had syntax errors"); + } + return if $self->bare_output; + return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING}); + $self->output (q(.\" [End document]) . "\n") if DEBUG; +} + +# Try to figure out the name and section from the file name and return them as +# a list, returning an empty name and section 1 if we can't find any better +# information. Uses File::Basename and File::Spec as necessary. +sub devise_title { + my ($self) = @_; + my $name = $self->source_filename || ''; + my $section = $$self{section} || 1; + $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i); + $name =~ s/\.p(od|[lm])\z//i; + + # If Pod::Parser gave us an IO::File reference as the source file name, + # convert that to the empty string as well. Then, if we don't have a + # valid name, convert it to STDIN. + # + # In podlators 4.00 through 4.07, this also produced a warning, but that + # was surprising to a lot of programs that had expected to be able to pipe + # POD through pod2man without specifying the name. In the name of + # backward compatibility, just quietly set STDIN as the page title. + if ($name =~ /^IO::File(?:=\w+)\(0x[\da-f]+\)$/i) { + $name = ''; + } + if ($name eq '') { + $name = 'STDIN'; + } + + # If the section isn't 3, then the name defaults to just the basename of + # the file. + if ($section !~ /^3/) { + require File::Basename; + $name = uc File::Basename::basename ($name); + } else { + require File::Spec; + my ($volume, $dirs, $file) = File::Spec->splitpath ($name); + + # Otherwise, assume we're dealing with a module. We want to figure + # out the full module name from the path to the file, but we don't + # want to include too much of the path into the module name. Lose + # anything up to the first of: + # + # */lib/*perl*/ standard or site_perl module + # */*perl*/lib/ from -Dprefix=/opt/perl + # */*perl*/ random module hierarchy + # + # Also strip off a leading site, site_perl, or vendor_perl component, + # any OS-specific component, and any version number component, and + # strip off an initial component of "lib" or "blib/lib" since that's + # what ExtUtils::MakeMaker creates. + # + # splitdir requires at least File::Spec 0.8. + my @dirs = File::Spec->splitdir ($dirs); + if (@dirs) { + my $cut = 0; + my $i; + for ($i = 0; $i < @dirs; $i++) { + if ($dirs[$i] =~ /perl/) { + $cut = $i + 1; + $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); + last; + } + } + if ($cut > 0) { + splice (@dirs, 0, $cut); + shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/); + shift @dirs if ($dirs[0] =~ /^[\d.]+$/); + shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); + } + shift @dirs if $dirs[0] eq 'lib'; + splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); + } + + # Remove empty directories when building the module name; they + # occur too easily on Unix by doubling slashes. + $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file); + } + return ($name, $section); +} + +# Determine the modification date and return that, properly formatted in ISO +# format. +# +# If POD_MAN_DATE is set, that overrides anything else. This can be used for +# reproducible generation of the same file even if the input file timestamps +# are unpredictable or the POD comes from standard input. +# +# Otherwise, if SOURCE_DATE_EPOCH is set and can be parsed as seconds since +# the UNIX epoch, base the timestamp on that. See +# +# +# Otherwise, use the modification date of the input if we can stat it. Be +# aware that Pod::Simple returns the stringification of the file handle as +# source_filename for input from a file handle, so we'll stat some random ref +# string in that case. If that fails, instead use the current time. +# +# $self - Pod::Man object, used to get the source file +# +# Returns: YYYY-MM-DD date suitable for the left-hand footer +sub devise_date { + my ($self) = @_; + + # If POD_MAN_DATE is set, always use it. + if (defined($ENV{POD_MAN_DATE})) { + return $ENV{POD_MAN_DATE}; + } + + # If SOURCE_DATE_EPOCH is set and can be parsed, use that. + my $time; + if (defined($ENV{SOURCE_DATE_EPOCH}) && $ENV{SOURCE_DATE_EPOCH} !~ /\D/) { + $time = $ENV{SOURCE_DATE_EPOCH}; + } + + # Otherwise, get the input filename and try to stat it. If that fails, + # use the current time. + if (!defined $time) { + my $input = $self->source_filename; + if ($input) { + $time = (stat($input))[9] || time(); + } else { + $time = time(); + } + } + + # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker uses + # this and it has to work in the core which can't load dynamic libraries. + # Use gmtime instead of localtime so that the generated man page does not + # depend on the local time zone setting and is more reproducible + my ($year, $month, $day) = (gmtime($time))[5,4,3]; + return sprintf("%04d-%02d-%02d", $year + 1900, $month + 1, $day); +} + +# Print out the preamble and the title. The meaning of the arguments to .TH +# unfortunately vary by system; some systems consider the fourth argument to +# be a "source" and others use it as a version number. Generally it's just +# presented as the left-side footer, though, so it doesn't matter too much if +# a particular system gives it another interpretation. +# +# The order of date and release used to be reversed in older versions of this +# module, but this order is correct for both Solaris and Linux. +sub preamble { + my ($self, $name, $section, $date) = @_; + my $preamble = $self->preamble_template (!$$self{utf8}); + + # Build the index line and make sure that it will be syntactically valid. + my $index = "$name $section"; + $index =~ s/\"/\"\"/g; + + # If name or section contain spaces, quote them (section really never + # should, but we may as well be cautious). + for ($name, $section) { + if (/\s/) { + s/\"/\"\"/g; + $_ = '"' . $_ . '"'; + } + } + + # Double quotes in date, since it will be quoted. + $date =~ s/\"/\"\"/g; + + # Substitute into the preamble the configuration options. + $preamble =~ s/\@CFONT\@/$$self{fixed}/; + $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/; + $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/; + chomp $preamble; + + # Get the version information. + my $version = $self->version_report; + + # Finally output everything. + $self->output (<<"----END OF HEADER----"); +.\\" Automatically generated by $version +.\\" +.\\" Standard preamble: +.\\" ======================================================================== +$preamble +.\\" ======================================================================== +.\\" +.IX Title "$index" +.TH $name $section "$date" "$$self{release}" "$$self{center}" +.\\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\\" way too many mistakes in technical documents. +.if n .ad l +.nh +----END OF HEADER---- + $self->output (".\\\" [End of preamble]\n") if DEBUG; +} + +############################################################################## +# Text blocks +############################################################################## + +# Handle a basic block of text. The only tricky part of this is if this is +# the first paragraph of text after an =over, in which case we have to change +# indentations for *roff. +sub cmd_para { + my ($self, $attrs, $text) = @_; + my $line = $$attrs{start_line}; + + # Output the paragraph. We also have to handle =over without =item. If + # there's an =over without =item, SHIFTWAIT will be set, and we need to + # handle creation of the indent here. Add the shift to SHIFTS so that it + # will be cleaned up on =back. + $self->makespace; + if ($$self{SHIFTWAIT}) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + $$self{SHIFTWAIT} = 0; + } + + # Add the line number for debugging, but not in the NAME section just in + # case the comment would confuse apropos. + $self->output (".\\\" [At source line $line]\n") + if defined ($line) && DEBUG && !$$self{IN_NAME}; + + # Force exactly one newline at the end and strip unwanted trailing + # whitespace at the end, but leave "\ " backslashed space from an S< > at + # the end of a line. Reverse the text first, to avoid having to scan the + # entire paragraph. + $text = reverse $text; + $text =~ s/\A\s*?(?= \\|\S|\z)/\n/; + $text = reverse $text; + + # Output the paragraph. + $self->output ($self->protect ($self->textmapfonts ($text))); + $self->outindex; + $$self{NEEDSPACE} = 1; + return ''; +} + +# Handle a verbatim paragraph. Put a null token at the beginning of each line +# to protect against commands and wrap in .Vb/.Ve (which we define in our +# prelude). +sub cmd_verbatim { + my ($self, $attrs, $text) = @_; + + # Ignore an empty verbatim paragraph. + return unless $text =~ /\S/; + + # Force exactly one newline at the end and strip unwanted trailing + # whitespace at the end. Reverse the text first, to avoid having to scan + # the entire paragraph. + $text = reverse $text; + $text =~ s/\A\s*/\n/; + $text = reverse $text; + + # Get a count of the number of lines before the first blank line, which + # we'll pass to .Vb as its parameter. This tells *roff to keep that many + # lines together. We don't want to tell *roff to keep huge blocks + # together. + my @lines = split (/\n/, $text); + my $unbroken = 0; + for (@lines) { + last if /^\s*$/; + $unbroken++; + } + $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT}); + + # Prepend a null token to each line. + $text =~ s/^/\\&/gm; + + # Output the results. + $self->makespace; + $self->output (".Vb $unbroken\n$text.Ve\n"); + $$self{NEEDSPACE} = 1; + return ''; +} + +# Handle literal text (produced by =for and similar constructs). Just output +# it with the minimum of changes. +sub cmd_data { + my ($self, $attrs, $text) = @_; + $text =~ s/^\n+//; + $text =~ s/\n{0,2}$/\n/; + $self->output ($text); + return ''; +} + +############################################################################## +# Headings +############################################################################## + +# Common code for all headings. This is called before the actual heading is +# output. It returns the cleaned up heading text (putting the heading all on +# one line) and may do other things, like closing bad =item blocks. +sub heading_common { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text =~ s/\s*\n\s*/ /g; + + # This should never happen; it means that we have a heading after =item + # without an intervening =back. But just in case, handle it anyway. + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + + # Output the current source line. + $self->output ( ".\\\" [At source line $line]\n" ) + if defined ($line) && DEBUG; + return $text; +} + +# First level heading. We can't output .IX in the NAME section due to a bug +# in some versions of catman, so don't output a .IX for that section. .SH +# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as +# appropriate. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\\s-?\d//g; + $text = $self->heading_common ($text, $$attrs{start_line}); + my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/); + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text))); + $self->outindex ('Header', $text) unless $isname; + $$self{NEEDSPACE} = 0; + $$self{IN_NAME} = $isname; + return ''; +} + +# Second level heading. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text))); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 0; + return ''; +} + +# Third level heading. *roff doesn't have this concept, so just put the +# heading in italics as a normal paragraph. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->makespace; + $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n"); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 1; + return ''; +} + +# Fourth level heading. *roff doesn't have this concept, so just put the +# heading as a normal paragraph. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $text = $self->heading_common ($text, $$attrs{start_line}); + $self->makespace; + $self->output ($self->textmapfonts ($text) . "\n"); + $self->outindex ('Subsection', $text); + $$self{NEEDSPACE} = 1; + return ''; +} + +############################################################################## +# Formatting codes +############################################################################## + +# All of the formatting codes that aren't handled internally by the parser, +# other than L<> and X<>. +sub cmd_b { return $_[0]->{IN_NAME} ? $_[2] : '\f(BS' . $_[2] . '\f(BE' } +sub cmd_i { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' } +sub cmd_f { return $_[0]->{IN_NAME} ? $_[2] : '\f(IS' . $_[2] . '\f(IE' } +sub cmd_c { return $_[0]->quote_literal ($_[2]) } + +# Index entries are just added to the pending entries. +sub cmd_x { + my ($self, $attrs, $text) = @_; + push (@{ $$self{INDEX} }, $text); + return ''; +} + +# Links reduce to the text that we're given, wrapped in angle brackets if it's +# a URL, followed by the URL. We take an option to suppress the URL if anchor +# text is given. We need to format the "to" value of the link before +# comparing it to the text since we may escape hyphens. +sub cmd_l { + my ($self, $attrs, $text) = @_; + if ($$attrs{type} eq 'url') { + my $to = $$attrs{to}; + if (defined $to) { + my $tag = $$self{PENDING}[-1]; + $to = $self->format_text ($$tag[1], $to); + } + if (not defined ($to) or $to eq $text) { + return "<$text>"; + } elsif ($$self{nourls}) { + return $text; + } else { + return "$text <$$attrs{to}>"; + } + } else { + return $text; + } +} + +############################################################################## +# List handling +############################################################################## + +# Handle the beginning of an =over block. Takes the type of the block as the +# first argument, and then the attr hash. This is called by the handlers for +# the four different types of lists (bullet, number, text, and block). +sub over_common_start { + my ($self, $type, $attrs) = @_; + my $line = $$attrs{start_line}; + my $indent = $$attrs{indent}; + DEBUG > 3 and print " Starting =over $type (line $line, indent ", + ($indent || '?'), "\n"; + + # Find the indentation level. + unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) { + $indent = $$self{indent}; + } + + # If we've gotten multiple indentations in a row, we need to emit the + # pending indentation for the last level that we saw and haven't acted on + # yet. SHIFTS is the stack of indentations that we've actually emitted + # code for. + if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + } + + # Now, do record-keeping. INDENTS is a stack of indentations that we've + # seen so far, and INDENT is the current level of indentation. ITEMTYPES + # is a stack of list types that we've seen. + push (@{ $$self{INDENTS} }, $$self{INDENT}); + push (@{ $$self{ITEMTYPES} }, $type); + $$self{INDENT} = $indent + 0; + $$self{SHIFTWAIT} = 1; +} + +# End an =over block. Takes no options other than the class pointer. +# Normally, once we close a block and therefore remove something from INDENTS, +# INDENTS will now be longer than SHIFTS, indicating that we also need to emit +# *roff code to close the indent. This isn't *always* true, depending on the +# circumstance. If we're still inside an indentation, we need to emit another +# .RE and then a new .RS to unconfuse *roff. +sub over_common_end { + my ($self) = @_; + DEBUG > 3 and print " Ending =over\n"; + $$self{INDENT} = pop @{ $$self{INDENTS} }; + pop @{ $$self{ITEMTYPES} }; + + # If we emitted code for that indentation, end it. + if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + + # If we're still in an indentation, *roff will have now lost track of the + # right depth of that indentation, so fix that. + if (@{ $$self{INDENTS} } > 0) { + $self->output (".RE\n"); + $self->output (".RS $$self{INDENT}\n"); + } + $$self{NEEDSPACE} = 1; + $$self{SHIFTWAIT} = 0; +} + +# Dispatch the start and end calls as appropriate. +sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) } +sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) } +sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) } +sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) } +sub end_over_bullet { $_[0]->over_common_end } +sub end_over_number { $_[0]->over_common_end } +sub end_over_text { $_[0]->over_common_end } +sub end_over_block { $_[0]->over_common_end } + +# The common handler for all item commands. Takes the type of the item, the +# attributes, and then the text of the item. +# +# Emit an index entry for anything that's interesting, but don't emit index +# entries for things like bullets and numbers. Newlines in an item title are +# turned into spaces since *roff can't handle them embedded. +sub item_common { + my ($self, $type, $attrs, $text) = @_; + my $line = $$attrs{start_line}; + DEBUG > 3 and print " $type item (line $line): $text\n"; + + # Clean up the text. We want to end up with two variables, one ($text) + # which contains any body text after taking out the item portion, and + # another ($item) which contains the actual item text. + $text =~ s/\s+$//; + my ($item, $index); + if ($type eq 'bullet') { + $item = "\\\(bu"; + $text =~ s/\n*$/\n/; + } elsif ($type eq 'number') { + $item = $$attrs{number} . '.'; + } else { + $item = $text; + $item =~ s/\s*\n\s*/ /g; + $text = ''; + $index = $item if ($item =~ /\w/); + } + + # Take care of the indentation. If shifts and indents are equal, close + # the top shift, since we're about to create an indentation with .IP. + # Also output .PD 0 to turn off spacing between items if this item is + # directly following another one. We only have to do that once for a + # whole chain of items so do it for the second item in the change. Note + # that makespace is what undoes this. + if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + $self->output (".PD 0\n") if ($$self{ITEMS} == 1); + + # Now, output the item tag itself. + $item = $self->textmapfonts ($item); + $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT})); + $$self{NEEDSPACE} = 0; + $$self{ITEMS}++; + $$self{SHIFTWAIT} = 0; + + # If body text for this item was included, go ahead and output that now. + if ($text) { + $text =~ s/\s*$/\n/; + $self->makespace; + $self->output ($self->protect ($self->textmapfonts ($text))); + $$self{NEEDSPACE} = 1; + } + $self->outindex ($index ? ('Item', $index) : ()); +} + +# Dispatch the item commands to the appropriate place. +sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) } +sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) } +sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) } +sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) } + +############################################################################## +# Backward compatibility +############################################################################## + +# Reset the underlying Pod::Simple object between calls to parse_from_file so +# that the same object can be reused to convert multiple pages. +sub parse_from_file { + my $self = shift; + $self->reinit; + + # Fake the old cutting option to Pod::Parser. This fiddles with internal + # Pod::Simple state and is quite ugly; we need a better approach. + if (ref ($_[0]) eq 'HASH') { + my $opts = shift @_; + if (defined ($$opts{-cutting}) && !$$opts{-cutting}) { + $$self{in_pod} = 1; + $$self{last_was_blank} = 1; + } + } + + # Do the work. + my $retval = $self->SUPER::parse_from_file (@_); + + # Flush output, since Pod::Simple doesn't do this. Ideally we should also + # close the file descriptor if we had to open one, but we can't easily + # figure this out. + my $fh = $self->output_fh (); + my $oldfh = select $fh; + my $oldflush = $|; + $| = 1; + print $fh ''; + $| = $oldflush; + select $oldfh; + return $retval; +} + +# Pod::Simple failed to provide this backward compatibility function, so +# implement it ourselves. File handles are one of the inputs that +# parse_from_file supports. +sub parse_from_filehandle { + my $self = shift; + return $self->parse_from_file (@_); +} + +# Pod::Simple's parse_file doesn't set output_fh. Wrap the call and do so +# ourself unless it was already set by the caller, since our documentation has +# always said that this should work. +sub parse_file { + my ($self, $in) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_file ($in); +} + +# Do the same for parse_lines, just to be polite. Pod::Simple's man page +# implies that the caller is responsible for setting this, but I don't see any +# reason not to set a default. +sub parse_lines { + my ($self, @lines) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_lines (@lines); +} + +# Likewise for parse_string_document. +sub parse_string_document { + my ($self, $doc) = @_; + unless (defined $$self{output_fh}) { + $self->output_fh (\*STDOUT); + } + return $self->SUPER::parse_string_document ($doc); +} + +############################################################################## +# Translation tables +############################################################################## + +# The following table is adapted from Tom Christiansen's pod2man. It assumes +# that the standard preamble has already been printed, since that's what +# defines all of the accent marks. We really want to do something better than +# this when *roff actually supports other character sets itself, since these +# results are pretty poor. +# +# This only works in an ASCII world. What to do in a non-ASCII world is very +# unclear -- hopefully we can assume UTF-8 and just leave well enough alone. +@ESCAPES{0xA0 .. 0xFF} = ( + "\\ ", undef, undef, undef, undef, undef, undef, undef, + undef, undef, undef, undef, undef, "\\%", undef, undef, + + undef, undef, undef, undef, undef, undef, undef, undef, + undef, undef, undef, undef, undef, undef, undef, undef, + + "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(Ae", "C\\*,", + "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:", + + "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef, + "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8", + + "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,", + "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:", + + "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef, + "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:", +) if ASCII; + +############################################################################## +# Premable +############################################################################## + +# The following is the static preamble which starts all *roff output we +# generate. Most is static except for the font to use as a fixed-width font, +# which is designed by @CFONT@, and the left and right quotes to use for C<> +# text, designated by @LQOUTE@ and @RQUOTE@. However, the second part, which +# defines the accent marks, is only used if $escapes is set to true. +sub preamble_template { + my ($self, $accents) = @_; + my $preamble = <<'----END OF PREAMBLE----'; +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft @CFONT@ +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" Set up some character translations and predefined strings. \*(-- will +.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left +.\" double quote, and \*(R" will give a right double quote. \*(C+ will +.\" give a nicer C++. Capital omega is used to do unbreakable dashes and +.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, +.\" nothing in troff, for use with C<>. +.tr \(*W- +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.ie n \{\ +. ds -- \(*W- +. ds PI pi +. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +. ds L" "" +. ds R" "" +. ds C` @LQUOTE@ +. ds C' @RQUOTE@ +'br\} +.el\{\ +. ds -- \|\(em\| +. ds PI \(*p +. ds L" `` +. ds R" '' +. ds C` +. ds C' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is >0, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.\" +.\" Avoid warning from groff about undefined register 'F'. +.de IX +.. +.nr rF 0 +.if \n(.g .if rF .nr rF 1 +.if (\n(rF:(\n(.g==0)) \{\ +. if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. if !\nF==2 \{\ +. nr % 0 +. nr F 2 +. \} +. \} +.\} +.rr rF +----END OF PREAMBLE---- +#'# for cperl-mode + + if ($accents) { + $preamble .= <<'----END OF PREAMBLE----' +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +----END OF PREAMBLE---- +#`# for cperl-mode + } + return $preamble; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +use 5.006; # we use some open(X, "<", $y) syntax + +package Pod::Perldoc; +use strict; +use warnings; +use Config '%Config'; + +use Fcntl; # for sysopen +use File::Basename qw(basename); +use File::Spec::Functions qw(catfile catdir splitdir); + +use vars qw($VERSION @Pagers $Bindir $Pod2man + $Temp_Files_Created $Temp_File_Lifetime +); +$VERSION = '3.2801'; + +#.......................................................................... + +BEGIN { # Make a DEBUG constant very first thing... + unless(defined &DEBUG) { + if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint + eval("sub DEBUG () {$1}"); + die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; + } else { + *DEBUG = sub () {0}; + } + } +} + +use Pod::Perldoc::GetOptsOO; # uses the DEBUG. +use Carp qw(croak carp); + +# these are also in BaseTo, which I don't want to inherit +sub debugging { + my $self = shift; + + ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() ) + } + +sub debug { + my( $self, @messages ) = @_; + return unless $self->debugging; + print STDERR map { "DEBUG : $_" } @messages; + } + +sub warn { + my( $self, @messages ) = @_; + + carp( join "\n", @messages, '' ); + } + +sub die { + my( $self, @messages ) = @_; + + croak( join "\n", @messages, '' ); + } + +#.......................................................................... + +sub TRUE () {1} +sub FALSE () {return} +sub BE_LENIENT () {1} + +BEGIN { + *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms; + *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32; + *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos; + *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2; + *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin; + *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; + *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; + *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; +} + +$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; + # If it's older than five days, it's quite unlikely + # that anyone's still looking at it!! + # (Currently used only by the MSWin cleanup routine) + + +#.......................................................................... +{ my $pager = $Config{'pager'}; + push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms; +} +$Bindir = $Config{'scriptdirexp'}; +$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); + +# End of class-init stuff +# +########################################################################### +# +# Option accessors... + +foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULva}) { + no strict 'refs'; + *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; +} + +# And these are so that GetOptsOO knows they take options: +sub opt_a_with { shift->_elem('opt_a', @_) } +sub opt_f_with { shift->_elem('opt_f', @_) } +sub opt_q_with { shift->_elem('opt_q', @_) } +sub opt_d_with { shift->_elem('opt_d', @_) } +sub opt_L_with { shift->_elem('opt_L', @_) } +sub opt_v_with { shift->_elem('opt_v', @_) } + +sub opt_w_with { # Specify an option for the formatter subclass + my($self, $value) = @_; + if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { + my $option = $1; + my $option_value = defined($2) ? $2 : "TRUE"; + $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" + $self->add_formatter_option( $option, $option_value ); + } else { + $self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) ); + } + return; +} + +sub opt_M_with { # specify formatter class name(s) + my($self, $classes) = @_; + return unless defined $classes and length $classes; + DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; + my @classes_to_add; + foreach my $classname (split m/[,;]+/s, $classes) { + next unless $classname =~ m/\S/; + if( $classname =~ m/^(\w+(::\w+)+)$/s ) { + # A mildly restrictive concept of what modulenames are valid. + push @classes_to_add, $1; # untaint + } else { + $self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) ); + } + } + + unshift @{ $self->{'formatter_classes'} }, @classes_to_add; + + DEBUG > 3 and print( + "Adding @classes_to_add to the list of formatter classes, " + . "making them @{ $self->{'formatter_classes'} }.\n" + ); + + return; +} + +sub opt_V { # report version and exit + print join '', + "Perldoc v$VERSION, under perl v$] for $^O", + + (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) + ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), + + (chr(65) eq 'A') ? () : " (non-ASCII)", + + "\n", + ; + exit; +} + +sub opt_t { # choose plaintext as output format + my $self = shift; + $self->opt_o_with('text') if @_ and $_[0]; + return $self->_elem('opt_t', @_); +} + +sub opt_u { # choose raw pod as output format + my $self = shift; + $self->opt_o_with('pod') if @_ and $_[0]; + return $self->_elem('opt_u', @_); +} + +sub opt_n_with { + # choose man as the output format, and specify the proggy to run + my $self = shift; + $self->opt_o_with('man') if @_ and $_[0]; + $self->_elem('opt_n', @_); +} + +sub opt_o_with { # "o" for output format + my($self, $rest) = @_; + return unless defined $rest and length $rest; + if($rest =~ m/^(\w+)$/s) { + $rest = $1; #untaint + } else { + $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") ); + return; + } + + $self->aside("Noting \"$rest\" as desired output format...\n"); + + # Figure out what class(es) that could actually mean... + + my @classes; + foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { + # Messy but smart: + foreach my $stem ( + $rest, # Yes, try it first with the given capitalization + "\L$rest", "\L\u$rest", "\U$rest" # And then try variations + + ) { + $self->aside("Considering $prefix$stem\n"); + push @classes, $prefix . $stem; + } + + # Tidier, but misses too much: + #push @classes, $prefix . ucfirst(lc($rest)); + } + $self->opt_M_with( join ";", @classes ); + return; +} + +########################################################################### +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % + +sub run { # to be called by the "perldoc" executable + my $class = shift; + if(DEBUG > 3) { + print "Parameters to $class\->run:\n"; + my @x = @_; + while(@x) { + $x[1] = '' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + return $class -> new(@_) -> process() || 0; +} + +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % +########################################################################### + +sub new { # yeah, nothing fancy + my $class = shift; + my $new = bless {@_}, (ref($class) || $class); + DEBUG > 1 and print "New $class object $new\n"; + $new->init(); + $new; +} + +#.......................................................................... + +sub aside { # If we're in -D or DEBUG mode, say this. + my $self = shift; + if( DEBUG or $self->opt_D ) { + my $out = join( '', + DEBUG ? do { + my $callsub = (caller(1))[3]; + my $package = quotemeta(__PACKAGE__ . '::'); + $callsub =~ s/^$package/'/os; + # the o is justified, as $package really won't change. + $callsub . ": "; + } : '', + @_, + ); + if(DEBUG) { print $out } else { print STDERR $out } + } + return; +} + +#.......................................................................... + +sub usage { + my $self = shift; + $self->warn( "@_\n" ) if @_; + + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; + + CORE::die( <debug( "The value in $0 is a symbolic link to $link\n" ); + } + + my $basename = basename( $0 ); + + $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" ); + # possible name forms + # perldoc + # perldoc-v5.14 + # perldoc-5.14 + # perldoc-5.14.2 + # perlvar # an alias mentioned in Camel 3 + { + my( $untainted ) = $basename =~ m/( + \A + perl + (?: doc | func | faq | help | op | toc | var # Camel 3 + ) + (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version + (?: \. (?: bat | exe | com ) )? # possible extension + \z + ) + /x; + + $self->debug($untainted); + return $untainted if $untainted; + } + + $self->warn(<<"HERE"); +You called the perldoc command with a name that I didn't recognize. +This might mean that someone is tricking you into running a +program you don't intend to use, but it also might mean that you +created your own link to perldoc. I think your program name is +[$basename]. + +I'll allow this if the filename only has [a-zA-Z0-9._-]. +HERE + + { + my( $untainted ) = $basename =~ m/( + \A [a-zA-Z0-9._-]+ \z + )/x; + + $self->debug($untainted); + return $untainted if $untainted; + } + + $self->die(<<"HERE"); +I think that your name for perldoc is potentially unsafe, so I'm +going to disallow it. I'd rather you be safe than sorry. If you +intended to use the name I'm disallowing, please tell the maintainers +about it. Write to: + + Pod-Perldoc\@rt.cpan.org + +HERE +} + +#.......................................................................... + +sub usage_brief { + my $self = shift; + my $program_name = $self->program_name; + + CORE::die( <<"EOUSAGE" ); +Usage: $program_name [-hVriDtumUFXlT] [-n nroffer_program] + [-d output_filename] [-o output_format] [-M FormatterModule] + [-w formatter_option:option_value] [-L translation_code] + PageName|ModuleName|ProgramName + +Examples: + + $program_name -f PerlFunc + $program_name -q FAQKeywords + $program_name -v PerlVar + $program_name -a PerlAPI + +The -h option prints more help. Also try "$program_name perldoc" to get +acquainted with the system. [Perldoc v$VERSION] +EOUSAGE + +} + +#.......................................................................... + +sub pagers { @{ shift->{'pagers'} } } + +#.......................................................................... + +sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) + if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } + else { return $_[0]{ $_[1] } } +} +#.......................................................................... +########################################################################### +# +# Init formatter switches, and start it off with __bindir and all that +# other stuff that ToMan.pm needs. +# + +sub init { + my $self = shift; + + # Make sure creat()s are neither too much nor too little + eval { umask(0077) }; # doubtless someone has no mask + + if ( $] < 5.008 ) { + $self->aside("Your old perl doesn't have proper unicode support."); + } + else { + # http://www.perl.com/pub/2012/04/perlunicookbook-decode-argv-as-utf8.html + # Decode command line arguments as UTF-8. See RT#98906 for example problem. + use Encode qw(decode_utf8); + @ARGV = map { decode_utf8($_, 1) } @ARGV; + } + + $self->{'args'} ||= \@ARGV; + $self->{'found'} ||= []; + $self->{'temp_file_list'} ||= []; + + + $self->{'target'} = undef; + + $self->init_formatter_class_list; + + $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; + $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; + $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; + $self->{'search_path'} = [ ] unless exists $self->{'search_path'}; + + push @{ $self->{'formatter_switches'} = [] }, ( + # Yeah, we could use a hashref, but maybe there's some class where options + # have to be ordered; so we'll use an arrayref. + + [ '__bindir' => $self->{'bindir' } ], + [ '__pod2man' => $self->{'pod2man'} ], + ); + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + $self->{'translators'} = []; + $self->{'extra_search_dirs'} = []; + + return; +} + +#.......................................................................... + +sub init_formatter_class_list { + my $self = shift; + $self->{'formatter_classes'} ||= []; + + # Remember, no switches have been read yet, when + # we've started this routine. + + $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru + $self->opt_o_with('text'); + + return; +} + +#.......................................................................... + +sub process { + # if this ever returns, its retval will be used for exit(RETVAL) + + my $self = shift; + DEBUG > 1 and print " Beginning process.\n"; + DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; + if(DEBUG > 3) { + print "Object contents:\n"; + my @x = %$self; + while(@x) { + $x[1] = '' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + + # TODO: make it deal with being invoked as various different things + # such as perlfaq". + + return $self->usage_brief unless @{ $self->{'args'} }; + $self->options_reading; + $self->pagers_guessing; + $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); + $self->drop_privs_maybe unless ($self->opt_U || $self->opt_F); + $self->options_processing; + + # Hm, we have @pages and @found, but we only really act on one + # file per call, with the exception of the opt_q hack, and with + # -l things + + $self->aside("\n"); + + my @pages; + $self->{'pages'} = \@pages; + if( $self->opt_f) { @pages = qw(perlfunc perlop) } + elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } + elsif( $self->opt_v) { @pages = ("perlvar") } + elsif( $self->opt_a) { @pages = ("perlapi") } + else { @pages = @{$self->{'args'}}; + # @pages = __FILE__ + # if @pages == 1 and $pages[0] eq 'perldoc'; + } + + return $self->usage_brief unless @pages; + + $self->find_good_formatter_class(); + $self->formatter_sanity_check(); + + $self->maybe_extend_searchpath(); + # for when we're apparently in a module or extension directory + + my @found = $self->grand_search_init(\@pages); + exit ($self->is_vms ? 98962 : 1) unless @found; + + if ($self->opt_l and not $self->opt_q ) { + DEBUG and print "We're in -l mode, so byebye after this:\n"; + print join("\n", @found), "\n"; + return; + } + + $self->tweak_found_pathnames(\@found); + $self->assert_closing_stdout; + return $self->page_module_file(@found) if $self->opt_m; + DEBUG > 2 and print "Found: [@found]\n"; + + return $self->render_and_page(\@found); +} + +#.......................................................................... +{ + +my( %class_seen, %class_loaded ); +sub find_good_formatter_class { + my $self = $_[0]; + my @class_list = @{ $self->{'formatter_classes'} || [] }; + $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list; + + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + + my $good_class_found; + foreach my $c (@class_list) { + DEBUG > 4 and print "Trying to load $c...\n"; + if($class_loaded{$c}) { + DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; + $good_class_found = $c; + last; + } + + if($class_seen{$c}) { + DEBUG > 4 and print + "I've tried $c before, and it's no good. Skipping.\n"; + next; + } + + $class_seen{$c} = 1; + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print + "Interesting, the formatter class $c is already loaded!\n"; + + } elsif( + ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2) + # the always case-insensitive filesystems + and $class_seen{lc("~$c")}++ + ) { + DEBUG > 4 and print + "We already used something quite like \"\L$c\E\", so no point using $c\n"; + # This avoids redefining the package. + } else { + DEBUG > 4 and print "Trying to eval 'require $c'...\n"; + + local $^W = $^W; + if(DEBUG() or $self->opt_D) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressible warnings from the require! + } + + eval "require $c"; + if($@) { + DEBUG > 4 and print "Couldn't load $c: $!\n"; + next; + } + } + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print "Settling on $c\n"; + my $v = $c->VERSION; + $v = ( defined $v and length $v ) ? " version $v" : ''; + $self->aside("Formatter class $c$v successfully loaded!\n"); + $good_class_found = $c; + last; + } else { + DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; + } + } + + $self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" ) + unless $good_class_found; + + $self->{'formatter_class'} = $good_class_found; + $self->aside("Will format with the class $good_class_found\n"); + + return; +} + +} +#.......................................................................... + +sub formatter_sanity_check { + my $self = shift; + my $formatter_class = $self->{'formatter_class'} + || $self->die( "NO FORMATTER CLASS YET!?" ); + + if(!$self->opt_T # so -T can FORCE sending to STDOUT + and $formatter_class->can('is_pageable') + and !$formatter_class->is_pageable + and !$formatter_class->can('page_for_perldoc') + ) { + my $ext = + ($formatter_class->can('output_extension') + && $formatter_class->output_extension + ) || ''; + $ext = ".$ext" if length $ext; + + my $me = $self->program_name; + $self->die( + "When using Perldoc to format with $formatter_class, you have to\n" + . "specify -T or -dsomefile$ext\n" + . "See `$me perldoc' for more information on those switches.\n" ) + ; + } +} + +#.......................................................................... + +sub render_and_page { + my($self, $found_list) = @_; + + $self->maybe_generate_dynamic_pod($found_list); + + my($out, $formatter) = $self->render_findings($found_list); + + if($self->opt_d) { + printf "Perldoc (%s) output saved to %s\n", + $self->{'formatter_class'} || ref($self), + $out; + print "But notice that it's 0 bytes long!\n" unless -s $out; + + + } elsif( # Allow the formatter to "page" itself, if it wants. + $formatter->can('page_for_perldoc') + and do { + $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); + if( $formatter->page_for_perldoc($out, $self) ) { + $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); + 1; + } else { + $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); + ''; + } + } + ) { + # Do nothing, since the formatter has "paged" it for itself. + + } else { + # Page it normally (internally) + + if( -s $out ) { # Usual case: + $self->page($out, $self->{'output_to_stdout'}, $self->pagers); + + } else { + # Odd case: + $self->aside("Skipping $out (from $$found_list[0] " + . "via $$self{'formatter_class'}) as it is 0-length.\n"); + + push @{ $self->{'temp_file_list'} }, $out; + $self->unlink_if_temp_file($out); + } + } + + $self->after_rendering(); # any extra cleanup or whatever + + return; +} + +#.......................................................................... + +sub options_reading { + my $self = shift; + + if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { + require Text::ParseWords; + $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); + # Yes, appends to the beginning + unshift @{ $self->{'args'} }, + Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) + ; + DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; + } else { + DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; + } + + DEBUG > 1 + and print " Args right before switch processing: @{$self->{'args'}}\n"; + + Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) + or return $self->usage; + + DEBUG > 1 + and print " Args after switch processing: @{$self->{'args'}}\n"; + + return $self->usage if $self->opt_h; + + return; +} + +#.......................................................................... + +sub options_processing { + my $self = shift; + + if ($self->opt_X) { + my $podidx = "$Config{'archlib'}/pod.idx"; + $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; + $self->{'podidx'} = $podidx; + } + + $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; + + $self->options_sanity; + + # This used to set a default, but that's now moved into any + # formatter that cares to have a default. + if( $self->opt_n ) { + $self->add_formatter_option( '__nroffer' => $self->opt_n ); + } + + # Get language from PERLDOC_POD2 environment variable + if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) { + if ( $ENV{PERLDOC_POD2} eq '1' ) { + $self->_elem('opt_L',(split(/\_/, $ENV{LC_ALL} || $ENV{LC_LANG} || $ENV{LANG}))[0] ); + } + else { + $self->_elem('opt_L', $ENV{PERLDOC_POD2}); + } + }; + + # Adjust for using translation packages + $self->add_translator(split(/\s+/,$self->opt_L)) if $self->opt_L; + + return; +} + +#.......................................................................... + +sub options_sanity { + my $self = shift; + + # The opts-counting stuff interacts quite badly with + # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} + # set to -t, and I specify -u on the command line, I don't want + # to be hectored at that -u and -t don't make sense together. + + #my $opts = grep $_ && 1, # yes, the count of the set ones + # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l + #; + # + #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; + + + # Any sanity-checking need doing here? + + # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} + if( $self->opt_f or $self->opt_q or $self->opt_a) { + my $count; + $count++ if $self->opt_f; + $count++ if $self->opt_q; + $count++ if $self->opt_a; + $self->usage("Only one of -f or -q or -a") if $count > 1; + $self->warn( + "Perldoc is meant for reading one file at a time.\n", + "So these parameters are being ignored: ", + join(' ', @{$self->{'args'}}), + "\n" ) + if @{$self->{'args'}} + } + return; +} + +#.......................................................................... + +sub grand_search_init { + my($self, $pages, @found) = @_; + + foreach (@$pages) { + if (/^http(s)?:\/\//) { + require HTTP::Tiny; + require File::Temp; + my $response = HTTP::Tiny->new->get($_); + if ($response->{success}) { + my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1); + $fh->print($response->{content}); + push @found, $filename; + ($self->{podnames}{$filename} = + m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN") + =~ s/\.P(?:[ML]|OD)\z//; + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + if ( /^https/ ) { + print STDERR "You may need an SSL library (such as IO::Socket::SSL) for that URL.\n"; + } + } + next; + } + if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { + my $searchfor = catfile split '::', $_; + $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); + local $_; + while () { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; + } + close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" ); + next; + } + + $self->aside( "Searching for $_\n" ); + + if ($self->opt_F) { + next unless -r; + push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_); + next; + } + + my @searchdirs; + + # prepend extra search directories (including language specific) + push @searchdirs, @{ $self->{'extra_search_dirs'} }; + + # We must look both in @INC for library modules and in $bindir + # for executables, like h2xs or perldoc itself. + push @searchdirs, ($self->{'bindir'}, @{$self->{search_path}}, @INC); + unless ($self->opt_m) { + if ($self->is_vms) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); + } + push(@searchdirs,'perl_root:[lib.pods]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = $self->searchfor(0,$_,@searchdirs); + if (@files) { + $self->aside( "Found as @files\n" ); + } + # add "perl" prefix, so "perldoc foo" may find perlfoo.pod + elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { + $self->aside( "Loosely found as @files\n" ); + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.\z/s,@INC); + @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; + if (@files) { + $self->aside( "Loosely found as @files\n" ); + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + if ( @{ $self->{'found'} } ) { + print STDERR "However, try\n"; + my $me = $self->program_name; + for my $dir (@{ $self->{'found'} }) { + opendir(DIR, $dir) or $self->die( "opendir $dir: $!" ); + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs + print STDERR "\t$me $_\::$file\n"; + } + closedir(DIR) or $self->die( "closedir $dir: $!" ); + } + } + } + } + push(@found,@files); + } + return @found; +} + +#.......................................................................... + +sub maybe_generate_dynamic_pod { + my($self, $found_things) = @_; + my @dynamic_pod; + + $self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a; + + $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; + + $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v; + + $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; + + if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) { + DEBUG > 4 and print "That's a non-dynamic pod search.\n"; + } elsif ( @dynamic_pod ) { + $self->aside("Hm, I found some Pod from that search!\n"); + my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); + if ( $] >= 5.008 && $self->opt_L ) { + binmode($buffd, ":encoding(UTF-8)"); + print $buffd "=encoding utf8\n\n"; + } + + push @{ $self->{'temp_file_list'} }, $buffer; + # I.e., it MIGHT be deleted at the end. + + my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a; + + print $buffd "=over 8\n\n" if $in_list; + print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" ); + print $buffd "=back\n" if $in_list; + + close $buffd or $self->die( "Can't close $buffer: $!" ); + + @$found_things = $buffer; + # Yes, so found_things never has more than one thing in + # it, by time we leave here + + $self->add_formatter_option('__filter_nroff' => 1); + + } else { + @$found_things = (); + $self->aside("I found no Pod from that search!\n"); + } + + return; +} + +#.......................................................................... + +sub not_dynamic { + my ($self,$value) = @_; + $self->{__not_dynamic} = $value if @_ == 2; + return $self->{__not_dynamic}; +} + +#.......................................................................... + +sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); + my $self = shift; + push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#......................................................................... + +sub new_translator { # $tr = $self->new_translator($lang); + my $self = shift; + my $lang = shift; + + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + my $pack = 'POD2::' . uc($lang); + eval "require $pack"; + if ( !$@ && $pack->can('new') ) { + return $pack->new(); + } + + eval { require POD2::Base }; + return if $@; + + return POD2::Base->new({ lang => $lang }); +} + +#......................................................................... + +sub add_translator { # $self->add_translator($lang); + my $self = shift; + for my $lang (@_) { + my $tr = $self->new_translator($lang); + if ( defined $tr ) { + push @{ $self->{'translators'} }, $tr; + push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs; + + $self->aside( "translator for '$lang' loaded\n" ); + } else { + # non-installed or bad translator package + $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" ); + } + + } + return; +} + +#.......................................................................... + +sub open_fh { + my ($self, $op, $path) = @_; + + open my $fh, $op, $path or $self->die("Couldn't open $path: $!"); + return $fh; +} + +sub set_encoding { + my ($self, $fh, $encoding) = @_; + + if ( $encoding =~ /utf-?8/i ) { + $encoding = ":encoding(UTF-8)"; + } + else { + $encoding = ":encoding($encoding)"; + } + + if ( $] < 5.008 ) { + $self->aside("Your old perl doesn't have proper unicode support."); + } + else { + binmode($fh, $encoding); + } + + return $fh; +} + +sub search_perlvar { + my($self, $found_things, $pod) = @_; + + my $opt = $self->opt_v; + + if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) { + CORE::die( "'$opt' does not look like a Perl variable\n" ); + } + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlvar = shift @$found_things; + my $fh = $self->open_fh("<", $perlvar); + + if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ... + $opt = '$>'; + } + my $search_re = quotemeta($opt); + + DEBUG > 2 and + print "Going to perlvar-scan for $search_re in $perlvar\n"; + + # Skip introduction + local $_; + my $enc; + while (<$fh>) { + $enc = $1 if /^=encoding\s+(\S+)/; + last if /^=over 8/; + } + + $fh = $self->set_encoding($fh, $enc) if $enc; + + # Look for our variable + my $found = 0; + my $inheader = 1; + my $inlist = 0; + while (<$fh>) { + last if /^=head2 Error Indicators/; + # \b at the end of $` and friends borks things! + if ( m/^=item\s+$search_re\s/ ) { + $found = 1; + } + elsif (/^=item/) { + last if $found && !$inheader && !$inlist; + } + elsif (!/^\s+$/) { # not a blank line + if ( $found ) { + $inheader = 0; # don't accept more =item (unless inlist) + } + else { + @$pod = (); # reset + $inheader = 1; # start over + next; + } + } + + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + last if $found && !$inheader && !$inlist; + --$inlist; + } + push @$pod, $_; +# ++$found if /^\w/; # found descriptive text + } + @$pod = () unless $found; + if (!@$pod) { + CORE::die( "No documentation for perl variable '$opt' found\n" ); + } + close $fh or $self->die( "Can't close $perlvar: $!" ); + + return; +} + +#.......................................................................... + +sub search_perlop { + my ($self,$found_things,$pod) = @_; + + $self->not_dynamic( 1 ); + + my $perlop = shift @$found_things; + # XXX FIXME: getting filehandles should probably be done in a single place + # especially since we need to support UTF8 or other encoding when dealing + # with perlop, perlfunc, perlapi, perlfaq[1-9] + my $fh = $self->open_fh('<', $perlop); + + my $thing = $self->opt_f; + + my $previous_line; + my $push = 0; + my $seen_item = 0; + my $skip = 1; + + while( my $line = <$fh> ) { + $line =~ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); + # only start search after we hit the operator section + if ($line =~ m!^X!) { + $skip = 0; + } + + next if $skip; + + # strategy is to capture the previous line until we get a match on X<$thingy> + # if the current line contains X<$thingy>, then we push "=over", the previous line, + # the current line and keep pushing current line until we see a ^X, + # then we chop off final line from @$pod and add =back + # + # At that point, Bob's your uncle. + + if ( $line =~ m!X<+\s*\Q$thing\E\s*>+!) { + if ( $previous_line ) { + push @$pod, "=over 8\n\n", $previous_line; + $previous_line = ""; + } + push @$pod, $line; + $push = 1; + + } + elsif ( $push and $line =~ m!^=item\s*.*$! ) { + $seen_item = 1; + } + elsif ( $push and $seen_item and $line =~ m!^X<+\s*[ a-z,?-]+\s*>+!) { + $push = 0; + $seen_item = 0; + last; + } + elsif ( $push ) { + push @$pod, $line; + } + + else { + $previous_line = $line; + } + + } #end while + + # we overfilled by 1 line, so pop off final array element if we have any + if ( scalar @$pod ) { + pop @$pod; + + # and add the =back + push @$pod, "\n\n=back\n"; + DEBUG > 8 and print "PERLOP POD --->" . (join "", @$pod) . "<---\n"; + } + else { + DEBUG > 4 and print "No pod from perlop\n"; + } + + close $fh; + + return; +} + +#.......................................................................... + +sub search_perlapi { + my($self, $found_things, $pod) = @_; + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlapi = shift @$found_things; + my $fh = $self->open_fh('<', $perlapi); + + my $search_re = quotemeta($self->opt_a); + + DEBUG > 2 and + print "Going to perlapi-scan for $search_re in $perlapi\n"; + + local $_; + + # Look for our function + my $found = 0; + my $inlist = 0; + + my @related; + my $related_re; + while (<$fh>) { + /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); + + if ( m/^=item\s+$search_re\b/ ) { + $found = 1; + } + elsif (@related > 1 and /^=item/) { + $related_re ||= join "|", @related; + if (m/^=item\s+(?:$related_re)\b/) { + $found = 1; + } + else { + last; + } + } + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + elsif ($found and /^X<[^>]+>/) { + push @related, m/X<([^>]+)>/g; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + last if $found > 1 and not $inlist; + --$inlist; + } + push @$pod, $_; + ++$found if /^\w/; # found descriptive text + } + + if (!@$pod) { + CORE::die( sprintf + "No documentation for perl api function '%s' found\n", + $self->opt_a ) + ; + } + close $fh or $self->die( "Can't open $perlapi: $!" ); + + return; +} + +#.......................................................................... + +sub search_perlfunc { + my($self, $found_things, $pod) = @_; + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $pfunc = shift @$found_things; + my $fh = $self->open_fh("<", $pfunc); # "Funk is its own reward" + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? '(?:I<)?-X' : quotemeta($self->opt_f) ; + + DEBUG > 2 and + print "Going to perlfunc-scan for $search_re in $pfunc\n"; + + my $re = 'Alphabetical Listing of Perl Functions'; + + # Check available translator or backup to default (english) + if ( $self->opt_L && defined $self->{'translators'}->[0] ) { + my $tr = $self->{'translators'}->[0]; + $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re'); + if ( $] < 5.008 ) { + $self->aside("Your old perl doesn't really have proper unicode support."); + } + } + + # Skip introduction + local $_; + while (<$fh>) { + /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); + last if /^=head2 (?:$re|Alphabetical Listing of Perl Functions)/; + } + + # Look for our function + my $found = 0; + my $inlist = 0; + + my @perlops = qw(m q qq qr qx qw s tr y); + + my @related; + my $related_re; + while (<$fh>) { # "The Mothership Connection is here!" + last if( grep{ $self->opt_f eq $_ }@perlops ); + + if ( /^=over/ and not $found ) { + ++$inlist; + } + elsif ( /^=back/ and not $found and $inlist ) { + --$inlist; + } + + + if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) { + $found = 1; + } + elsif (@related > 1 and /^=item/) { + $related_re ||= join "|", @related; + if (m/^=item\s+(?:$related_re)\b/) { + $found = 1; + } + else { + last if $found > 1 and $inlist < 2; + } + } + elsif (/^=item|^=back/) { + last if $found > 1 and $inlist < 2; + } + elsif ($found and /^X<[^>]+>/) { + push @related, m/X<([^>]+)>/g; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; + } + push @$pod, $_; + ++$found if /^\w/; # found descriptive text + } + + if( !@$pod ){ + $self->search_perlop( $found_things, $pod ); + } + + if (!@$pod) { + CORE::die( sprintf + "No documentation for perl function '%s' found\n", + $self->opt_f ) + ; + } + close $fh or $self->die( "Can't close $pfunc: $!" ); + + return; +} + +#.......................................................................... + +sub search_perlfaqs { + my( $self, $found_things, $pod) = @_; + + my $found = 0; + my %found_in; + my $search_key = $self->opt_q; + + my $rx = eval { qr/$search_key/ } + or $self->die( <die( "invalid file spec: $!" ) if $file =~ /[<>|]/; + my $fh = $self->open_fh("<", $file); + while (<$fh>) { + /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); + if ( m/^=head2\s+.*(?:$search_key)/i ) { + $found = 1; + push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; + } + elsif (/^=head[12]/) { + $found = 0; + } + next unless $found; + push @$pod, $_; + } + close($fh); + } + CORE::die("No documentation for perl FAQ keyword '$search_key' found\n") + unless @$pod; + + if ( $self->opt_l ) { + CORE::die((join "\n", keys %found_in) . "\n"); + } + return; +} + + +#.......................................................................... + +sub render_findings { + # Return the filename to open + + my($self, $found_things) = @_; + + my $formatter_class = $self->{'formatter_class'} + || $self->die( "No formatter class set!?" ); + my $formatter = $formatter_class->can('new') + ? $formatter_class->new + : $formatter_class + ; + + if(! @$found_things) { + $self->die( "Nothing found?!" ); + # should have been caught before here + } elsif(@$found_things > 1) { + $self->warn( + "Perldoc is only really meant for reading one document at a time.\n", + "So these parameters are being ignored: ", + join(' ', @$found_things[1 .. $#$found_things] ), + "\n" ); + } + + my $file = $found_things->[0]; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + # Set formatter options: + if( ref $formatter ) { + foreach my $f (@{ $self->{'formatter_switches'} || [] }) { + my($switch, $value, $silent_fail) = @$f; + if( $formatter->can($switch) ) { + eval { $formatter->$switch( defined($value) ? $value : () ) }; + $self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" ) + if $@; + } else { + if( $silent_fail or $switch =~ m/^__/s ) { + DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; + } else { + $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" ); + } + } + } + } + + $self->{'output_is_binary'} = + $formatter->can('write_with_binmode') && $formatter->write_with_binmode; + + if( $self->{podnames} and exists $self->{podnames}{$file} and + $formatter->can('name') ) { + $formatter->name($self->{podnames}{$file}); + } + + my ($out_fh, $out) = $self->new_output_file( + ( $formatter->can('output_extension') && $formatter->output_extension ) + || undef, + $self->useful_filename_bit, + ); + + # Now, finally, do the formatting! + { + local $^W = $^W; + if(DEBUG() or $self->opt_D) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressible warnings from the formatting! + } + + eval { $formatter->parse_from_file( $file, $out_fh ) }; + } + + $self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@; + DEBUG > 2 and print "Back from formatting with $formatter_class\n"; + + close $out_fh + or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" ); + sleep 0; sleep 0; sleep 0; + # Give the system a few timeslices to meditate on the fact + # that the output file does in fact exist and is closed. + + $self->unlink_if_temp_file($file); + + unless( -s $out ) { + if( $formatter->can( 'if_zero_length' ) ) { + # Basically this is just a hook for Pod::Simple::Checker; since + # what other class could /happily/ format an input file with Pod + # as a 0-length output file? + $formatter->if_zero_length( $file, $out, $out_fh ); + } else { + $self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" ); + } + } + + DEBUG and print "Finished writing to $out.\n"; + return($out, $formatter) if wantarray; + return $out; +} + +#.......................................................................... + +sub unlink_if_temp_file { + # Unlink the specified file IFF it's in the list of temp files. + # Really only used in the case of -f / -q things when we can + # throw away the dynamically generated source pod file once + # we've formatted it. + # + my($self, $file) = @_; + return unless defined $file and length $file; + + my $temp_file_list = $self->{'temp_file_list'} || return; + if(grep $_ eq $file, @$temp_file_list) { + $self->aside("Unlinking $file\n"); + unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" ); + } else { + DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; + } + return; +} + +#.......................................................................... + + +sub after_rendering { + my $self = $_[0]; + $self->after_rendering_VMS if $self->is_vms; + $self->after_rendering_MSWin32 if $self->is_mswin32; + $self->after_rendering_Dos if $self->is_dos; + $self->after_rendering_OS2 if $self->is_os2; + return; +} + +sub after_rendering_VMS { return } +sub after_rendering_Dos { return } +sub after_rendering_OS2 { return } +sub after_rendering_MSWin32 { return } + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + +sub minus_f_nocase { # i.e., do like -f, but without regard to case + + my($self, $dir, $file) = @_; + my $path = catfile($dir,$file); + return $path if -f $path and -r _; + + if(!$self->opt_i + or $self->is_vms or $self->is_mswin32 + or $self->is_dos or $self->is_os2 + ) { + # On a case-forgiving file system, or if case is important, + # that is it, all we can do. + $self->warn( "Ignored $path: unreadable\n" ) if -f _; + return ''; + } + + local *DIR; + my @p = ($dir); + my($p,$cip); + foreach $p (splitdir $file){ + my $try = catfile @p, $p; + $self->aside("Scrutinizing $try...\n"); + stat $try; + if (-d _) { + push @p, $p; + if ( $p eq $self->{'target'} ) { + my $tmp_path = catfile @p; + my $path_f = 0; + for (@{ $self->{'found'} }) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@{ $self->{'found'} }, $tmp_path) unless $path_f; + $self->aside( "Found as $tmp_path but directory\n" ); + } + } + elsif (-f _ && -r _ && lc($try) eq lc($path)) { + return $try; + } + elsif (-f _) { + $self->warn( "Ignored $try: unreadable or file/dir mismatch\n" ); + } + elsif (-d catdir(@p)) { # at least we see the containing directory! + my $found = 0; + my $lcp = lc $p; + my $p_dirspec = catdir(@p); + opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" ); + while(defined( $cip = readdir(DIR) )) { + if (lc $cip eq $lcp){ + $found++; + last; # XXX stop at the first? what if there's others? + } + } + closedir DIR or $self->die( "closedir $p_dirspec: $!" ); + return "" unless $found; + + push @p, $cip; + my $p_filespec = catfile(@p); + return $p_filespec if -f $p_filespec and -r _; + $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _; + } + } + return ""; +} + +#.......................................................................... + +sub pagers_guessing { + # TODO: This whole subroutine needs to be rewritten. It's semi-insane + # right now. + + my $self = shift; + + my @pagers; + push @pagers, $self->pagers; + $self->{'pagers'} = \@pagers; + + if ($self->is_mswin32) { + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + elsif ($self->is_vms) { + push @pagers, qw( most more less type/page ); + } + elsif ($self->is_dos) { + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + elsif ( $self->is_amigaos) { + push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); + unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; + } + else { + if ($self->is_os2) { + unshift @pagers, 'less', 'cmd /c more <'; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; + } + + if ($self->is_cygwin) { + if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { + unshift @pagers, '/usr/bin/less -isrR'; + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + } + + if ( $self->opt_m ) { + unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER} + } + else { + unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER}; + unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER}; + } + + $self->aside("Pagers: ", (join ", ", @pagers)); + + return; +} + +#.......................................................................... + +sub page_module_file { + my($self, @found) = @_; + + # Security note: + # Don't ever just pass this off to anything like MSWin's "start.exe", + # since we might be calling on a .pl file, and we wouldn't want that + # to actually /execute/ the file that we just want to page thru! + # Also a consideration if one were to use a web browser as a pager; + # doing so could trigger the browser's MIME mapping for whatever + # it thinks .pm/.pl/whatever is. Probably just a (useless and + # annoying) "Save as..." dialog, but potentially executing the file + # in question -- particularly in the case of MSIE and it's, ahem, + # occasionally hazy distinction between OS-local extension + # associations, and browser-specific MIME mappings. + + if(@found > 1) { + $self->warn( + "Perldoc is only really meant for reading one document at a time.\n" . + "So these files are being ignored: " . + join(' ', @found[1 .. $#found] ) . + "\n" ) + } + + return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers); + +} + +#.......................................................................... + +sub check_file { + my($self, $dir, $file) = @_; + + unless( ref $self ) { + # Should never get called: + $Carp::Verbose = 1; + require Carp; + Carp::croak( join '', + "Crazy ", __PACKAGE__, " error:\n", + "check_file must be an object_method!\n", + "Aborting" + ); + } + + if(length $dir and not -d $dir) { + DEBUG > 3 and print " No dir $dir -- skipping.\n"; + return ""; + } + + my $path = $self->minus_f_nocase($dir,$file); + if( length $path and ($self->opt_m ? $self->isprintable($path) + : $self->containspod($path)) ) { + DEBUG > 3 and print + " The file $path indeed looks promising!\n"; + return $path; + } + DEBUG > 3 and print " No good: $file in $dir\n"; + + return ""; +} + +sub isprintable { + my($self, $file, $readit) = @_; + my $size= 1024; + my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc. + + return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i; + + my $data; + local($_); + my $fh = $self->open_fh("<", $file); + read $fh, $data, $size; + close $fh; + $size= length($data); + $data =~ tr/\x09-\x0D\x20-\x7E//d; + return length($data) <= $size*$maxunprintfrac; +} + +#.......................................................................... + +sub containspod { + my($self, $file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod\z/i; + + + # Under cygwin the /usr/bin/perl is legal executable, but + # you cannot open a file with that name. It must be spelled + # out as "/usr/bin/perl.exe". + # + # The following if-case under cygwin prevents error + # + # $ perldoc perl + # Cannot open /usr/bin/perl: no such file or directory + # + # This would work though + # + # $ perldoc perl.pod + + if ( $self->is_cygwin and -x $file and -f "$file.exe" ) + { + $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D; + return 0; + } + + local($_); + my $fh = $self->open_fh("<", $file); + while (<$fh>) { + if (/^=head/) { + close($fh) or $self->die( "Can't close $file: $!" ); + return 1; + } + } + close($fh) or $self->die( "Can't close $file: $!" ); + return 0; +} + +#.......................................................................... + +sub maybe_extend_searchpath { + my $self = shift; + + # Does this look like a module or extension directory? + + if (-f "Makefile.PL" || -f "Build.PL") { + + push @{$self->{search_path} }, '.','lib'; + + # don't add if superuser + if ($< && $> && -d "blib") { # don't be looking too hard now! + push @{ $self->{search_path} }, 'blib'; + $self->warn( $@ ) if $@ && $self->opt_D; + } + } + + return; +} + +#.......................................................................... + +sub new_output_file { + my $self = shift; + my $outspec = $self->opt_d; # Yes, -d overrides all else! + # So don't call this twice per format-job! + + return $self->new_tempfile(@_) unless defined $outspec and length $outspec; + + # Otherwise open a write-handle on opt_d!f + + DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; + my $fh = $self->open_fh(">", $outspec); + + DEBUG > 3 and print "Successfully opened $outspec\n"; + binmode($fh) if $self->{'output_is_binary'}; + return($fh, $outspec); +} + +#.......................................................................... + +sub useful_filename_bit { + # This tries to provide a meaningful bit of text to do with the query, + # such as can be used in naming the file -- since if we're going to be + # opening windows on temp files (as a "pager" may well do!) then it's + # better if the temp file's name (which may well be used as the window + # title) isn't ALL just random garbage! + # In other words "perldoc_LWPSimple_2371981429" is a better temp file + # name than "perldoc_2371981429". So this routine is what tries to + # provide the "LWPSimple" bit. + # + my $self = shift; + my $pages = $self->{'pages'} || return undef; + return undef unless @$pages; + + my $chunk = $pages->[0]; + return undef unless defined $chunk; + $chunk =~ s/:://g; + $chunk =~ s/\.\w+$//g; # strip any extension + if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file + $chunk = $1; + } else { + return undef; + } + $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! + $chunk = substr($chunk, -10) if length($chunk) > 10; + return $chunk; +} + +#.......................................................................... + +sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) + my $self = shift; + + ++$Temp_Files_Created; + + require File::Temp; + return File::Temp::tempfile(UNLINK => 1); +} + +#.......................................................................... + +sub page { # apply a pager to the output file + my ($self, $output, $output_to_stdout, @pagers) = @_; + if ($output_to_stdout) { + $self->aside("Sending unpaged output to STDOUT.\n"); + my $fh = $self->open_fh("<", $output); + local $_; + while (<$fh>) { + print or $self->die( "Can't print to stdout: $!" ); + } + close $fh or $self->die( "Can't close while $output: $!" ); + $self->unlink_if_temp_file($output); + } else { + # On VMS, quoting prevents logical expansion, and temp files with no + # extension get the wrong default extension (such as .LIS for TYPE) + + $output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms; + + $output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos; + # Altho "/" under MSWin is in theory good as a pathsep, + # many many corners of the OS don't like it. So we + # have to force it to be "\" to make everyone happy. + + # if we are on an amiga convert unix path to an amiga one + $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos; + + foreach my $pager (@pagers) { + $self->aside("About to try calling $pager $output\n"); + if ($self->is_vms) { + last if system("$pager $output") == 0; + } elsif($self->is_amigaos) { + last if system($pager, $output) == 0; + } else { + last if system("$pager \"$output\"") == 0; + } + } + } + return; +} + +#.......................................................................... + +sub searchfor { + my($self, $recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if $self->is_vms; + return $s if -f $s && $self->containspod($s); + $self->aside( "Looking for $s in @dirs\n" ); + my $ret; + my $i; + my $dir; + $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + next unless -d $dir; + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms; + if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) + or ( $ret = $self->check_file($dir,"$s.pm")) + or ( $ret = $self->check_file($dir,$s)) + or ( $self->is_vms and + $ret = $self->check_file($dir,"$s.com")) + or ( $self->is_os2 and + $ret = $self->check_file($dir,"$s.cmd")) + or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and + $ret = $self->check_file($dir,"$s.bat")) + or ( $ret = $self->check_file("$dir/pod","$s.pod")) + or ( $ret = $self->check_file("$dir/pod",$s)) + or ( $ret = $self->check_file("$dir/pods","$s.pod")) + or ( $ret = $self->check_file("$dir/pods",$s)) + ) { + DEBUG > 1 and print " Found $ret\n"; + return $ret; + } + + if ($recurse) { + opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" ); + my @newdirs = map catfile($dir, $_), grep { + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d catfile($dir, $_) + } readdir D; + closedir(D) or $self->die( "Can't closedir $dir: $!" ); + next unless @newdirs; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms; + $self->aside( "Also looking in @newdirs\n" ); + push(@dirs,@newdirs); + } + } + return (); +} + +#.......................................................................... +{ + my $already_asserted; + sub assert_closing_stdout { + my $self = shift; + + return if $already_asserted; + + eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~; + # What for? to let the pager know that nothing more will come? + + $self->die( $@ ) if $@; + $already_asserted = 1; + return; + } +} + +#.......................................................................... + +sub tweak_found_pathnames { + my($self, $found) = @_; + if ($self->is_mswin32) { + foreach (@$found) { s,/,\\,g } + } + foreach (@$found) { s,',\\',g } # RT 37347 + return; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + +sub am_taint_checking { + my $self = shift; + $self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way + my($k,$v) = each %ENV; + return is_tainted($v); +} + +#.......................................................................... + +sub is_tainted { # just a function + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length! + local $@; # preserve the caller's version of $@ + eval { eval "# $nada" }; + return length($@) != 0; +} + +#.......................................................................... + +sub drop_privs_maybe { + my $self = shift; + + DEBUG and print "Attempting to drop privs...\n"; + + # Attempt to drop privs if we should be tainting and aren't + if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos + || $self->is_os2 + ) + && ($> == 0 || $< == 0) + && !$self->am_taint_checking() + ) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + # + # According to Stevens' APUE and various + # (BSD, Solaris, HP-UX) man pages, setting + # the real uid first and effective uid second + # is the way to go if one wants to drop privileges, + # because if one changes into an effective uid of + # non-zero, one cannot change the real uid any more. + # + # Actually, it gets even messier. There is + # a third uid, called the saved uid, and as + # long as that is zero, one can get back to + # uid of zero. Setting the real-effective *twice* + # helps in *most* systems (FreeBSD and Solaris) + # but apparently in HP-UX even this doesn't help: + # the saved uid stays zero (apparently the only way + # in HP-UX to change saved uid is to call setuid() + # when the effective uid is zero). + # + eval { + $< = $id; # real uid + $> = $id; # effective uid + $< = $id; # real uid + $> = $id; # effective uid + }; + if( !$@ && $< && $> ) { + DEBUG and print "OK, I dropped privileges.\n"; + } elsif( $self->opt_U ) { + DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." + } else { + DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; + # We used to die here; but that seemed pointless. + } + } + return; +} + +#.......................................................................... + +1; + +__END__ + +# Pod::Text::Color -- Convert POD data to formatted color ASCII text +# +# This is just a basic proof of concept. It should later be modified to make +# better use of color, take options changing what colors are used for what +# text, and the like. +# +# Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2014 +# Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Color; + +use 5.006; +use strict; +use warnings; + +use Pod::Text (); +use Term::ANSIColor qw(colored); + +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +$VERSION = '4.10'; + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head1 ($attrs, colored ($text, 'bold')); +} + +# Make level two headings bold. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head2 ($attrs, colored ($text, 'bold')); +} + +# Fix the various formatting codes. +sub cmd_b { return colored ($_[2], 'bold') } +sub cmd_f { return colored ($_[2], 'cyan') } +sub cmd_i { return colored ($_[2], 'yellow') } + +# Output any included code in green. +sub output_code { + my ($self, $code) = @_; + $code = colored ($code, 'green'); + $self->output ($code); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. We will eventually want to use colorstrip() from Term::ANSIColor, +# but it's fairly new so avoid the tight dependency. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/\e\[[\d;]*m//g; + return $text; +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the escape sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + + # We have to do $shortchar and $longchar in variables because the + # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. + my $char = '(?:(?:\e\[[\d;]+m)*[^\n])'; + my $shortchar = $char . "{0,$width}"; + my $longchar = $char . "{$width}"; + while (length > $width) { + if (s/^($shortchar)\s+// || s/^($longchar)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text +# +# This was written because the output from: +# +# pod2text Text.pm > plain.txt; less plain.txt +# +# is not as rich as the output from +# +# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt +# +# and because both Pod::Text::Color and Pod::Text::Termcap are not device +# independent. +# +# Created by Joe Smith 30-Nov-2000 +# (based on Pod::Text::Color by Russ Allbery ) +# Copyright 2000 Joe Smith . +# Copyright 2001, 2004, 2008, 2014 Russ Allbery . +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Overstrike; + +use 5.006; +use strict; +use warnings; + +use vars qw(@ISA $VERSION); + +use Pod::Text (); + +@ISA = qw(Pod::Text); + +$VERSION = '4.10'; + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold, overriding any existing formatting. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/$1\b$1/g; + return $self->SUPER::cmd_head1 ($attrs, $text); +} + +# Make level two headings bold, overriding any existing formatting. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/$1\b$1/g; + return $self->SUPER::cmd_head2 ($attrs, $text); +} + +# Make level three headings underscored, overriding any existing formatting. +sub cmd_head3 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/_\b$1/g; + return $self->SUPER::cmd_head3 ($attrs, $text); +} + +# Level four headings look like level three headings. +sub cmd_head4 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($text); + $text =~ s/(.)/_\b$1/g; + return $self->SUPER::cmd_head4 ($attrs, $text); +} + +# The common code for handling all headers. We have to override to avoid +# interpolating twice and because we don't want to honor alt. +sub heading { + my ($self, $text, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text .= "\n" if $$self{opt_loose}; + my $margin = ' ' x ($$self{opt_margin} + $indent); + $self->output ($margin . $text . "\n"); + return ''; +} + +# Fix the various formatting codes. +sub cmd_b { local $_ = $_[0]->strip_format ($_[2]); s/(.)/$1\b$1/g; $_ } +sub cmd_f { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ } +sub cmd_i { local $_ = $_[0]->strip_format ($_[2]); s/(.)/_\b$1/g; $_ } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $code =~ s/(.)/$1\b$1/g; + $self->output ($code); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/(.)[\b]\1/$1/g; + $text =~ s/_[\b]//g; + return $text; +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the backspaces. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + while (length > $width) { + # This regex represents a single character, that's possibly underlined + # or in bold (in which case, it's three characters; the character, a + # backspace, and a character). Use [^\n] rather than . to protect + # against odd settings of $*. + my $char = '(?:[^\n][\b])?[^\n]'; + if (s/^((?>$char){0,$width})(?:\Z|\s+)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. +# +# This is a simple subclass of Pod::Text that overrides a few key methods to +# output the right termcap escape sequences for formatted text on the current +# terminal type. +# +# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009, 2014, 2015 +# Russ Allbery +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Termcap; + +use 5.006; +use strict; +use warnings; + +use Pod::Text (); +use POSIX (); +use Term::Cap; + +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +$VERSION = '4.10'; + +############################################################################## +# Overrides +############################################################################## + +# In the initialization method, grab our terminal characteristics as well as +# do all the stuff we normally do. +sub new { + my ($self, @args) = @_; + my ($ospeed, $term, $termios); + $self = $self->SUPER::new (@args); + + # $ENV{HOME} is usually not set on Windows. The default Term::Cap path + # may not work on Solaris. + unless (exists $ENV{TERMPATH}) { + my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; + $ENV{TERMPATH} = + "${home}/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap"; + } + + # Fall back on a hard-coded terminal speed if POSIX::Termios isn't + # available (such as on VMS). + eval { $termios = POSIX::Termios->new }; + if ($@) { + $ospeed = 9600; + } else { + $termios->getattr; + $ospeed = $termios->getospeed || 9600; + } + + # Fall back on the ANSI escape sequences if Term::Cap doesn't work. + eval { $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } }; + $$self{BOLD} = $$term{_md} || "\e[1m"; + $$self{UNDL} = $$term{_us} || "\e[4m"; + $$self{NORM} = $$term{_me} || "\e[m"; + + unless (defined $$self{width}) { + $$self{opt_width} = $ENV{COLUMNS} || $$term{_co} || 80; + $$self{opt_width} -= 2; + } + + return $self; +} + +# Make level one headings bold. +sub cmd_head1 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head1 ($attrs, "$$self{BOLD}$text$$self{NORM}"); +} + +# Make level two headings bold. +sub cmd_head2 { + my ($self, $attrs, $text) = @_; + $text =~ s/\s+$//; + $self->SUPER::cmd_head2 ($attrs, "$$self{BOLD}$text$$self{NORM}"); +} + +# Fix up B<> and I<>. Note that we intentionally don't do F<>. +sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" } +sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $self->output ($$self{BOLD} . $code . $$self{NORM}); +} + +# Strip all of the formatting from a provided string, returning the stripped +# version. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/\Q$$self{BOLD}//g; + $text =~ s/\Q$$self{UNDL}//g; + $text =~ s/\Q$$self{NORM}//g; + return $text; +} + +# Override the wrapping code to ignore the special sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{opt_width} - $$self{MARGIN}; + + # $codes matches a single special sequence. $char matches any number of + # special sequences preceding a single character other than a newline. + # We have to do $shortchar and $longchar in variables because the + # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. + my $codes = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $char = "(?:$codes*[^\\n])"; + my $shortchar = $char . "{0,$width}"; + my $longchar = $char . "{$width}"; + while (length > $width) { + if (s/^($shortchar)\s+// || s/^($longchar)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + return $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +require 5.005; +package Pod::Simple::Search; +use strict; + +use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); +$VERSION = '3.35'; ## Current version of this package + +BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level +use Carp (); + +$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; + # flag to occasionally sleep for $SLEEPY - 1 seconds. + +$MAX_VERSION_WITHIN ||= 60; +my $IS_CASE_INSENSITIVE = -e uc __FILE__ && -e lc __FILE__; + +############################################################################# + +#use diagnostics; +use File::Spec (); +use File::Basename qw( basename dirname ); +use Config (); +use Cwd qw( cwd ); + +#========================================================================== +__PACKAGE__->_accessorize( # Make my dumb accessor methods + 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob', + 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse', + 'ciseen' +); +#========================================================================== + +sub new { + my $class = shift; + my $self = bless {}, ref($class) || $class; + $self->init; + return $self; +} + +sub init { + my $self = shift; + $self->inc(1); + $self->recurse(1); + $self->verbose(DEBUG); + return $self; +} + +#-------------------------------------------------------------------------- + +sub survey { + my($self, @search_dirs) = @_; + $self = $self->new unless ref $self; # tolerate being a class method + + $self->_expand_inc( \@search_dirs ); + + $self->{'_scan_count'} = 0; + $self->{'_dirs_visited'} = {}; + $self->path2name( {} ); + $self->name2path( {} ); + $self->ciseen( {} ); + $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'}; + my $cwd = cwd(); + my $verbose = $self->verbose; + local $_; # don't clobber the caller's $_ ! + + foreach my $try (@search_dirs) { + unless( File::Spec->file_name_is_absolute($try) ) { + # make path absolute + $try = File::Spec->catfile( $cwd ,$try); + } + # simplify path + $try = File::Spec->canonpath($try); + + my $start_in; + my $modname_prefix; + if($self->{'dir_prefix'}) { + $start_in = File::Spec->catdir( + $try, + grep length($_), split '[\\/:]+', $self->{'dir_prefix'} + ); + $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}]; + $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ", + "giving $start_in (= @$modname_prefix)\n"; + } else { + $start_in = $try; + } + + if( $self->{'_dirs_visited'}{$start_in} ) { + $verbose and print "Directory '$start_in' already seen, skipping.\n"; + next; + } else { + $self->{'_dirs_visited'}{$start_in} = 1; + } + + unless(-e $start_in) { + $verbose and print "Skipping non-existent $start_in\n"; + next; + } + + my $closure = $self->_make_search_callback; + + if(-d $start_in) { + # Normal case: + $verbose and print "Beginning excursion under $start_in\n"; + $self->_recurse_dir( $start_in, $closure, $modname_prefix ); + $verbose and print "Back from excursion under $start_in\n\n"; + + } elsif(-f _) { + # A excursion consisting of just one file! + $_ = basename($start_in); + $verbose and print "Pondering $start_in ($_)\n"; + $closure->($start_in, $_, 0, []); + + } else { + $verbose and print "Skipping mysterious $start_in\n"; + } + } + $self->progress and $self->progress->done( + "Noted $$self{'_scan_count'} Pod files total"); + $self->ciseen( {} ); + + return unless defined wantarray; # void + return $self->name2path unless wantarray; # scalar + return $self->name2path, $self->path2name; # list +} + +#========================================================================== +sub _make_search_callback { + my $self = $_[0]; + + # Put the options in variables, for easy access + my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress, + $path2name, $name2path, $recurse, $ciseen) = + map scalar($self->$_()), + qw(laborious verbose shadows limit_re callback progress + path2name name2path recurse ciseen); + my ($seen, $remember, $files_for); + if ($IS_CASE_INSENSITIVE) { + $seen = sub { $ciseen->{ lc $_[0] } }; + $remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; }; + $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } }; + } else { + $seen = sub { $name2path->{ $_[0] } }; + $remember = sub { $name2path->{ $_[0] } = $_[1] }; + $files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } }; + } + + my($file, $shortname, $isdir, $modname_bits); + return sub { + ($file, $shortname, $isdir, $modname_bits) = @_; + + if($isdir) { # this never gets called on the startdir itself, just subdirs + + unless( $recurse ) { + $verbose and print "Not recursing into '$file' as per requested.\n"; + return 'PRUNE'; + } + + if( $self->{'_dirs_visited'}{$file} ) { + $verbose and print "Directory '$file' already seen, skipping.\n"; + return 'PRUNE'; + } + + print "Looking in dir $file\n" if $verbose; + + unless ($laborious) { # $laborious overrides pruning + if( m/^(\d+\.[\d_]{3,})\z/s + and do { my $x = $1; $x =~ tr/_//d; $x != $] } + ) { + $verbose and print "Perl $] version mismatch on $_, skipping.\n"; + return 'PRUNE'; + } + + if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) { + $verbose and print "$_ is a well-named module subdir. Looking....\n"; + } else { + $verbose and print "$_ is a fishy directory name. Skipping.\n"; + return 'PRUNE'; + } + } # end unless $laborious + + $self->{'_dirs_visited'}{$file} = 1; + return; # (not pruning); + } + + # Make sure it's a file even worth even considering + if($laborious) { + unless( + m/\.(pod|pm|plx?)\z/i || -x _ and -T _ + # Note that the cheapest operation (the RE) is run first. + ) { + $verbose > 1 and print " Brushing off uninteresting $file\n"; + return; + } + } else { + unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) { + $verbose > 1 and print " Brushing off oddly-named $file\n"; + return; + } + } + + $verbose and print "Considering item $file\n"; + my $name = $self->_path2modname( $file, $shortname, $modname_bits ); + $verbose > 0.01 and print " Nominating $file as $name\n"; + + if($limit_re and $name !~ m/$limit_re/i) { + $verbose and print "Shunning $name as not matching $limit_re\n"; + return; + } + + if( !$shadows and $seen->($name) ) { + $verbose and print "Not worth considering $file ", + "-- already saw $name as ", + join(' ', $files_for->($name)), "\n"; + return; + } + + # Put off until as late as possible the expense of + # actually reading the file: + $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file"); + return unless $self->contains_pod( $file ); + ++ $self->{'_scan_count'}; + + # Or finally take note of it: + if ( my $prev = $seen->($name) ) { + $verbose and print + "Duplicate POD found (shadowing?): $name ($file)\n", + " Already seen in ", join(' ', $files_for->($name)), "\n"; + } else { + $remember->($name, $file); # Noting just the first occurrence + } + $verbose and print " Noting $name = $file\n"; + if( $callback ) { + local $_ = $_; # insulate from changes, just in case + $callback->($file, $name); + } + $path2name->{$file} = $name; + return; + } +} + +#========================================================================== + +sub _path2modname { + my($self, $file, $shortname, $modname_bits) = @_; + + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" (from 'archname') + # * remove e.g. 5.00503 + # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod) + # * dig into the file for case-preserved name if not already mixed case + + my @m = @$modname_bits; + my $x; + my $verbose = $self->verbose; + + # Shaving off leading naughty-bits + while(@m + and defined($x = lc( $m[0] )) + and( $x eq 'site_perl' + or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) + or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum + or $x eq lc( $Config::Config{'archname'} ) + )) { shift @m } + + my $name = join '::', @m, $shortname; + $self->_simplify_base($name); + + # On VMS, case-preserved document names can't be constructed from + # filenames, so try to extract them from the "=head1 NAME" tag in the + # file instead. + if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) { + open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!"; + my $in_pod = 0; + my $in_name = 0; + my $line; + while ($line = ) { + chomp $line; + $in_pod = 1 if ($line =~ m/^=\w/); + $in_pod = 0 if ($line =~ m/^=cut/); + next unless $in_pod; # skip non-pod text + next if ($line =~ m/^\s*\z/); # and blank lines + next if ($in_pod && ($line =~ m/^X{'fs_recursion_maxdepth'} || 10; + my $verbose = $self->verbose; + + my $here_string = File::Spec->curdir; + my $up_string = File::Spec->updir; + $modname_bits ||= []; + + my $recursor; + $recursor = sub { + my($dir_long, $dir_bare) = @_; + if( @$modname_bits >= 10 ) { + $verbose and print "Too deep! [@$modname_bits]\n"; + return; + } + + unless(-d $dir_long) { + $verbose > 2 and print "But it's not a dir! $dir_long\n"; + return; + } + unless( opendir(INDIR, $dir_long) ) { + $verbose > 2 and print "Can't opendir $dir_long : $!\n"; + closedir(INDIR); + return + } + + # Load all items; put no extension before .pod before .pm before .plx?. + my @items = map { $_->[0] } + sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] } + map { + (my $t = $_) =~ s/[.]p(m|lx?|od)\z//; + [$_, $t, lc($1 || 'z') ] + } readdir(INDIR); + closedir(INDIR); + + push @$modname_bits, $dir_bare unless $dir_bare eq ''; + + my $i_full; + foreach my $i (@items) { + next if $i eq $here_string or $i eq $up_string or $i eq ''; + $i_full = File::Spec->catfile( $dir_long, $i ); + + if(!-r $i_full) { + $verbose and print "Skipping unreadable $i_full\n"; + + } elsif(-f $i_full) { + $_ = $i; + $callback->( $i_full, $i, 0, $modname_bits ); + + } elsif(-d _) { + $i =~ s/\.DIR\z//i if $^O eq 'VMS'; + $_ = $i; + my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || ''; + + if($rv eq 'PRUNE') { + $verbose > 1 and print "OK, pruning"; + } else { + # Otherwise, recurse into it + $recursor->( File::Spec->catdir($dir_long, $i) , $i); + } + } else { + $verbose > 1 and print "Skipping oddity $i_full\n"; + } + } + pop @$modname_bits; + return; + };; + + local $_; + $recursor->($startdir, ''); + + undef $recursor; # allow it to be GC'd + + return; +} + + +#========================================================================== + +sub run { + # A function, useful in one-liners + + my $self = __PACKAGE__->new; + $self->limit_glob($ARGV[0]) if @ARGV; + $self->callback( sub { + my($file, $name) = @_; + my $version = ''; + + # Yes, I know we won't catch the version in like a File/Thing.pm + # if we see File/Thing.pod first. That's just the way the + # cookie crumbles. -- SMB + + if($file =~ m/\.pod$/i) { + # Don't bother looking for $VERSION in .pod files + DEBUG and print "Not looking for \$VERSION in .pod $file\n"; + } elsif( !open(INPOD, $file) ) { + DEBUG and print "Couldn't open $file: $!\n"; + close(INPOD); + } else { + # Sane case: file is readable + my $lines = 0; + while() { + last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity + if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) { + DEBUG and print "Found version line (#$lines): $_"; + s/\s*\#.*//s; + s/\;\s*$//s; + s/\s+$//s; + s/\t+/ /s; # nix tabs + # Optimize the most common cases: + $_ = "v$1" + if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s + # like in $VERSION = "3.14159"; + or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s + # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/); + ; + + # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/) + $_ = sprintf("v%d.%s", + map {s/_//g; $_} + $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part + if m{\$Name:\s*([^\$]+)\$}s + ; + $version = $_; + DEBUG and print "Noting $version as version\n"; + last; + } + } + close(INPOD); + } + print "$name\t$version\t$file\n"; + return; + # End of callback! + }); + + $self->survey; +} + +#========================================================================== + +sub simplify_name { + my($self, $str) = @_; + + # Remove all path components + # XXX Why not just use basename()? -- SMB + + if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s } + else { $str =~ s{^.*/+}{}s } + + $self->_simplify_base($str); + return $str; +} + +#========================================================================== + +sub _simplify_base { # Internal method only + + # strip Perl's own extensions + $_[1] =~ s/\.(pod|pm|plx?)\z//i; + + # strip meaningless extensions on Win32 and OS/2 + $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i; + + # strip meaningless extensions on VMS + $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS'; + + return; +} + +#========================================================================== + +sub _expand_inc { + my($self, $search_dirs) = @_; + + return unless $self->{'inc'}; + my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs }; + + if ($^O eq 'MacOS') { + push @$search_dirs, + grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC); + # Any other OSs need custom handling here? + } else { + push @$search_dirs, + grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC; + } + + $self->{'laborious'} = 0; # Since inc said to use INC + return; +} + +#========================================================================== + +sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @them; + (undef,@them) = @_; + for $_ (@them) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + $_ = ':'. $_; + } else { + $_ =~ s|^\./|:|; + } + } + return @them; +} + +#========================================================================== + +sub _limit_glob_to_limit_re { + my $self = $_[0]; + my $limit_glob = $self->{'limit_glob'} || return; + + my $limit_re = '^' . quotemeta($limit_glob) . '$'; + $limit_re =~ s/\\\?/./g; # glob "?" => "." + $limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?" + $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => "" + + $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n"; + + # A common optimization: + if(!exists($self->{'dir_prefix'}) + and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*" + # Optimize for sane and common cases (but not things like "*::File") + ) { + $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg; + $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n"; + } + + return $limit_re; +} + +#========================================================================== + +# contribution mostly from Tim Jenness + +sub _actual_filenames { + my $dir = shift; + my $fn = lc shift; + opendir my $dh, $dir or return; + return map { File::Spec->catdir($dir, $_) } + grep { lc $_ eq $fn } readdir $dh; +} + +sub find { + my($self, $pod, @search_dirs) = @_; + $self = $self->new unless ref $self; # tolerate being a class method + + # Check usage + Carp::carp 'Usage: \$self->find($podname, ...)' + unless defined $pod and length $pod; + + my $verbose = $self->verbose; + + # Split on :: and then join the name together using File::Spec + my @parts = split /::/, $pod; + $verbose and print "Chomping {$pod} => {@parts}\n"; + + #@search_dirs = File::Spec->curdir unless @search_dirs; + + $self->_expand_inc(\@search_dirs); + # Add location of binaries such as pod2text: + push @search_dirs, $Config::Config{'scriptdir'} if $self->inc; + + my %seen_dir; + while (my $dir = shift @search_dirs ) { + next unless defined $dir and length $dir; + next if $seen_dir{$dir}; + $seen_dir{$dir} = 1; + unless(-d $dir) { + print "Directory $dir does not exist\n" if $verbose; + } + + print "Looking in directory $dir\n" if $verbose; + my $fullname = File::Spec->catfile( $dir, @parts ); + print "Filename is now $fullname\n" if $verbose; + + foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions + my $fullext = $fullname . $ext; + if ( -f $fullext and $self->contains_pod($fullext) ) { + print "FOUND: $fullext\n" if $verbose; + if (@parts > 1 && lc $parts[0] eq 'pod' && $IS_CASE_INSENSITIVE && $ext eq '.pod') { + # Well, this file could be for a program (perldoc) but we actually + # want a module (Pod::Perldoc). So see if there is a .pm with the + # proper casing. + my $subdir = dirname $fullext; + unless (grep { $fullext eq $_ } _actual_filenames $subdir, "$parts[-1].pod") { + print "# Looking for alternate spelling in $subdir\n" if $verbose; + # Try the .pm file. + my $pm = $fullname . '.pm'; + if ( -f $pm and $self->contains_pod($pm) ) { + # Prefer the .pm if its case matches. + if (grep { $pm eq $_ } _actual_filenames $subdir, "$parts[-1].pm") { + print "FOUND: $fullext\n" if $verbose; + return $pm; + } + } + } + } + return $fullext; + } + } + + # Case-insensitively Look for ./pod directories and slip them in. + for my $subdir ( _actual_filenames($dir, 'pod') ) { + if (-d $subdir) { + $verbose and print "Noticing $subdir and looking there...\n"; + unshift @search_dirs, $subdir; + } + } + } + + return undef; +} + +#========================================================================== + +sub contains_pod { + my($self, $file) = @_; + my $verbose = $self->{'verbose'}; + + # check for one line of POD + $verbose > 1 and print " Scanning $file for pod...\n"; + unless( open(MAYBEPOD,"<$file") ) { + print "Error: $file is unreadable: $!\n"; + return undef; + } + + sleep($SLEEPY - 1) if $SLEEPY; + # avoid totally hogging the processor on OSs with poor process control + + local $_; + while( ) { + if(m/^=(head\d|pod|over|item)\b/s) { + close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; + chomp; + $verbose > 1 and print " Found some pod ($_) in $file\n"; + return 1; + } + } + close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting"; + $verbose > 1 and print " No POD in $file, skipping.\n"; + return 0; +} + +#========================================================================== + +sub _accessorize { # A simple-minded method-maker + shift; + no strict 'refs'; + foreach my $attrname (@_) { + *{caller() . '::' . $attrname} = sub { + use strict; + $Carp::CarpLevel = 1, Carp::croak( + "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" + ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + + # Read access: + return $_[0]->{$attrname} if @_ == 1; + + # Write access: + $_[0]->{$attrname} = $_[1]; + return $_[0]; # RETURNS MYSELF! + }; + } + # Ya know, they say accessories make the ensemble! + return; +} + +#========================================================================== +sub _state_as_string { + my $self = $_[0]; + return '' unless ref $self; + my @out = "{\n # State of $self ...\n"; + foreach my $k (sort keys %$self) { + push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n"; + } + push @out, "}\n"; + my $x = join '', @out; + $x =~ s/^/#/mg; + return $x; +} + +sub _esc { + my $in = $_[0]; + return 'undef' unless defined $in; + $in =~ + s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> + <'\\x'.(unpack("H2",$1))>eg; + return qq{"$in"}; +} + +#========================================================================== + +run() unless caller; # run if "perl whatever/Search.pm" + +1; + +#========================================================================== + +__END__ + + + +require 5; +package Pod::Simple::DumpAsXML; +$VERSION = '3.35'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; + +use Carp (); +use Text::Wrap qw(wrap); + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_codes('VerbatimFormatted'); + $new->keep_encoding_directive(1); + return $new; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { + # ($self, $element_name, $attr_hash_r) + my $fh = $_[0]{'output_fh'}; + my($key, $value); + DEBUG and print STDERR "++ $_[1]\n"; + + print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1]; + + foreach my $key (sort keys %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _xml_escape($value = $_[2]{$key}); + print $fh ' ', $key, '="', $value, '"'; + } + } + + + print $fh ">\n"; + $_[0]{'indent'}++; + return; +} + +sub _handle_text { + DEBUG and print STDERR "== \"$_[1]\"\n"; + if(length $_[1]) { + my $indent = ' ' x $_[0]{'indent'}; + my $text = $_[1]; + _xml_escape($text); + local $Text::Wrap::huge = 'overflow'; + $text = wrap('', $indent, $text); + print {$_[0]{'output_fh'}} $indent, $text, "\n"; + } + return; +} + +sub _handle_element_end { + DEBUG and print STDERR "-- $_[1]\n"; + print {$_[0]{'output_fh'}} + ' ' x --$_[0]{'indent'}, "\n"; + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _xml_escape { + foreach my $x (@_) { + # Escape things very cautiously: + if ($] ge 5.007_003) { + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg; + } else { # Is broken for non-ASCII platforms on early perls + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + } + # Yes, stipulate the list without a range, so that this can work right on + # all charsets that this module happens to run under. + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + +__END__ + + +require 5; +package Pod::Simple::Text; +use strict; +use Carp (); +use Pod::Simple::Methody (); +use Pod::Simple (); +use vars qw( @ISA $VERSION $FREAKYMODE); +$VERSION = '3.35'; +@ISA = ('Pod::Simple::Methody'); +BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) + ? \&Pod::Simple::DEBUG + : sub() {0} + } + +use Text::Wrap 98.112902 (); +$Text::Wrap::huge = 'overflow'; + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_target_as_text(qw( text plaintext plain )); + $new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->{'Thispara'} = ''; + $new->{'Indent'} = 0; + $new->{'Indentstring'} = ' '; + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub handle_text { $_[0]{'Thispara'} .= $_[1] } + +sub start_Para { $_[0]{'Thispara'} = '' } +sub start_head1 { $_[0]{'Thispara'} = '' } +sub start_head2 { $_[0]{'Thispara'} = '' } +sub start_head3 { $_[0]{'Thispara'} = '' } +sub start_head4 { $_[0]{'Thispara'} = '' } + +sub start_Verbatim { $_[0]{'Thispara'} = '' } +sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' } +sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " } +sub start_item_text { $_[0]{'Thispara'} = '' } + +sub start_over_bullet { ++$_[0]{'Indent'} } +sub start_over_number { ++$_[0]{'Indent'} } +sub start_over_text { ++$_[0]{'Indent'} } +sub start_over_block { ++$_[0]{'Indent'} } + +sub end_over_bullet { --$_[0]{'Indent'} } +sub end_over_number { --$_[0]{'Indent'} } +sub end_over_text { --$_[0]{'Indent'} } +sub end_over_block { --$_[0]{'Indent'} } + + +# . . . . . Now the actual formatters: + +sub end_head1 { $_[0]->emit_par(-4) } +sub end_head2 { $_[0]->emit_par(-3) } +sub end_head3 { $_[0]->emit_par(-2) } +sub end_head4 { $_[0]->emit_par(-1) } +sub end_Para { $_[0]->emit_par( 0) } +sub end_item_bullet { $_[0]->emit_par( 0) } +sub end_item_number { $_[0]->emit_par( 0) } +sub end_item_text { $_[0]->emit_par(-2) } +sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' } +sub end_L { + if (my $link = delete $_[0]{'Link'}) { + # Append the URL to the output unless it's already present. + $_[0]{'Thispara'} .= " <$link->{to}>" + unless $_[0]{'Thispara'} =~ /\b\Q$link->{to}/; + } +} + +sub emit_par { + my($self, $tweak_indent) = splice(@_,0,2); + my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) ); + # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0 + + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; + my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); + $out =~ s/$Pod::Simple::nbsp/ /g; + print {$self->{'output_fh'}} $out, "\n"; + $self->{'Thispara'} = ''; + + return; +} + +# . . . . . . . . . . And then off by its lonesome: + +sub end_Verbatim { + my $self = shift; + $self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g; + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; + + my $i = ' ' x ( 2 * $self->{'Indent'} + 4); + #my $i = ' ' x (4 + $self->{'Indent'}); + + $self->{'Thispara'} =~ s/^/$i/mg; + + print { $self->{'output_fh'} } '', + $self->{'Thispara'}, + "\n\n" + ; + $self->{'Thispara'} = ''; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + + +use strict; +package Pod::Simple::TiedOutFH; +use Symbol ('gensym'); +use Carp (); +use vars qw($VERSION ); +$VERSION = '3.35'; + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub handle_on { # some horrible frightening things are encapsulated in here + my $class = shift; + $class = ref($class) || $class; + + Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_; + + my $x = (defined($_[0]) and ref($_[0])) + ? $_[0] + : ( \( $_[0] ) )[0] + ; + $$x = '' unless defined $$x; + + #Pod::Simple::DEBUG and print STDERR "New $class handle on $x = \"$$x\"\n"; + + my $new = gensym(); + tie *$new, $class, $x; + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub TIEHANDLE { # Ties to just a scalar ref + my($class, $scalar_ref) = @_; + $$scalar_ref = '' unless defined $$scalar_ref; + return bless \$scalar_ref, ref($class) || $class; +} + +sub PRINT { + my $it = shift; + foreach my $x (@_) { $$$it .= $x } + + #Pod::Simple::DEBUG > 10 and print STDERR " appended to $$it = \"$$$it\"\n"; + + return 1; +} + +sub FETCH { + return ${$_[0]}; +} + +sub PRINTF { + my $it = shift; + my $format = shift; + $$$it .= sprintf $format, @_; + return 1; +} + +sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number + +sub CLOSE { 1 } + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +1; +__END__ + +Chole + + * 1 large red onion + * 2 tomatillos + * 4 or 5 roma tomatoes (optionally with the pulp discarded) + * 1 tablespoons chopped ginger root (or more, to taste) + * 2 tablespoons canola oil (or vegetable oil) + + * 1 tablespoon garam masala + * 1/2 teaspoon red chili powder, or to taste + * Salt, to taste (probably quite a bit) + * 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed + * juice of one smallish lime + * a dash of balsamic vinegar (to taste) + * cooked rice, preferably long-grain white rice (whether plain, + basmati rice, jasmine rice, or even a mild pilaf) + +In a blender or food processor, puree the onions, tomatoes, tomatillos, +and ginger root. You can even do it with a Braun hand "mixer", if you +chop things finer to start with, and work at it. + +In a saucepan set over moderate heat, warm the oil until hot. + +Add the puree and the balsamic vinegar, and cook, stirring occasionally, +for 20 to 40 minutes. (Cooking it longer will make it sweeter.) + +Add the Garam Masala, chili powder, and cook, stirring occasionally, for +5 minutes. + +Add the salt and chick peas and cook, stirring, until heated through. + +Stir in the lime juice, and optionally one or two teaspoons of tahini. +You can let it simmer longer, depending on how much softer you want the +garbanzos to get. + +Serve over rice, like a curry. + +Yields 5 to 7 servings. + + + +require 5; +package Pod::Simple::RTF; + +#sub DEBUG () {4}; +#sub Pod::Simple::DEBUG () {4}; +#sub Pod::Simple::PullParser::DEBUG () {4}; + +use strict; +use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); +$VERSION = '3.35'; +use Pod::Simple::PullParser (); +BEGIN {@ISA = ('Pod::Simple::PullParser')} + +use Carp (); +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +$WRAP = 1 unless defined $WRAP; + +# These are broken for early Perls on EBCDIC; they could be fixed to work +# better there, but not worth it. These are part of a larger [...] class, so +# are just the strings to substitute into it, as opposed to compiled patterns. +my $cntrl = '[:cntrl:]'; +$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/"; + +my $not_ascii = '[:^ascii:]'; +$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/"; + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _openclose { + return map {; + m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?"; + ( $1, "{\\$2\n", "/$1", "}" ); + } @_; +} + +my @_to_accept; + +%Tagmap = ( + # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}') + _openclose( + 'B=cs18\b', + 'I=cs16\i', + 'C=cs19\f1\lang1024\noproof', + 'F=cs17\i\lang1024\noproof', + + 'VerbatimI=cs26\i', + 'VerbatimB=cs27\b', + 'VerbatimBI=cs28\b\i', + + map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ } + qw[ + underline=ul smallcaps=scaps shadow=shad + superscript=super subscript=sub strikethrough=strike + outline=outl emboss=embo engrave=impr + dotted-underline=uld dash-underline=uldash + dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd + double-underline=uldb thick-underline=ulth + word-underline=ulw wave-underline=ulwave + ] + # But no double-strikethrough, because MSWord can't agree with the + # RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!) + ), + + # Bit of a hack here: + 'L=pod' => '{\cs22\i'."\n", + 'L=url' => '{\cs23\i'."\n", + 'L=man' => '{\cs24\i'."\n", + '/L' => '}', + + 'Data' => "\n", + '/Data' => "\n", + + 'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n", + '/Verbatim' => "\n\\par}\n", + 'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n", + '/VerbatimFormatted' => "\n\\par}\n", + 'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n", + '/Para' => "\n\\par}\n", + 'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n", + '/head1' => "\n}\\par}\n", + 'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n", + '/head2' => "\n}\\par}\n", + 'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n", + '/head3' => "\n}\\par}\n", + 'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n", + '/head4' => "\n}\\par}\n", + # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2 + + 'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-bullet' => "\n\\par}\n", + 'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-number' => "\n\\par}\n", + 'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n", + '/item-text' => "\n\\par}\n", + + # we don't need any styles for over-* and /over-* +); + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub new { + my $new = shift->SUPER::new(@_); + $new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->accept_targets( 'rtf', 'RTF' ); + + $new->{'Tagmap'} = {%Tagmap}; + + $new->accept_codes(@_to_accept); + $new->accept_codes('VerbatimFormatted'); + DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n"; + $new->doc_lang( + ( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1 + : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1) + # yes, tolerate hex! + : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1) + # yes, tolerate even more hex! + : '1033' + ); + + $new->head1_halfpoint_size(32); + $new->head2_halfpoint_size(28); + $new->head3_halfpoint_size(25); + $new->head4_halfpoint_size(22); + $new->codeblock_halfpoint_size(18); + $new->header_halfpoint_size(17); + $new->normal_halfpoint_size(25); + + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +__PACKAGE__->_accessorize( + 'doc_lang', + 'head1_halfpoint_size', + 'head2_halfpoint_size', + 'head3_halfpoint_size', + 'head4_halfpoint_size', + 'codeblock_halfpoint_size', + 'header_halfpoint_size', + 'normal_halfpoint_size', + 'no_proofing_exemptions', +); + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub run { + my $self = $_[0]; + return $self->do_middle if $self->bare_output; + return + $self->do_beginning && $self->do_middle && $self->do_end; +} + + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub do_middle { # the main work + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + + my($token, $type, $tagname, $scratch); + my @stack; + my @indent_stack; + $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'}; + + while($token = $self->get_token) { + + if( ($type = $token->type) eq 'text' ) { + if( $self->{'rtfverbatim'} ) { + DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n"; + rtf_esc_codely($scratch = $token->text); + print $fh $scratch; + next; + } + + DEBUG > 1 and print STDERR " $type " , $token->text, "\n"; + + $scratch = $token->text; + $scratch =~ tr/\t\cb\cc/ /d; + + $self->{'no_proofing_exemptions'} or $scratch =~ + s/(?: + ^ + | + (?<=[\r\n\t "\[\<\(]) + ) # start on whitespace, sequence-start, or quote + ( # something looking like a Perl token: + (?: + [\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc. + ) + | + # or starting alpha, but containing anything strange: + (?: + [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+ + ) + ) + /\cb$1\cc/xsg + ; + + rtf_esc($scratch); + $scratch =~ + s/( + [^\r\n]{65} # Snare 65 characters from a line + [^\r\n ]{0,50} # and finish any current word + ) + (\ {1,10})(?![\r\n]) # capture some spaces not at line-end + /$1$2\n/gx # and put a NL before those spaces + if $WRAP; + # This may wrap at well past the 65th column, but not past the 120th. + + print $fh $scratch; + + } elsif( $type eq 'start' ) { + DEBUG > 1 and print STDERR " +$type ",$token->tagname, + " (", map("<$_> ", %{$token->attr_hash}), ")\n"; + + if( ($tagname = $token->tagname) eq 'Verbatim' + or $tagname eq 'VerbatimFormatted' + ) { + ++$self->{'rtfverbatim'}; + my $next = $self->get_token; + next unless defined $next; + my $line_count = 1; + if($next->type eq 'text') { + my $t = $next->text_r; + while( $$t =~ m/$/mg ) { + last if ++$line_count > 15; # no point in counting further + } + DEBUG > 3 and print STDERR " verbatim line count: $line_count\n"; + } + $self->unget_token($next); + $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ; + + } elsif( $tagname =~ m/^item-/s ) { + my @to_unget; + my $text_count_here = 0; + $self->{'rtfitemkeepn'} = ''; + # Some heuristics to stop item-*'s functioning as subheadings + # from getting split from the things they're subheadings for. + # + # It's not terribly pretty, but it really does make things pretty. + # + while(1) { + push @to_unget, $self->get_token; + pop(@to_unget), last unless defined $to_unget[-1]; + # Erroneously used to be "unshift" instead of pop! Adds instead + # of removes, and operates on the beginning instead of the end! + + if($to_unget[-1]->type eq 'text') { + if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){ + DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n"; + last; + } + } elsif (@to_unget > 1 and + $to_unget[-2]->type eq 'end' and + $to_unget[-2]->tagname =~ m/^item-/s + ) { + # Bail out here, after setting rtfitemkeepn yea or nay. + $self->{'rtfitemkeepn'} = '\keepn' if + $to_unget[-1]->type eq 'start' and + $to_unget[-1]->tagname eq 'Para'; + + DEBUG > 1 and printf STDERR " item-* before %s(%s) %s keepn'd.\n", + $to_unget[-1]->type, + $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '', + $self->{'rtfitemkeepn'} ? "gets" : "doesn't get"; + last; + } elsif (@to_unget > 40) { + DEBUG > 1 and print STDERR " item-* now has too many tokens (", + scalar(@to_unget), + (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (), + ") to be keepn'd.\n"; + last; # give up + } + # else keep while'ing along + } + # Now put it aaaaall back... + $self->unget_token(@to_unget); + + } elsif( $tagname =~ m/^over-/s ) { + push @stack, $1; + push @indent_stack, + int($token->attr('indent') * 4 * $self->normal_halfpoint_size); + DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n"; + $self->{'rtfindent'} += $indent_stack[-1]; + + } elsif ($tagname eq 'L') { + $tagname .= '=' . ($token->attr('type') || 'pod'); + + } elsif ($tagname eq 'Data') { + my $next = $self->get_token; + next unless defined $next; + unless( $next->type eq 'text' ) { + $self->unget_token($next); + next; + } + DEBUG and print STDERR " raw text ", $next->text, "\n"; + printf $fh "\n" . $next->text . "\n"; + next; + } + + defined($scratch = $self->{'Tagmap'}{$tagname}) or next; + $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate + print $fh $scratch; + + if ($tagname eq 'item-number') { + print $fh $token->attr('number'), ". \n"; + } elsif ($tagname eq 'item-bullet') { + print $fh "\\'", ord("_"), "\n"; + #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}"); + } + + } elsif( $type eq 'end' ) { + DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n"; + if( ($tagname = $token->tagname) =~ m/^over-/s ) { + DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n"; + $self->{'rtfindent'} -= pop @indent_stack; + pop @stack; + } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') { + --$self->{'rtfverbatim'}; + } + defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next; + $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate + print $fh $scratch; + } + } + return 1; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub do_beginning { + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + return print $fh join '', + $self->doc_init, + $self->font_table, + $self->stylesheet, + $self->color_table, + $self->doc_info, + $self->doc_start, + "\n" + ; +} + +sub do_end { + my $self = $_[0]; + my $fh = $self->{'output_fh'}; + return print $fh '}'; # that should do it +} + +########################################################################### + +sub stylesheet { + return sprintf <<'END', +{\stylesheet +{\snext0 Normal;} +{\*\cs10 \additive Default Paragraph Font;} +{\*\cs16 \additive \i \sbasedon10 pod-I;} +{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;} +{\*\cs18 \additive \b \sbasedon10 pod-B;} +{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;} +{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;} +{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;} +{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;} +{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;} +{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;} + +{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;} +{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;} +{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;} +{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;} + +{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;} +{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;} +{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;} +{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;} +} + +END + + $_[0]->codeblock_halfpoint_size(), + $_[0]->head1_halfpoint_size(), + $_[0]->head2_halfpoint_size(), + $_[0]->head3_halfpoint_size(), + $_[0]->head4_halfpoint_size(), + ; +} + +########################################################################### +# Override these as necessary for further customization + +sub font_table { + return <<'END'; # text font, code font, heading font +{\fonttbl +{\f0\froman Times New Roman;} +{\f1\fmodern Courier New;} +{\f2\fswiss Arial;} +} + +END +} + +sub doc_init { + return <<'END'; +{\rtf1\ansi\deff0 + +END +} + +sub color_table { + return <<'END'; +{\colortbl;\red255\green0\blue0;\red0\green0\blue255;} +END +} + + +sub doc_info { + my $self = $_[0]; + + my $class = ref($self) || $self; + + my $tag = __PACKAGE__ . ' ' . $VERSION; + + unless($class eq __PACKAGE__) { + $tag = " ($tag)"; + $tag = " v" . $self->VERSION . $tag if defined $self->VERSION; + $tag = $class . $tag; + } + + return sprintf <<'END', +{\info{\doccomm +%s + using %s v%s + under Perl v%s at %s GMT} +{\author [see doc]}{\company [see doc]}{\operator [see doc]} +} + +END + + # None of the following things should need escaping, I dare say! + $tag, + $ISA[0], $ISA[0]->VERSION(), + $], scalar(gmtime), + ; +} + +sub doc_start { + my $self = $_[0]; + my $title = $self->get_short_title(); + DEBUG and print STDERR "Short Title: <$title>\n"; + $title .= ' ' if length $title; + + $title =~ s/ *$/ /s; + $title =~ s/^ //s; + $title =~ s/ $/, /s; + # make sure it ends in a comma and a space, unless it's 0-length + + my $is_obviously_module_name; + $is_obviously_module_name = 1 + if $title =~ m/^\S+$/s and $title =~ m/::/s; + # catches the most common case, at least + + DEBUG and print STDERR "Title0: <$title>\n"; + $title = rtf_esc($title); + DEBUG and print STDERR "Title1: <$title>\n"; + $title = '\lang1024\noproof ' . $title + if $is_obviously_module_name; + + return sprintf <<'END', +\deflang%s\plain\lang%s\widowctrl +{\header\pard\qr\plain\f2\fs%s +%s +p.\chpgn\par} +\fs%s + +END + ($self->doc_lang) x 2, + $self->header_halfpoint_size, + $title, + $self->normal_halfpoint_size, + ; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#------------------------------------------------------------------------- + +use integer; +sub rtf_esc { + my $x; # scratch + if(!defined wantarray) { # void context: alter in-place! + for(@_) { + s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + } + return; + } elsif(wantarray) { # return an array + return map {; ($x = $_) =~ + s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x; + } @_; + } else { # return a single scalar + ($x = ((@_ == 1) ? $_[0] : join '', @_) + ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + # Escape \, {, }, -, control chars, and 7f-ff. + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + return $x; + } +} + +sub rtf_esc_codely { + # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts. + # We don't want to change the "-" to hard-hyphen, because we want to + # be able to paste this into a file and run it without there being + # dire screaming about the mysterious hard-hyphen character (which + # looks just like a normal dash character). + + my $x; # scratch + if(!defined wantarray) { # void context: alter in-place! + for(@_) { + s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + } + return; + } elsif(wantarray) { # return an array + return map {; ($x = $_) =~ + s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x; + } @_; + } else { # return a single scalar + ($x = ((@_ == 1) ? $_[0] : join '', @_) + ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + # Escape \, {, }, -, control chars, and 7f-ff. + $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + return $x; + } +} + +%Escape = ( + (($] lt 5.007_003) # Broken for non-ASCII on early Perls + ? (map( (chr($_),chr($_)), # things not apparently needing escaping + 0x20 .. 0x7E ), + map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things + 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46)) + : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))), + 0x20 .. 0x7E ), + map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))), + 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))), + + # We get to escape out 'F' so that we can send RTF files thru the mail + # without the slightest worry that paragraphs beginning with "From" + # will get munged. + + # And some refinements: + "\r" => "\n", + "\cj" => "\n", + "\n" => "\n\\line ", + + "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) + "\f" => "\n\\page\n", # Formfeed + "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen + $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space + $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen + + # CRAZY HACKS: + "\n" => "\\line\n", + "\r" => "\n", + "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 + "\cc" => "}", +); +1; + +__END__ + +package Pod::Simple::BlackBox; +# +# "What's in the box?" "Pain." +# +########################################################################### +# +# This is where all the scary things happen: parsing lines into +# paragraphs; and then into directives, verbatims, and then also +# turning formatting sequences into treelets. +# +# Are you really sure you want to read this code? +# +#----------------------------------------------------------------------------- +# +# The basic work of this module Pod::Simple::BlackBox is doing the dirty work +# of parsing Pod into treelets (generally one per non-verbatim paragraph), and +# to call the proper callbacks on the treelets. +# +# Every node in a treelet is a ['name', {attrhash}, ...children...] + +use integer; # vroom! +use strict; +use Carp (); +use vars qw($VERSION ); +$VERSION = '3.35'; +#use constant DEBUG => 7; +BEGIN { + require Pod::Simple; + *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG +} + +# Matches a character iff the character will have a different meaning +# if we choose CP1252 vs UTF-8 if there is no =encoding line. +# This is broken for early Perls on non-ASCII platforms. +my $non_ascii_re = eval "qr/[[:^ascii:]]/"; +$non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re; + +my $utf8_bom; +if (($] ge 5.007_003)) { + $utf8_bom = "\x{FEFF}"; + utf8::encode($utf8_bom); +} else { + $utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls. +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub parse_line { shift->parse_lines(@_) } # alias + +# - - - Turn back now! Run away! - - - + +sub parse_lines { # Usage: $parser->parse_lines(@lines) + # an undef means end-of-stream + my $self = shift; + + my $code_handler = $self->{'code_handler'}; + my $cut_handler = $self->{'cut_handler'}; + my $wl_handler = $self->{'whiteline_handler'}; + $self->{'line_count'} ||= 0; + + my $scratch; + + DEBUG > 4 and + print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n"; + + DEBUG > 5 and + print STDERR "# About to parse lines: ", + join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n"; + + my $paras = ($self->{'paras'} ||= []); + # paragraph buffer. Because we need to defer processing of =over + # directives and verbatim paragraphs. We call _ponder_paragraph_buffer + # to process this. + + $self->{'pod_para_count'} ||= 0; + + my $line; + foreach my $source_line (@_) { + if( $self->{'source_dead'} ) { + DEBUG > 4 and print STDERR "# Source is dead.\n"; + last; + } + + unless( defined $source_line ) { + DEBUG > 4 and print STDERR "# Undef-line seen.\n"; + + push @$paras, ['~end', {'start_line' => $self->{'line_count'}}]; + push @$paras, $paras->[-1], $paras->[-1]; + # So that it definitely fills the buffer. + $self->{'source_dead'} = 1; + $self->_ponder_paragraph_buffer; + next; + } + + + if( $self->{'line_count'}++ ) { + ($line = $source_line) =~ tr/\n\r//d; + # If we don't have two vars, we'll end up with that there + # tr/// modding the (potentially read-only) original source line! + + } else { + DEBUG > 2 and print STDERR "First line: [$source_line]\n"; + + if( ($line = $source_line) =~ s/^$utf8_bom//s ) { + DEBUG and print STDERR "UTF-8 BOM seen. Faking a '=encoding utf8'.\n"; + $self->_handle_encoding_line( "=encoding utf8" ); + delete $self->{'_processed_encoding'}; + $line =~ tr/\n\r//d; + + } elsif( $line =~ s/^\xFE\xFF//s ) { + DEBUG and print STDERR "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; + $self->scream( + $self->{'line_count'}, + "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." + ); + splice @_; + push @_, undef; + next; + + # TODO: implement somehow? + + } elsif( $line =~ s/^\xFF\xFE//s ) { + DEBUG and print STDERR "Little-endian UTF-16 BOM seen. Aborting parsing.\n"; + $self->scream( + $self->{'line_count'}, + "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." + ); + splice @_; + push @_, undef; + next; + + # TODO: implement somehow? + + } else { + DEBUG > 2 and print STDERR "First line is BOM-less.\n"; + ($line = $source_line) =~ tr/\n\r//d; + } + } + + if(!$self->{'parse_characters'} && !$self->{'encoding'} + && ($self->{'in_pod'} || $line =~ /^=/s) + && $line =~ /$non_ascii_re/ + ) { + + my $encoding; + + # No =encoding line, and we are at the first line in the input that + # contains a non-ascii byte, that is one whose meaning varies depending + # on whether the file is encoded in UTF-8 or CP1252, which are the two + # possibilities permitted by the pod spec. (ASCII is assumed if the + # file only contains ASCII bytes.) In order to process this line, we + # need to figure out what encoding we will use for the file. + # + # Strictly speaking ISO 8859-1 (Latin 1) refers to the code points + # 160-255, but it is used here, as it often colloquially is, to refer to + # the complete set of code points 0-255, including ASCII (0-127), the C1 + # controls (128-159), and strict Latin 1 (160-255). + # + # CP1252 is effectively a superset of Latin 1, because it differs only + # from colloquial 8859-1 in the C1 controls, which are very unlikely to + # actually be present in 8859-1 files, so can be used for other purposes + # without conflict. CP 1252 uses most of them for graphic characters. + # + # Note that all ASCII-range bytes represent their corresponding code + # points in CP1252 and UTF-8. In ASCII platform UTF-8 all other code + # points require multiple (non-ASCII) bytes to represent. (A separate + # paragraph for EBCDIC is below.) The multi-byte representation is + # quite structured. If we find an isolated byte that requires multiple + # bytes to represent in UTF-8, we know that the encoding is not UTF-8. + # If we find a sequence of bytes that violates the UTF-8 structure, we + # also can presume the encoding isn't UTF-8, and hence must be 1252. + # + # But there are ambiguous cases where we could guess wrong. If so, the + # user will end up having to supply an =encoding line. We use all + # readily available information to improve our chances of guessing + # right. The odds of something not being UTF-8, but still passing a + # UTF-8 validity test go down very rapidly with increasing length of the + # sequence. Therefore we look at all the maximal length non-ascii + # sequences on the line. If any of the sequences can't be UTF-8, we + # quit there and choose CP1252. If all could be UTF-8, we guess UTF-8. + # + # On EBCDIC platforms, the situation is somewhat different. In + # UTF-EBCDIC, not only do ASCII-range bytes represent their code points, + # but so do the bytes that are for the C1 controls. Recall that these + # correspond to the unused portion of 8859-1 that 1252 mostly takes + # over. That means that there are fewer code points that are + # represented by multi-bytes. But, note that the these controls are + # very unlikely to be in pod text. So if we encounter one of them, it + # means that it is quite likely CP1252 and not UTF-8. The net result is + # the same code below is used for both platforms. + while ($line =~ m/($non_ascii_re+)/g) { + my $non_ascii_seq = $1; + + if (length $non_ascii_seq == 1) { + $encoding = 'CP1252'; + goto guessed; + } elsif ($] ge 5.007_003) { + + # On Perls that have this function, we can see if the sequence is + # valid UTF-8 or not. + my $is_utf8; + { + no warnings 'utf8'; + $is_utf8 = utf8::decode($non_ascii_seq); + } + if (! $is_utf8) { + $encoding = 'CP1252'; + goto guessed; + } + } elsif (ord("A") == 65) { # An early Perl, ASCII platform + + # Without utf8::decode, it's a lot harder to do a rigorous check + # (though some early releases had a different function that + # accomplished the same thing). Since these are ancient Perls, not + # likely to be in use today, we take the easy way out, and look at + # just the first two bytes of the sequence to see if they are the + # start of a UTF-8 character. In ASCII UTF-8, continuation bytes + # must be between 0x80 and 0xBF. Start bytes can range from 0xC2 + # through 0xFF, but anything above 0xF4 is not Unicode, and hence + # extremely unlikely to be in a pod. + if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) { + $encoding = 'CP1252'; + goto guessed; + } + + # We don't bother doing anything special for EBCDIC on early Perls. + # If there is a solitary variant, CP1252 will be chosen; otherwise + # UTF-8. + } + } # End of loop through all variant sequences on the line + + # All sequences in the line could be UTF-8. Guess that. + $encoding = 'UTF-8'; + + guessed: + $self->_handle_encoding_line( "=encoding $encoding" ); + delete $self->{'_processed_encoding'}; + $self->{'_transcoder'} && $self->{'_transcoder'}->($line); + + my ($word) = $line =~ /(\S*$non_ascii_re\S*)/; + + $self->whine( + $self->{'line_count'}, + "Non-ASCII character seen before =encoding in '$word'. Assuming $encoding" + ); + } + + DEBUG > 5 and print STDERR "# Parsing line: [$line]\n"; + + if(!$self->{'in_pod'}) { + if($line =~ m/^=([a-zA-Z][a-zA-Z0-9]*)(?:\s|$)/s) { + if($1 eq 'cut') { + $self->scream( + $self->{'line_count'}, + "=cut found outside a pod block. Skipping to next block." + ); + + ## Before there were errata sections in the world, it was + ## least-pessimal to abort processing the file. But now we can + ## just barrel on thru (but still not start a pod block). + #splice @_; + #push @_, undef; + + next; + } else { + $self->{'in_pod'} = $self->{'start_of_pod_block'} + = $self->{'last_was_blank'} = 1; + # And fall thru to the pod-mode block further down + } + } else { + DEBUG > 5 and print STDERR "# It's a code-line.\n"; + $code_handler->(map $_, $line, $self->{'line_count'}, $self) + if $code_handler; + # Note: this may cause code to be processed out of order relative + # to pods, but in order relative to cuts. + + # Note also that we haven't yet applied the transcoding to $line + # by time we call $code_handler! + + if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) { + # That RE is from perlsyn, section "Plain Old Comments (Not!)", + #$fname = $2 if defined $2; + #DEBUG > 1 and defined $2 and print STDERR "# Setting fname to \"$fname\"\n"; + DEBUG > 1 and print STDERR "# Setting nextline to $1\n"; + $self->{'line_count'} = $1 - 1; + } + + next; + } + } + + # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + # Else we're in pod mode: + + # Apply any necessary transcoding: + $self->{'_transcoder'} && $self->{'_transcoder'}->($line); + + # HERE WE CATCH =encoding EARLY! + if( $line =~ m/^=encoding\s+\S+\s*$/s ) { + next if $self->parse_characters; # Ignore this line + $line = $self->_handle_encoding_line( $line ); + } + + if($line =~ m/^=cut/s) { + # here ends the pod block, and therefore the previous pod para + DEBUG > 1 and print STDERR "Noting =cut at line ${$self}{'line_count'}\n"; + $self->{'in_pod'} = 0; + # ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + $cut_handler->(map $_, $line, $self->{'line_count'}, $self) + if $cut_handler; + + # TODO: add to docs: Note: this may cause cuts to be processed out + # of order relative to pods, but in order relative to code. + + } elsif($line =~ m/^(\s*)$/s) { # it's a blank line + if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line + $wl_handler->(map $_, $line, $self->{'line_count'}, $self) + if $wl_handler; + } + + if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { + DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n"; + push @{$paras->[-1]}, $line; + } # otherwise it's not interesting + + if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { + DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n"; + } + + $self->{'last_was_blank'} = 1; + + } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para... + + if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) { + # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS + my $new = [$1, {'start_line' => $self->{'line_count'}}, $2]; + # Note that in "=head1 foo", the WS is lost. + # Example: ['=head1', {'start_line' => 123}, ' foo'] + + ++$self->{'pod_para_count'}; + + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + + push @$paras, $new; # the new incipient paragraph + DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; + + } elsif($line =~ m/^\s/s) { + + if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { + DEBUG > 1 and print STDERR "Resuming verbatim para at line ${$self}{'line_count'}\n"; + push @{$paras->[-1]}, $line; + } else { + ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + DEBUG > 1 and print STDERR "Starting verbatim para at line ${$self}{'line_count'}\n"; + push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line]; + } + } else { + ++$self->{'pod_para_count'}; + $self->_ponder_paragraph_buffer(); + # by now it's safe to consider the previous paragraph as done. + push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line]; + DEBUG > 1 and print STDERR "Starting plain para at line ${$self}{'line_count'}\n"; + } + $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; + + } else { + # It's a non-blank line /continuing/ the current para + if(@$paras) { + DEBUG > 2 and print STDERR "Line ${$self}{'line_count'} continues current paragraph\n"; + push @{$paras->[-1]}, $line; + } else { + # Unexpected case! + die "Continuing a paragraph but \@\$paras is empty?"; + } + $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; + } + + } # ends the big while loop + + DEBUG > 1 and print STDERR (pretty(@$paras), "\n"); + return $self; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_encoding_line { + my($self, $line) = @_; + + return if $self->parse_characters; + + # The point of this routine is to set $self->{'_transcoder'} as indicated. + + return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s; + DEBUG > 1 and print STDERR "Found an encoding line \"=encoding $1\"\n"; + + my $e = $1; + my $orig = $e; + push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig"; + + my $enc_error; + + # Cf. perldoc Encode and perldoc Encode::Supported + + require Pod::Simple::Transcode; + + if( $self->{'encoding'} ) { + my $norm_current = $self->{'encoding'}; + my $norm_e = $e; + foreach my $that ($norm_current, $norm_e) { + $that = lc($that); + $that =~ s/[-_]//g; + } + if($norm_current eq $norm_e) { + DEBUG > 1 and print STDERR "The '=encoding $orig' line is ", + "redundant. ($norm_current eq $norm_e). Ignoring.\n"; + $enc_error = ''; + # But that doesn't necessarily mean that the earlier one went okay + } else { + $enc_error = "Encoding is already set to " . $self->{'encoding'}; + DEBUG > 1 and print STDERR $enc_error; + } + } elsif ( + # OK, let's turn on the encoding + do { + DEBUG > 1 and print STDERR " Setting encoding to $e\n"; + $self->{'encoding'} = $e; + 1; + } + and $e eq 'HACKRAW' + ) { + DEBUG and print STDERR " Putting in HACKRAW (no-op) encoding mode.\n"; + + } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) { + + die($enc_error = "WHAT? _transcoder is already set?!") + if $self->{'_transcoder'}; # should never happen + require Pod::Simple::Transcode; + $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e); + eval { + my @x = ('', "abc", "123"); + $self->{'_transcoder'}->(@x); + }; + $@ && die( $enc_error = + "Really unexpected error setting up encoding $e: $@\nAborting" + ); + $self->{'detected_encoding'} = $e; + + } else { + my @supported = Pod::Simple::Transcode::->all_encodings; + + # Note unsupported, and complain + DEBUG and print STDERR " Encoding [$e] is unsupported.", + "\nSupporteds: @supported\n"; + my $suggestion = ''; + + # Look for a near match: + my $norm = lc($e); + $norm =~ tr[-_][]d; + my $n; + foreach my $enc (@supported) { + $n = lc($enc); + $n =~ tr[-_][]d; + next unless $n eq $norm; + $suggestion = " (Maybe \"$e\" should be \"$enc\"?)"; + last; + } + my $encmodver = Pod::Simple::Transcode::->encmodver; + $enc_error = join '' => + "This document probably does not appear as it should, because its ", + "\"=encoding $e\" line calls for an unsupported encoding.", + $suggestion, " [$encmodver\'s supported encodings are: @supported]" + ; + + $self->scream( $self->{'line_count'}, $enc_error ); + } + push @{ $self->{'encoding_command_statuses'} }, $enc_error; + if (defined($self->{'_processed_encoding'})) { + # Double declaration. + $self->scream( $self->{'line_count'}, 'Cannot have multiple =encoding directives'); + } + $self->{'_processed_encoding'} = $orig; + + return $line; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _handle_encoding_second_level { + # By time this is called, the encoding (if well formed) will already + # have been acted one. + my($self, $para) = @_; + my @x = @$para; + my $content = join ' ', splice @x, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + + DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n"; + + if (defined($self->{'_processed_encoding'})) { + #if($content ne $self->{'_processed_encoding'}) { + # Could it happen? + #} + delete $self->{'_processed_encoding'}; + # It's already been handled. Check for errors. + if(! $self->{'encoding_command_statuses'} ) { + DEBUG > 2 and print STDERR " CRAZY ERROR: It wasn't really handled?!\n"; + } elsif( $self->{'encoding_command_statuses'}[-1] ) { + $self->whine( $para->[1]{'start_line'}, + sprintf "Couldn't do %s: %s", + $self->{'encoding_command_reqs' }[-1], + $self->{'encoding_command_statuses'}[-1], + ); + } else { + DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n"; + } + + } else { + # Otherwise it's a syntax error + $self->whine( $para->[1]{'start_line'}, + "Invalid =encoding syntax: $content" + ); + } + + return; +} + +#~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~` + +{ +my $m = -321; # magic line number + +sub _gen_errata { + my $self = $_[0]; + # Return 0 or more fake-o paragraphs explaining the accumulated + # errors on this document. + + return() unless $self->{'errata'} and keys %{$self->{'errata'}}; + + my @out; + + foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) { + push @out, + ['=item', {'start_line' => $m}, "Around line $line:"], + map( ['~Para', {'start_line' => $m, '~cooked' => 1}, + #['~Top', {'start_line' => $m}, + $_ + #] + ], + @{$self->{'errata'}{$line}} + ) + ; + } + + # TODO: report of unknown entities? unrenderable characters? + + unshift @out, + ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'], + ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1}, + "Hey! ", + ['B', {}, + 'The above document had some coding errors, which are explained below:' + ] + ], + ['=over', {'start_line' => $m, 'errata' => 1}, ''], + ; + + push @out, + ['=back', {'start_line' => $m, 'errata' => 1}, ''], + ; + + DEBUG and print STDERR "\n<<\n", pretty(\@out), "\n>>\n\n"; + + return @out; +} + +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +############################################################################## +## +## stop reading now stop reading now stop reading now stop reading now stop +## +## HERE IT BECOMES REALLY SCARY +## +## stop reading now stop reading now stop reading now stop reading now stop +## +############################################################################## + +sub _ponder_paragraph_buffer { + + # Para-token types as found in the buffer. + # ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end, + # =over, =back, =item + # and the null =pod (to be complained about if over one line) + # + # "~data" paragraphs are something we generate at this level, depending on + # a currently open =over region + + # Events fired: Begin and end for: + # directivename (like head1 .. head4), item, extend, + # for (from =begin...=end, =for), + # over-bullet, over-number, over-text, over-block, + # item-bullet, item-number, item-text, + # Document, + # Data, Para, Verbatim + # B, C, longdirname (TODO -- wha?), etc. for all directives + # + + my $self = $_[0]; + my $paras; + return unless @{$paras = $self->{'paras'}}; + my $curr_open = ($self->{'curr_open'} ||= []); + + my $scratch; + + DEBUG > 10 and print STDERR "# Paragraph buffer: <<", pretty($paras), ">>\n"; + + # We have something in our buffer. So apparently the document has started. + unless($self->{'doc_has_started'}) { + $self->{'doc_has_started'} = 1; + + my $starting_contentless; + $starting_contentless = + ( + !@$curr_open + and @$paras and ! grep $_->[0] ne '~end', @$paras + # i.e., if the paras is all ~ends + ) + ; + DEBUG and print STDERR "# Starting ", + $starting_contentless ? 'contentless' : 'contentful', + " document\n" + ; + + $self->_handle_element_start( + ($scratch = 'Document'), + { + 'start_line' => $paras->[0][1]{'start_line'}, + $starting_contentless ? ( 'contentless' => 1 ) : (), + }, + ); + } + + my($para, $para_type); + while(@$paras) { + last if @$paras == 1 and + ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim' + or $paras->[0][0] eq '=item' ) + ; + # Those're the three kinds of paragraphs that require lookahead. + # Actually, an "=item Foo" inside an region + # and any =item inside an region (rare) + # don't require any lookahead, but all others (bullets + # and numbers) do. + +# TODO: whinge about many kinds of directives in non-resolving =for regions? +# TODO: many? like what? =head1 etc? + + $para = shift @$paras; + $para_type = $para->[0]; + + DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (", + $self->_dump_curr_open(), ")\n"; + + if($para_type eq '=for') { + next if $self->_ponder_for($para,$curr_open,$paras); + + } elsif($para_type eq '=begin') { + next if $self->_ponder_begin($para,$curr_open,$paras); + + } elsif($para_type eq '=end') { + next if $self->_ponder_end($para,$curr_open,$paras); + + } elsif($para_type eq '~end') { # The virtual end-document signal + next if $self->_ponder_doc_end($para,$curr_open,$paras); + } + + + # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and + print STDERR "Skipping $para_type paragraph because in ignore mode.\n"; + next; + } + #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + + if($para_type eq '=pod') { + $self->_ponder_pod($para,$curr_open,$paras); + + } elsif($para_type eq '=over') { + next if $self->_ponder_over($para,$curr_open,$paras); + + } elsif($para_type eq '=back') { + next if $self->_ponder_back($para,$curr_open,$paras); + + } else { + + # All non-magical codes!!! + + # Here we start using $para_type for our own twisted purposes, to + # mean how it should get treated, not as what the element name + # should be. + + DEBUG > 1 and print STDERR "Pondering non-magical $para_type\n"; + + my $i; + + # Enforce some =headN discipline + if($para_type =~ m/^=head\d$/s + and ! $self->{'accept_heads_anywhere'} + and @$curr_open + and $curr_open->[-1][0] eq '=over' + ) { + DEBUG > 2 and print STDERR "'=$para_type' inside an '=over'!\n"; + $self->whine( + $para->[1]{'start_line'}, + "You forgot a '=back' before '$para_type'" + ); + unshift @$paras, ['=back', {}, ''], $para; # close the =over + next; + } + + + if($para_type eq '=item') { + + my $over; + unless(@$curr_open and + $over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) { + $self->whine( + $para->[1]{'start_line'}, + "'=item' outside of any '=over'" + ); + unshift @$paras, + ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], + $para + ; + next; + } + + + my $over_type = $over->[1]{'~type'}; + + if(!$over_type) { + # Shouldn't happen1 + die "Typeless over in stack, starting at line " + . $over->[1]{'start_line'}; + + } elsif($over_type eq 'block') { + unless($curr_open->[-1][1]{'~bitched_about'}) { + $curr_open->[-1][1]{'~bitched_about'} = 1; + $self->whine( + $curr_open->[-1][1]{'start_line'}, + "You can't have =items (as at line " + . $para->[1]{'start_line'} + . ") unless the first thing after the =over is an =item" + ); + } + # Just turn it into a paragraph and reconsider it + $para->[0] = '~Para'; + unshift @$paras, $para; + next; + + } elsif($over_type eq 'text') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'text') { + # Nothing special needs doing for 'text' + } elsif($item_type eq 'number' or $item_type eq 'bullet') { + $self->whine( + $para->[1]{'start_line'}, + "Expected text after =item, not a $item_type" + ); + # Undo our clobbering: + push @$para, $para->[1]{'~orig_content'}; + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + # =item-text thingies don't need any assimilation, it seems. + + } elsif($over_type eq 'number') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; + + if($item_type eq 'bullet') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + push @$para, $para->[1]{'~orig_content'}; + # restore the bullet, blocking the assimilation of next para + + } elsif($item_type eq 'text') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + # Text content will still be there and will block next ~Para + + } elsif($item_type ne 'number') { + die "Unknown item type $item_type"; # should never happen + + } elsif($expected_value == $para->[1]{'number'}) { + DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; + + } else { + DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, + " instead of the expected value of $expected_value\n"; + $self->whine( + $para->[1]{'start_line'}, + "You have '=item " . $para->[1]{'number'} . + "' instead of the expected '=item $expected_value'" + ); + $para->[1]{'number'} = $expected_value; # correcting!! + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + + } elsif($over_type eq 'bullet') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'bullet') { + # as expected! + + if( $para->[1]{'~_freaky_para_hack'} ) { + DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; + push @$para, delete $para->[1]{'~_freaky_para_hack'}; + } + + } elsif($item_type eq 'number') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + push @$para, $para->[1]{'~orig_content'}; + # and block assimilation of the next paragraph + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } elsif($item_type eq 'text') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + # But doesn't need processing. But it'll block assimilation + # of the next para. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + } else { + die "Unhandled =over type \"$over_type\"?"; + # Shouldn't happen! + } + + $para_type = 'Plain'; + $para->[0] .= '-' . $over_type; + # Whew. Now fall thru and process it. + + + } elsif($para_type eq '=extend') { + # Well, might as well implement it here. + $self->_ponder_extend($para); + next; # and skip + } elsif($para_type eq '=encoding') { + # Not actually acted on here, but we catch errors here. + $self->_handle_encoding_second_level($para); + next unless $self->keep_encoding_directive; + $para_type = 'Plain'; + } elsif($para_type eq '~Verbatim') { + $para->[0] = 'Verbatim'; + $para_type = '?Verbatim'; + } elsif($para_type eq '~Para') { + $para->[0] = 'Para'; + $para_type = '?Plain'; + } elsif($para_type eq 'Data') { + $para->[0] = 'Data'; + $para_type = '?Data'; + } elsif( $para_type =~ s/^=//s + and defined( $para_type = $self->{'accept_directives'}{$para_type} ) + ) { + DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n"; + } else { + # An unknown directive! + DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n", + $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) + ; + $self->whine( + $para->[1]{'start_line'}, + "Unknown directive: $para->[0]" + ); + + # And maybe treat it as text instead of just letting it go? + next; + } + + if($para_type =~ s/^\?//s) { + if(! @$curr_open) { # usual case + DEBUG and print STDERR "Treating $para_type paragraph as such because stack is empty.\n"; + } else { + my @fors = grep $_->[0] eq '=for', @$curr_open; + DEBUG > 1 and print STDERR "Containing fors: ", + join(',', map $_->[1]{'target'}, @fors), "\n"; + + if(! @fors) { + DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n"; + + #} elsif(grep $_->[1]{'~resolve'}, @fors) { + #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { + } elsif( $fors[-1][1]{'~resolve'} ) { + # Look to the immediately containing for + + if($para_type eq 'Data') { + DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; + $para->[0] = 'Para'; + $para_type = 'Plain'; + } else { + DEBUG and print STDERR "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; + } + } else { + DEBUG and print STDERR "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n"; + $para->[0] = $para_type = 'Data'; + } + } + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + if($para_type eq 'Plain') { + $self->_ponder_Plain($para); + } elsif($para_type eq 'Verbatim') { + $self->_ponder_Verbatim($para); + } elsif($para_type eq 'Data') { + $self->_ponder_Data($para); + } else { + die "\$para type is $para_type -- how did that happen?"; + # Shouldn't happen. + } + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + $para->[0] =~ s/^[~=]//s; + + DEBUG and print STDERR "\n", pretty($para), "\n"; + + # traverse the treelet (which might well be just one string scalar) + $self->{'content_seen'} ||= 1; + $self->_traverse_treelet_bit(@$para); + } + } + + return; +} + +########################################################################### +# The sub-ponderers... + + + +sub _ponder_for { + my ($self,$para,$curr_open,$paras) = @_; + + # Fake it out as a begin/end + my $target; + + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print STDERR "Ignoring ignorable =for\n"; + return 1; + } + + for(my $i = 2; $i < @$para; ++$i) { + if($para->[$i] =~ s/^\s*(\S+)\s*//s) { + $target = $1; + last; + } + } + unless(defined $target) { + $self->whine( + $para->[1]{'start_line'}, + "=for without a target?" + ); + return 1; + } + DEBUG > 1 and + print STDERR "Faking out a =for $target as a =begin $target / =end $target\n"; + + $para->[0] = 'Data'; + + unshift @$paras, + ['=begin', + {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, + $target, + ], + $para, + ['=end', + {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, + $target, + ], + ; + + return 1; +} + +sub _ponder_begin { + my ($self,$para,$curr_open,$paras) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + unless(length($content)) { + $self->whine( + $para->[1]{'start_line'}, + "=begin without a target?" + ); + DEBUG and print STDERR "Ignoring targetless =begin\n"; + return 1; + } + + my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/; + $para->[1]{'title'} = $title if ($title); + $para->[1]{'target'} = $target; # without any ':' + $content = $target; # strip off the title + + $content =~ s/^:!/!:/s; + my $neg; # whether this is a negation-match + $neg = 1 if $content =~ s/^!//s; + my $to_resolve; # whether to process formatting codes + $to_resolve = 1 if $content =~ s/^://s; + + my $dont_ignore; # whether this target matches us + + foreach my $target_name ( + split(',', $content, -1), + $neg ? () : '*' + ) { + DEBUG > 2 and + print STDERR " Considering whether =begin $content matches $target_name\n"; + next unless $self->{'accept_targets'}{$target_name}; + + DEBUG > 2 and + print STDERR " It DOES match the acceptable target $target_name!\n"; + $to_resolve = 1 + if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; + $dont_ignore = 1; + $para->[1]{'target_matching'} = $target_name; + last; # stop looking at other target names + } + + if($neg) { + if( $dont_ignore ) { + $dont_ignore = ''; + delete $para->[1]{'target_matching'}; + DEBUG > 2 and print STDERR " But the leading ! means that this is a NON-match!\n"; + } else { + $dont_ignore = 1; + $para->[1]{'target_matching'} = '!'; + DEBUG > 2 and print STDERR " But the leading ! means that this IS a match!\n"; + } + } + + $para->[0] = '=for'; # Just what we happen to call these, internally + $para->[1]{'~really'} ||= '=begin'; + $para->[1]{'~ignore'} = (! $dont_ignore) || 0; + $para->[1]{'~resolve'} = $to_resolve || 0; + + DEBUG > 1 and print STDERR " Making note to ", $dont_ignore ? 'not ' : '', + "ignore contents of this region\n"; + DEBUG > 1 and $dont_ignore and print STDERR " Making note to treat contents as ", + ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; + DEBUG > 1 and print STDERR " (Stack now: ", $self->_dump_curr_open(), ")\n"; + + push @$curr_open, $para; + if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n"; + } else { + $self->{'content_seen'} ||= 1; + $self->_handle_element_start((my $scratch='for'), $para->[1]); + } + + return 1; +} + +sub _ponder_end { + my ($self,$para,$curr_open,$paras) = @_; + my $content = join ' ', splice @$para, 2; + $content =~ s/^\s+//s; + $content =~ s/\s+$//s; + DEBUG and print STDERR "Ogling '=end $content' directive\n"; + + unless(length($content)) { + $self->whine( + $para->[1]{'start_line'}, + "'=end' without a target?" . ( + ( @$curr_open and $curr_open->[-1][0] eq '=for' ) + ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' ) + : '' + ) + ); + DEBUG and print STDERR "Ignoring targetless =end\n"; + return 1; + } + + unless($content =~ m/^\S+$/) { # i.e., unless it's one word + $self->whine( + $para->[1]{'start_line'}, + "'=end $content' is invalid. (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; + return 1; + } + + unless(@$curr_open and $curr_open->[-1][0] eq '=for') { + $self->whine( + $para->[1]{'start_line'}, + "=end $content without matching =begin. (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; + return 1; + } + + unless($content eq $curr_open->[-1][1]{'target'}) { + $self->whine( + $para->[1]{'start_line'}, + "=end $content doesn't match =begin " + . $curr_open->[-1][1]{'target'} + . ". (Stack: " + . $self->_dump_curr_open() . ')' + ); + DEBUG and print STDERR "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; + return 1; + } + + # Else it's okay to close... + if(grep $_->[1]{'~ignore'}, @$curr_open) { + DEBUG > 1 and print STDERR "Not firing any event for this =end $content because in an ignored region\n"; + # And that may be because of this to-be-closed =for region, or some + # other one, but it doesn't matter. + } else { + $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; + # what's that for? + + $self->{'content_seen'} ||= 1; + $self->_handle_element_end( my $scratch = 'for', $para->[1]); + } + DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; + pop @$curr_open; + + return 1; +} + +sub _ponder_doc_end { + my ($self,$para,$curr_open,$paras) = @_; + if(@$curr_open) { # Deal with things left open + DEBUG and print STDERR "Stack is nonempty at end-document: (", + $self->_dump_curr_open(), ")\n"; + + DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n"; + unshift @$paras, $self->_closers_for_all_curr_open; + # Make sure there is exactly one ~end in the parastack, at the end: + @$paras = grep $_->[0] ne '~end', @$paras; + push @$paras, $para, $para; + # We need two -- once for the next cycle where we + # generate errata, and then another to be at the end + # when that loop back around to process the errata. + return 1; + + } else { + DEBUG and print STDERR "Okay, stack is empty now.\n"; + } + + # Try generating errata section, if applicable + unless($self->{'~tried_gen_errata'}) { + $self->{'~tried_gen_errata'} = 1; + my @extras = $self->_gen_errata(); + if(@extras) { + unshift @$paras, @extras; + DEBUG and print STDERR "Generated errata... relooping...\n"; + return 1; # I.e., loop around again to process these fake-o paragraphs + } + } + + splice @$paras; # Well, that's that for this paragraph buffer. + DEBUG and print STDERR "Throwing end-document event.\n"; + + $self->_handle_element_end( my $scratch = 'Document' ); + return 1; # Hasta la byebye +} + +sub _ponder_pod { + my ($self,$para,$curr_open,$paras) = @_; + $self->whine( + $para->[1]{'start_line'}, + "=pod directives shouldn't be over one line long! Ignoring all " + . (@$para - 2) . " lines of content" + ) if @$para > 3; + + # Content ignored unless 'pod_handler' is set + if (my $pod_handler = $self->{'pod_handler'}) { + my ($line_num, $line) = map $_, $para->[1]{'start_line'}, $para->[2]; + $line = $line eq '' ? "=pod" : "=pod $line"; # imitate cut_handler output + $pod_handler->($line, $line_num, $self); + } + + # The surrounding methods set content_seen, so let us remain consistent. + # I do not know why it was not here before -- should it not be here? + # $self->{'content_seen'} ||= 1; + + return; +} + +sub _ponder_over { + my ($self,$para,$curr_open,$paras) = @_; + return 1 unless @$paras; + my $list_type; + + if($paras->[0][0] eq '=item') { # most common case + $list_type = $self->_get_initial_item_type($paras->[0]); + + } elsif($paras->[0][0] eq '=back') { + # Ignore empty lists by default + if ($self->{'parse_empty_lists'}) { + $list_type = 'empty'; + } else { + shift @$paras; + return 1; + } + } elsif($paras->[0][0] eq '~end') { + $self->whine( + $para->[1]{'start_line'}, + "=over is the last thing in the document?!" + ); + return 1; # But feh, ignore it. + } else { + $list_type = 'block'; + } + $para->[1]{'~type'} = $list_type; + push @$curr_open, $para; + # yes, we reuse the paragraph as a stack item + + my $content = join ' ', splice @$para, 2; + my $overness; + if($content =~ m/^\s*$/s) { + $para->[1]{'indent'} = 4; + } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) { + no integer; + $para->[1]{'indent'} = $1; + if($1 == 0) { + $self->whine( + $para->[1]{'start_line'}, + "Can't have a 0 in =over $content" + ); + $para->[1]{'indent'} = 4; + } + } else { + $self->whine( + $para->[1]{'start_line'}, + "=over should be: '=over' or '=over positive_number'" + ); + $para->[1]{'indent'} = 4; + } + DEBUG > 1 and print STDERR "=over found of type $list_type\n"; + + $self->{'content_seen'} ||= 1; + $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); + + return; +} + +sub _ponder_back { + my ($self,$para,$curr_open,$paras) = @_; + # TODO: fire off or or ?? + + my $content = join ' ', splice @$para, 2; + if($content =~ m/\S/) { + $self->whine( + $para->[1]{'start_line'}, + "=back doesn't take any parameters, but you said =back $content" + ); + } + + if(@$curr_open and $curr_open->[-1][0] eq '=over') { + DEBUG > 1 and print STDERR "=back happily closes matching =over\n"; + # Expected case: we're closing the most recently opened thing + #my $over = pop @$curr_open; + $self->{'content_seen'} ||= 1; + $self->_handle_element_end( my $scratch = + 'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1] + ); + } else { + DEBUG > 1 and print STDERR "=back found without a matching =over. Stack: (", + join(', ', map $_->[0], @$curr_open), ").\n"; + $self->whine( + $para->[1]{'start_line'}, + '=back without =over' + ); + return 1; # and ignore it + } +} + +sub _ponder_item { + my ($self,$para,$curr_open,$paras) = @_; + my $over; + unless(@$curr_open and + $over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) { + $self->whine( + $para->[1]{'start_line'}, + "'=item' outside of any '=over'" + ); + unshift @$paras, + ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], + $para + ; + return 1; + } + + + my $over_type = $over->[1]{'~type'}; + + if(!$over_type) { + # Shouldn't happen1 + die "Typeless over in stack, starting at line " + . $over->[1]{'start_line'}; + + } elsif($over_type eq 'block') { + unless($curr_open->[-1][1]{'~bitched_about'}) { + $curr_open->[-1][1]{'~bitched_about'} = 1; + $self->whine( + $curr_open->[-1][1]{'start_line'}, + "You can't have =items (as at line " + . $para->[1]{'start_line'} + . ") unless the first thing after the =over is an =item" + ); + } + # Just turn it into a paragraph and reconsider it + $para->[0] = '~Para'; + unshift @$paras, $para; + return 1; + + } elsif($over_type eq 'text') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'text') { + # Nothing special needs doing for 'text' + } elsif($item_type eq 'number' or $item_type eq 'bullet') { + $self->whine( + $para->[1]{'start_line'}, + "Expected text after =item, not a $item_type" + ); + # Undo our clobbering: + push @$para, $para->[1]{'~orig_content'}; + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + # =item-text thingies don't need any assimilation, it seems. + + } elsif($over_type eq 'number') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; + + if($item_type eq 'bullet') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + push @$para, $para->[1]{'~orig_content'}; + # restore the bullet, blocking the assimilation of next para + + } elsif($item_type eq 'text') { + # Hm, it's not numeric. Correct for this. + $para->[1]{'number'} = $expected_value; + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item $expected_value'" + ); + # Text content will still be there and will block next ~Para + + } elsif($item_type ne 'number') { + die "Unknown item type $item_type"; # should never happen + + } elsif($expected_value == $para->[1]{'number'}) { + DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; + + } else { + DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, + " instead of the expected value of $expected_value\n"; + $self->whine( + $para->[1]{'start_line'}, + "You have '=item " . $para->[1]{'number'} . + "' instead of the expected '=item $expected_value'" + ); + $para->[1]{'number'} = $expected_value; # correcting!! + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + + } elsif($over_type eq 'bullet') { + my $item_type = $self->_get_item_type($para); + # That kills the content of the item if it's a number or bullet. + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; + + if($item_type eq 'bullet') { + # as expected! + + if( $para->[1]{'~_freaky_para_hack'} ) { + DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; + push @$para, delete $para->[1]{'~_freaky_para_hack'}; + } + + } elsif($item_type eq 'number') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + push @$para, $para->[1]{'~orig_content'}; + # and block assimilation of the next paragraph + delete $para->[1]{'number'}; + # Only a PROPER item-number element is allowed + # to have a number attribute. + } elsif($item_type eq 'text') { + $self->whine( + $para->[1]{'start_line'}, + "Expected '=item *'" + ); + # But doesn't need processing. But it'll block assimilation + # of the next para. + } else { + die "Unhandled item type $item_type"; # should never happen + } + + if(@$para == 2) { + # For the cases where we /didn't/ push to @$para + if($paras->[0][0] eq '~Para') { + DEBUG and print STDERR "Assimilating following ~Para content into $over_type item\n"; + push @$para, splice @{shift @$paras},2; + } else { + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; + push @$para, ''; # Just so it's not contentless + } + } + + } else { + die "Unhandled =over type \"$over_type\"?"; + # Shouldn't happen! + } + $para->[0] .= '-' . $over_type; + + return; +} + +sub _ponder_Plain { + my ($self,$para) = @_; + DEBUG and print STDERR " giving plain treatment...\n"; + unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) + or $para->[1]{'~cooked'} + ) { + push @$para, + @{$self->_make_treelet( + join("\n", splice(@$para, 2)), + $para->[1]{'start_line'} + )}; + } + # Empty paragraphs don't need a treelet for any reason I can see. + # And precooked paragraphs already have a treelet. + return; +} + +sub _ponder_Verbatim { + my ($self,$para) = @_; + DEBUG and print STDERR " giving verbatim treatment...\n"; + + $para->[1]{'xml:space'} = 'preserve'; + + my $indent = $self->strip_verbatim_indent; + if ($indent && ref $indent eq 'CODE') { + my @shifted = (shift @{$para}, shift @{$para}); + $indent = $indent->($para); + unshift @{$para}, @shifted; + } + + for(my $i = 2; $i < @$para; $i++) { + foreach my $line ($para->[$i]) { # just for aliasing + # Strip indentation. + $line =~ s/^\Q$indent// if $indent + && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); + while( $line =~ + # Sort of adapted from Text::Tabs -- yes, it's hardwired in that + # tabs are at every EIGHTH column. For portability, it has to be + # one setting everywhere, and 8th wins. + s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e + ) {} + + # TODO: whinge about (or otherwise treat) unindented or overlong lines + + } + } + + # Now the VerbatimFormatted hoodoo... + if( $self->{'accept_codes'} and + $self->{'accept_codes'}{'VerbatimFormatted'} + ) { + while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para } + # Kill any number of terminal newlines + $self->_verbatim_format($para); + } elsif ($self->{'codes_in_verbatim'}) { + push @$para, + @{$self->_make_treelet( + join("\n", splice(@$para, 2)), + $para->[1]{'start_line'}, $para->[1]{'xml:space'} + )}; + $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines + } else { + push @$para, join "\n", splice(@$para, 2) if @$para > 3; + $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines + } + return; +} + +sub _ponder_Data { + my ($self,$para) = @_; + DEBUG and print STDERR " giving data treatment...\n"; + $para->[1]{'xml:space'} = 'preserve'; + push @$para, join "\n", splice(@$para, 2) if @$para > 3; + return; +} + + + + +########################################################################### + +sub _traverse_treelet_bit { # for use only by the routine above + my($self, $name) = splice @_,0,2; + + my $scratch; + $self->_handle_element_start(($scratch=$name), shift @_); + + while (@_) { + my $x = shift; + if (ref($x)) { + &_traverse_treelet_bit($self, @$x); + } else { + $x .= shift while @_ && !ref($_[0]); + $self->_handle_text($x); + } + } + + $self->_handle_element_end($scratch=$name); + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _closers_for_all_curr_open { + my $self = $_[0]; + my @closers; + foreach my $still_open (@{ $self->{'curr_open'} || return }) { + my @copy = @$still_open; + $copy[1] = {%{ $copy[1] }}; + #$copy[1]{'start_line'} = -1; + if($copy[0] eq '=for') { + $copy[0] = '=end'; + } elsif($copy[0] eq '=over') { + $self->whine( + $still_open->[1]{start_line} , + "=over without closing =back" + ); + + $copy[0] = '=back'; + } else { + die "I don't know how to auto-close an open $copy[0] region"; + } + + unless( @copy > 2 ) { + push @copy, $copy[1]{'target'}; + $copy[-1] = '' unless defined $copy[-1]; + # since =over's don't have targets + } + + $copy[1]{'fake-closer'} = 1; + + DEBUG and print STDERR "Queuing up fake-o event: ", pretty(\@copy), "\n"; + unshift @closers, \@copy; + } + return @closers; +} + +#-------------------------------------------------------------------------- + +sub _verbatim_format { + my($it, $p) = @_; + + my $formatting; + + for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines + DEBUG and print STDERR "_verbatim_format appends a newline to $i: $p->[$i]\n"; + $p->[$i] .= "\n"; + # Unlike with simple Verbatim blocks, we don't end up just doing + # a join("\n", ...) on the contents, so we have to append a + # newline to ever line, and then nix the last one later. + } + + if( DEBUG > 4 ) { + print STDERR "<<\n"; + for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines + print STDERR "_verbatim_format $i: $p->[$i]"; + } + print STDERR ">>\n"; + } + + for(my $i = $#$p; $i > 2; $i--) { + # work backwards over the lines, except the first (#2) + + #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s + # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s; + # look at a formatty line preceding a nonformatty one + DEBUG > 5 and print STDERR "Scrutinizing line $i: $$p[$i]\n"; + if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { + DEBUG > 5 and print STDERR " It's a formatty line. ", + "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; + + if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { + DEBUG > 5 and print STDERR " Previous line is formatty! Skipping this one.\n"; + next; + } else { + DEBUG > 5 and print STDERR " Previous line is non-formatty! Yay!\n"; + } + } else { + DEBUG > 5 and print STDERR " It's not a formatty line. Ignoring\n"; + next; + } + + # A formatty line has to have #: in the first two columns, and uses + # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic. + # Example: + # What do you want? i like pie. [or whatever] + # #:^^^^^^^^^^^^^^^^^ ///////////// + + + DEBUG > 4 and print STDERR "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; + + $formatting = ' ' . $1; + $formatting =~ s/\s+$//s; # nix trailing whitespace + unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op + splice @$p,$i,1; # remove this line + $i--; # don't consider next line + next; + } + + if( length($formatting) >= length($p->[$i-1]) ) { + $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' '; + } else { + $formatting .= ' ' x (length($p->[$i-1]) - length($formatting)); + } + # Make $formatting and the previous line be exactly the same length, + # with $formatting having a " " as the last character. + + DEBUG > 4 and print STDERR "Formatting <$formatting> on <", $p->[$i-1], ">\n"; + + + my @new_line; + while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) { + #print STDERR "Format matches $1\n"; + + if($2) { + #print STDERR "SKIPPING <$2>\n"; + push @new_line, + substr($p->[$i-1], pos($formatting)-length($1), length($1)); + } else { + #print STDERR "SNARING $+\n"; + push @new_line, [ + ( + $3 ? 'VerbatimB' : + $4 ? 'VerbatimI' : + $5 ? 'VerbatimBI' : die("Should never get called") + ), {}, + substr($p->[$i-1], pos($formatting)-length($1), length($1)) + ]; + #print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; + } + } + my @nixed = + splice @$p, $i-1, 2, @new_line; # replace myself and the next line + DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n"; + + DEBUG > 6 and print STDERR "New version of the above line is these tokens (", + scalar(@new_line), "):", + map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; + $i--; # So the next line we scrutinize is the line before the one + # that we just went and formatted + } + + $p->[0] = 'VerbatimFormatted'; + + # Collapse adjacent text nodes, just for kicks. + for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last + if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) { + DEBUG > 5 and print STDERR "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n"; + $p->[$i] .= splice @$p, $i+1, 1; # merge + --$i; # and back up + } + } + + # Now look for the last text token, and remove the terminal newline + for( my $i = $#$p; $i >= 2; $i-- ) { + # work backwards over the tokens, even the first + if( !ref($p->[$i]) ) { + if($p->[$i] =~ s/\n$//s) { + DEBUG > 5 and print STDERR "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n"; + } else { + DEBUG > 5 and print STDERR + "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n"; + } + last; # we only want the next one + } + } + + return; +} + + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + + +sub _treelet_from_formatting_codes { + # Given a paragraph, returns a treelet. Full of scary tokenizing code. + # Like [ '~Top', {'start_line' => $start_line}, + # "I like ", + # [ 'B', {}, "pie" ], + # "!" + # ] + + my($self, $para, $start_line, $preserve_space) = @_; + + my $treelet = ['~Top', {'start_line' => $start_line},]; + + unless ($preserve_space || $self->{'preserve_whitespace'}) { + $para =~ s/\s+/ /g; # collapse and trim all whitespace first. + $para =~ s/ $//; + $para =~ s/^ //; + } + + # Only apparent problem the above code is that N<< >> turns into + # N<< >>. But then, word wrapping does that too! So don't do that! + + my @stack; + my @lineage = ($treelet); + my $raw = ''; # raw content of L<> fcode before splitting/processing + # XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed + # into just 1 ' '. Is this the regex's doing or 'raw's? + my $inL = 0; + + DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n"; + + # Here begins our frightening tokenizer RE. The following regex matches + # text in four main parts: + # + # * Start-codes. The first alternative matches C< or C<<, the latter + # followed by some whitespace. $1 will hold the entire start code + # (including any space following a multiple-angle-bracket delimiter), + # and $2 will hold only the additional brackets past the first in a + # multiple-bracket delimiter. length($2) + 1 will be the number of + # closing brackets we have to find. + # + # * Closing brackets. Match some amount of whitespace followed by + # multiple close brackets. The logic to see if this closes anything + # is down below. Note that in order to parse C<< >> correctly, we + # have to use look-behind (?<=\s\s), since the match of the starting + # code will have consumed the whitespace. + # + # * A single closing bracket, to close a simple code like C<>. + # + # * Something that isn't a start or end code. We have to be careful + # about accepting whitespace, since perlpodspec says that any whitespace + # before a multiple-bracket closing delimiter should be ignored. + # + while($para =~ + m/\G + (?: + # Match starting codes, including the whitespace following a + # multiple-delimiter start code. $1 gets the whole start code and + # $2 gets all but one of the {2,}) + | + (\s?>) # $5: simple end-codes + | + ( # $6: stuff containing no start-codes or end-codes + (?: + [^A-Z\s>] + | + (?: + [A-Z](?!<) + ) + | + # whitespace is ok, but we don't want to eat the whitespace before + # a multiple-bracket end code. + # NOTE: we may still have problems with e.g. S<< >> + (?: + \s(?!\s*>{2,}) + ) + )+ + ) + ) + /xgo + ) { + DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n"; + if(defined $1) { + if(defined $2) { + DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n"; + push @stack, length($2) + 1; + # length of the necessary complex end-code string + } else { + DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n"; + push @stack, 0; # signal that we're looking for simple + } + push @lineage, [ substr($1,0,1), {}, ]; # new node object + push @{ $lineage[-2] }, $lineage[-1]; + if ('L' eq substr($1,0,1)) { + $raw = $inL ? $raw.$1 : ''; # reset raw content accumulator + $inL = 1; + } else { + $raw .= $1 if $inL; + } + + } elsif(defined $4) { + DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n"; + # This is where it gets messy... + if(! @stack) { + # We saw " >>>>" but needed nothing. This is ALL just stuff then. + DEBUG > 4 and print STDERR " But it's really just stuff.\n"; + push @{ $lineage[-1] }, $3, $4; + next; + } elsif(!$stack[-1]) { + # We saw " >>>>" but needed only ">". Back pos up. + DEBUG > 4 and print STDERR " And that's more than we needed to close simple.\n"; + push @{ $lineage[-1] }, $3; # That was a for-real space, too. + pos($para) = pos($para) - length($4) + 1; + } elsif($stack[-1] == length($4)) { + # We found " >>>>", and it was exactly what we needed. Commonest case. + DEBUG > 4 and print STDERR " And that's exactly what we needed to close complex.\n"; + } elsif($stack[-1] < length($4)) { + # We saw " >>>>" but needed only " >>". Back pos up. + DEBUG > 4 and print STDERR " And that's more than we needed to close complex.\n"; + pos($para) = pos($para) - length($4) + $stack[-1]; + } else { + # We saw " >>>>" but needed " >>>>>>". So this is all just stuff! + DEBUG > 4 and print STDERR " But it's really just stuff, because we needed more.\n"; + push @{ $lineage[-1] }, $3, $4; + next; + } + #print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; + + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; + # Keep the element from being childless + + pop @stack; + pop @lineage; + + unless (@stack) { # not in an L if there are no open fcodes + $inL = 0; + if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') { + $lineage[-1][-1][1]{'raw'} = $raw + } + } + $raw .= $3.$4 if $inL; + + } elsif(defined $5) { + DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n"; + + if(@stack and ! $stack[-1]) { + # We're indeed expecting a simple end-code + DEBUG > 4 and print STDERR " It's indeed an end-code.\n"; + + if(length($5) == 2) { # There was a space there: " >" + push @{ $lineage[-1] }, ' '; + } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element + push @{ $lineage[-1] }, ''; # keep it from being really childless + } + + pop @stack; + pop @lineage; + } else { + DEBUG > 4 and print STDERR " It's just stuff.\n"; + push @{ $lineage[-1] }, $5; + } + + unless (@stack) { # not in an L if there are no open fcodes + $inL = 0; + if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') { + $lineage[-1][-1][1]{'raw'} = $raw + } + } + $raw .= $5 if $inL; + + } elsif(defined $6) { + DEBUG > 3 and print STDERR "Found stuff \"$6\"\n"; + push @{ $lineage[-1] }, $6; + $raw .= $6 if $inL; + # XXX does not capture multiplace whitespaces -- 'raw' ends up with + # at most 1 leading/trailing whitespace, why not all of it? + + } else { + # should never ever ever ever happen + DEBUG and print STDERR "AYYAYAAAAA at line ", __LINE__, "\n"; + die "SPORK 512512!"; + } + } + + if(@stack) { # Uhoh, some sequences weren't closed. + my $x= "..."; + while(@stack) { + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; + # Hmmmmm! + + my $code = (pop @lineage)->[0]; + my $ender_length = pop @stack; + if($ender_length) { + --$ender_length; + $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length); + } else { + $x = $code . "<$x>"; + } + } + DEBUG > 1 and print STDERR "Unterminated $x sequence\n"; + $self->whine($start_line, + "Unterminated $x sequence", + ); + } + + return $treelet; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol) + return stringify_lol($_[1]); +} + +sub stringify_lol { # function: stringify_lol($lol) + my $string_form = ''; + _stringify_lol( $_[0] => \$string_form ); + return $string_form; +} + +sub _stringify_lol { # the real recursor + my($lol, $to) = @_; + for(my $i = 2; $i < @$lol; ++$i) { + if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) { + _stringify_lol( $lol->[$i], $to); # recurse! + } else { + $$to .= $lol->[$i]; + } + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _dump_curr_open { # return a string representation of the stack + my $curr_open = $_[0]{'curr_open'}; + + return '[empty]' unless @$curr_open; + return join '; ', + map {; + ($_->[0] eq '=for') + ? ( ($_->[1]{'~really'} || '=over') + . ' ' . $_->[1]{'target'}) + : $_->[0] + } + @$curr_open + ; +} + +########################################################################### +my %pretty_form = ( + "\a" => '\a', # ding! + "\b" => '\b', # BS + "\e" => '\e', # ESC + "\f" => '\f', # FF + "\t" => '\t', # tab + "\cm" => '\cm', + "\cj" => '\cj', + "\n" => '\n', # probably overrides one of either \cm or \cj + '"' => '\"', + '\\' => '\\\\', + '$' => '\\$', + '@' => '\\@', + '%' => '\\%', + '#' => '\\#', +); + +sub pretty { # adopted from Class::Classless + # Not the most brilliant routine, but passable. + # Don't give it a cyclic data structure! + my @stuff = @_; # copy + my $x; + my $out = + # join ",\n" . + join ", ", + map {; + if(!defined($_)) { + "undef"; + } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') { + $x = "[ " . pretty(@$_) . " ]" ; + $x; + } elsif(ref($_) eq 'SCALAR') { + $x = "\\" . pretty($$_) ; + $x; + } elsif(ref($_) eq 'HASH') { + my $hr = $_; + $x = "{" . join(", ", + map(pretty($_) . '=>' . pretty($hr->{$_}), + sort keys %$hr ) ) . "}" ; + $x; + } elsif(!length($_)) { q{''} # empty string + } elsif( + $_ eq '0' # very common case + or( + m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s + and $_ ne '-0' # the strange case that RE lets thru + ) + ) { $_; + } else { + # Yes, explicitly name every character desired. There are shorcuts one + # could make, but I (Karl Williamson) was afraid that some Perl + # releases would have bugs in some of them. For example [A-Z] works + # even on EBCDIC platforms to match exactly the 26 uppercase English + # letters, but I don't know if it has always worked without bugs. It + # seemed safest just to list the characters. + # s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> + s<([^ !#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])> + <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; + #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; + qq{"$_"}; + } + } @stuff; + # $out =~ s/\n */ /g if length($out) < 75; + return $out; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +# A rather unsubtle method of blowing away all the state information +# from a parser object so it can be reused. Provided as a utility for +# backward compatibility in Pod::Man, etc. but not recommended for +# general use. + +sub reinit { + my $self = shift; + foreach (qw(source_dead source_filename doc_has_started +start_of_pod_block content_seen last_was_blank paras curr_open +line_count pod_para_count in_pod ~tried_gen_errata all_errata errata errors_seen +Title)) { + + delete $self->{$_}; + } +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +require 5; +package Pod::Simple::DumpAsText; +$VERSION = '3.35'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; + +use Carp (); + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->accept_codes('VerbatimFormatted'); + $new->keep_encoding_directive(1); + return $new; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +sub _handle_element_start { + # ($self, $element_name, $attr_hash_r) + my $fh = $_[0]{'output_fh'}; + my($key, $value); + DEBUG and print STDERR "++ $_[1]\n"; + + print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n"; + $_[0]{'indent'}++; + while(($key,$value) = each %{$_[2]}) { + unless($key =~ m/^~/s) { + next if $key eq 'start_line' and $_[0]{'hide_line_numbers'}; + _perly_escape($key); + _perly_escape($value); + printf $fh qq{%s \\ "%s" => "%s"\n}, + ' ' x ($_[0]{'indent'} || 0), $key, $value; + } + } + return; +} + +sub _handle_text { + DEBUG and print STDERR "== \"$_[1]\"\n"; + + if(length $_[1]) { + my $indent = ' ' x $_[0]{'indent'}; + my $text = $_[1]; + _perly_escape($text); + $text =~ # A not-totally-brilliant wrapping algorithm: + s/( + [^\n]{55} # Snare some characters from a line + [^\n\ ]{0,50} # and finish any current word + ) + \ {1,10}(?!\n) # capture some spaces not at line-end + /$1"\n$indent . "/gx # => line-break here + ; + + print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n"; + } + return; +} + +sub _handle_element_end { + DEBUG and print STDERR "-- $_[1]\n"; + print {$_[0]{'output_fh'}} + ' ' x --$_[0]{'indent'}, "--", $_[1], "\n"; + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + +sub _perly_escape { + foreach my $x (@_) { + $x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg; + # Escape things very cautiously: + $x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg; + } + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + + +require 5; +package Pod::Simple::Methody; +use strict; +use Pod::Simple (); +use vars qw(@ISA $VERSION); +$VERSION = '3.35'; +@ISA = ('Pod::Simple'); + +# Yes, we could use named variables, but I want this to be impose +# as little an additional performance hit as possible. + +sub _handle_element_start { + $_[1] =~ tr/-:./__/; + ( $_[0]->can( 'start_' . $_[1] ) + || return + )->( + $_[0], $_[2] + ); +} + +sub _handle_text { + ( $_[0]->can( 'handle_text' ) + || return + )->( + @_ + ); +} + +sub _handle_element_end { + $_[1] =~ tr/-:./__/; + ( $_[0]->can( 'end_' . $_[1] ) + || return + )->( + $_[0], $_[2] + ); +} + +1; + + +__END__ + + +package Pod::Simple::XHTML; +use strict; +use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); +$VERSION = '3.35'; +use Pod::Simple::Methody (); +@ISA = ('Pod::Simple::Methody'); + +BEGIN { + $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1"; +} + +my %entities = ( + q{>} => 'gt', + q{<} => 'lt', + q{'} => '#39', + q{"} => 'quot', + q{&} => 'amp', +); + +sub encode_entities { + my $self = shift; + my $ents = $self->html_encode_chars; + return HTML::Entities::encode_entities( $_[0], $ents ) if $HAS_HTML_ENTITIES; + if (defined $ents) { + $ents =~ s,(?_accessorize( + 'perldoc_url_prefix', + 'perldoc_url_postfix', + 'man_url_prefix', + 'man_url_postfix', + 'title_prefix', 'title_postfix', + 'html_css', + 'html_javascript', + 'html_doctype', + 'html_charset', + 'html_encode_chars', + 'html_h_level', + 'title', # Used internally for the title extracted from the content + 'default_title', + 'force_title', + 'html_header', + 'html_footer', + 'index', + 'anchor_items', + 'backlink', + 'batch_mode', # whether we're in batch mode + 'batch_mode_current_level', + # When in batch mode, how deep the current module is: 1 for "LWP", + # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc +); + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->perldoc_url_prefix('http://search.cpan.org/perldoc?'); + $new->man_url_prefix('http://man.he.net/man'); + $new->html_charset('ISO-8859-1'); + $new->nix_X_codes(1); + $new->{'scratch'} = ''; + $new->{'to_index'} = []; + $new->{'output'} = []; + $new->{'saved'} = []; + $new->{'ids'} = { '_podtop_' => 1 }; # used in + $new->{'in_li'} = []; + + $new->{'__region_targets'} = []; + $new->{'__literal_targets'} = {}; + $new->accept_targets_as_html( 'html', 'HTML' ); + + return $new; +} + +sub html_header_tags { + my $self = shift; + return $self->{html_header_tags} = shift if @_; + return $self->{html_header_tags} + ||= ''; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +sub __in_literal_xhtml_region { + return unless @{ $_[0]{__region_targets} }; + my $target = $_[0]{__region_targets}[-1]; + return $_[0]{__literal_targets}{ $target }; +} + +sub accept_targets_as_html { + my ($self, @targets) = @_; + $self->accept_targets(@targets); + $self->{__literal_targets}{$_} = 1 for @targets; +} + +sub handle_text { + # escape special characters in HTML (<, >, &, etc) + my $text = $_[0]->__in_literal_xhtml_region + ? $_[1] + : $_[0]->encode_entities( $_[1] ); + + if ($_[0]{'in_code'} && @{$_[0]{'in_code'}}) { + # Intentionally use the raw text in $_[1], even if we're not in a + # literal xhtml region, since handle_code calls encode_entities. + $_[0]->handle_code( $_[1], $_[0]{'in_code'}[-1] ); + } else { + if ($_[0]->{in_for}) { + my $newlines = $_[0]->__in_literal_xhtml_region ? "\n\n" : ''; + if ($_[0]->{started_for}) { + if ($text =~ /\S/) { + delete $_[0]->{started_for}; + $_[0]{'scratch'} .= $text . $newlines; + } + # Otherwise, append nothing until we have something to append. + } else { + # The parser sometimes preserves newlines and sometimes doesn't! + $text =~ s/\n\z//; + $_[0]{'scratch'} .= $text . $newlines; + } + } else { + # Just plain text. + $_[0]{'scratch'} .= $text; + } + } + + $_[0]{htext} .= $text if $_[0]{'in_head'}; +} + +sub start_code { + $_[0]{'scratch'} .= ''; +} + +sub end_code { + $_[0]{'scratch'} .= ''; +} + +sub handle_code { + $_[0]{'scratch'} .= $_[0]->encode_entities( $_[1] ); +} + +sub start_Para { + $_[0]{'scratch'} .= '

'; +} + +sub start_Verbatim { + $_[0]{'scratch'} = '

';
+    push(@{$_[0]{'in_code'}}, 'Verbatim');
+    $_[0]->start_code($_[0]{'in_code'}[-1]);
+}
+
+sub start_head1 {  $_[0]{'in_head'} = 1; $_[0]{htext} = ''; }
+sub start_head2 {  $_[0]{'in_head'} = 2; $_[0]{htext} = ''; }
+sub start_head3 {  $_[0]{'in_head'} = 3; $_[0]{htext} = ''; }
+sub start_head4 {  $_[0]{'in_head'} = 4; $_[0]{htext} = ''; }
+
+sub start_item_number {
+    $_[0]{'scratch'} = "\n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
+    $_[0]{'scratch'} .= '
  • ';
+    push @{$_[0]{'in_li'}}, 1;
+}
+
+sub start_item_bullet {
+    $_[0]{'scratch'} = "
    • \n" if ($_[0]{'in_li'}->[-1] && pop @{$_[0]{'in_li'}});
+    $_[0]{'scratch'} .= '
  • ';
+    push @{$_[0]{'in_li'}}, 1;
+}
+
+sub start_item_text   {
+    # see end_item_text
+}
+
+sub start_over_bullet { $_[0]{'scratch'} = '
      '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
+sub start_over_block  { $_[0]{'scratch'} = '
        '; $_[0]->emit }
+sub start_over_number { $_[0]{'scratch'} = '
          '; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
+sub start_over_text   {
+    $_[0]{'scratch'} = '
          ';
+    $_[0]{'dl_level'}++;
+    $_[0]{'in_dd'} ||= [];
+    $_[0]->emit
+}
+
+sub end_over_block  { $_[0]{'scratch'} .= '
      '; $_[0]->emit }
+
+sub end_over_number   {
+    $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
+    $_[0]{'scratch'} .= '';
+    pop @{$_[0]{'in_li'}};
+    $_[0]->emit;
+}
+
+sub end_over_bullet   {
+    $_[0]{'scratch'} = "\n" if ( pop @{$_[0]{'in_li'}} );
+    $_[0]{'scratch'} .= '
    ';
+    pop @{$_[0]{'in_li'}};
+    $_[0]->emit;
+}
+
+sub end_over_text   {
+    if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+        $_[0]{'scratch'} = "\n";
+        $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+    }
+    $_[0]{'scratch'} .= '';
+    $_[0]{'dl_level'}--;
+    $_[0]->emit;
+}
+
+# . . . . . Now the actual formatters:
+
+sub end_Para     { $_[0]{'scratch'} .= '
    '; $_[0]->emit }
+sub end_Verbatim {
+    $_[0]->end_code(pop(@{$_[0]->{'in_code'}}));
+    $_[0]{'scratch'} .= '
    • '; + $_[0]->emit; +} + +sub _end_head { + my $h = delete $_[0]{in_head}; + + my $add = $_[0]->html_h_level; + $add = 1 unless defined $add; + $h += $add - 1; + + my $id = $_[0]->idify($_[0]{htext}); + my $text = $_[0]{scratch}; + $_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0) + # backlinks enabled && =head1 + ? qq{$text} + : qq{$text}; + $_[0]->emit; + push @{ $_[0]{'to_index'} }, [$h, $id, delete $_[0]{'htext'}]; +} + +sub end_head1 { shift->_end_head(@_); } +sub end_head2 { shift->_end_head(@_); } +sub end_head3 { shift->_end_head(@_); } +sub end_head4 { shift->_end_head(@_); } + +sub end_item_bullet { $_[0]{'scratch'} .= '

    '; $_[0]->emit } +sub end_item_number { $_[0]{'scratch'} .= '

    '; $_[0]->emit } + +sub end_item_text { + # idify and anchor =item content if wanted + my $dt_id = $_[0]{'anchor_items'} + ? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"' + : ''; + + # reset scratch + my $text = $_[0]{scratch}; + $_[0]{'scratch'} = ''; + + if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) { + $_[0]{'scratch'} = "\n"; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0; + } + + $_[0]{'scratch'} .= qq{$text\n
    }; + $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1; + $_[0]->emit; +} + +# This handles =begin and =for blocks of all kinds. +sub start_for { + my ($self, $flags) = @_; + + push @{ $self->{__region_targets} }, $flags->{target_matching}; + $self->{started_for} = 1; + $self->{in_for} = 1; + + unless ($self->__in_literal_xhtml_region) { + $self->{scratch} .= '{scratch} .= qq( class="$flags->{target}") if $flags->{target}; + $self->{scratch} .= ">\n\n"; + } +} + +sub end_for { + my ($self) = @_; + delete $self->{started_for}; + delete $self->{in_for}; + + if ($self->__in_literal_xhtml_region) { + # Remove trailine newlines. + $self->{'scratch'} =~ s/\s+\z//s; + } else { + $self->{'scratch'} .= ''; + } + + pop @{ $self->{__region_targets} }; + $self->emit; +} + +sub start_Document { + my ($self) = @_; + if (defined $self->html_header) { + $self->{'scratch'} .= $self->html_header; + $self->emit unless $self->html_header eq ""; + } else { + my ($doctype, $title, $metatags, $bodyid); + $doctype = $self->html_doctype || ''; + $title = $self->force_title || $self->title || $self->default_title || ''; + $metatags = $self->html_header_tags || ''; + if (my $css = $self->html_css) { + if ($css !~ /encode_entities($css) . '" type="text/css" />'; + } else { + $metatags .= $css; + } + } + if ($self->html_javascript) { + $metatags .= qq{\n'; + } + $bodyid = $self->backlink ? ' id="_podtop_"' : ''; + $self->{'scratch'} .= <<"HTML"; +$doctype + + +$title +$metatags + + +HTML + $self->emit; + } +} + +sub end_Document { + my ($self) = @_; + my $to_index = $self->{'to_index'}; + if ($self->index && @{ $to_index } ) { + my @out; + my $level = 0; + my $indent = -1; + my $space = ''; + my $id = ' id="index"'; + + for my $h (@{ $to_index }, [0]) { + my $target_level = $h->[0]; + # Get to target_level by opening or closing ULs + if ($level == $target_level) { + $out[-1] .= ''; + } elsif ($level > $target_level) { + $out[-1] .= '' if $out[-1] =~ /^\s+
  • /; + while ($level > $target_level) { + --$level; + push @out, (' ' x --$indent) . '
    • ' if @out && $out[-1] =~ m{^\s+<\/ul}; + push @out, (' ' x --$indent) . ''; + } + push @out, (' ' x --$indent) . '' if $level; + } else { + while ($level < $target_level) { + ++$level; + push @out, (' ' x ++$indent) . '
  • ' if @out && $out[-1]=~ /^\s*
      "; + $id = ''; + } + ++$indent; + } + + next unless $level; + $space = ' ' x $indent; + push @out, sprintf '%s
    • %s', + $space, $h->[1], $h->[2]; + } + # Splice the index in between the HTML headers and the first element. + my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1; + splice @{ $self->{'output'} }, $offset, 0, join "\n", @out; + } + + if (defined $self->html_footer) { + $self->{'scratch'} .= $self->html_footer; + $self->emit unless $self->html_footer eq ""; + } else { + $self->{'scratch'} .= "\n"; + $self->emit; + } + + if ($self->index) { + print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n"; + @{$self->{'output'}} = (); + } + +} + +# Handling code tags +sub start_B { $_[0]{'scratch'} .= '' } +sub end_B { $_[0]{'scratch'} .= '' } + +sub start_C { push(@{$_[0]{'in_code'}}, 'C'); $_[0]->start_code($_[0]{'in_code'}[-1]); } +sub end_C { $_[0]->end_code(pop(@{$_[0]{'in_code'}})); } + +sub start_F { $_[0]{'scratch'} .= '' } +sub end_F { $_[0]{'scratch'} .= '' } + +sub start_I { $_[0]{'scratch'} .= '' } +sub end_I { $_[0]{'scratch'} .= '' } + +sub start_L { + my ($self, $flags) = @_; + my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'}; + my $url = $self->encode_entities( + $type eq 'url' ? $to + : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section) + : $type eq 'man' ? $self->resolve_man_page_link($to, $section) + : undef + ); + + # If it's an unknown type, use an attribute-less like HTML.pm. + $self->{'scratch'} .= '' : '>'); +} + +sub end_L { $_[0]{'scratch'} .= '' } + +sub start_S { $_[0]{'scratch'} .= '' } +sub end_S { $_[0]{'scratch'} .= '' } + +sub emit { + my($self) = @_; + if ($self->index) { + push @{ $self->{'output'} }, $self->{'scratch'}; + } else { + print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n"; + } + $self->{'scratch'} = ''; + return; +} + + +sub resolve_pod_page_link { + my ($self, $to, $section) = @_; + return undef unless defined $to || defined $section; + if (defined $section) { + $section = '#' . $self->idify($self->encode_entities($section), 1); + return $section unless defined $to; + } else { + $section = '' + } + + return ($self->perldoc_url_prefix || '') + . $self->encode_entities($to) . $section + . ($self->perldoc_url_postfix || ''); +} + + +sub resolve_man_page_link { + my ($self, $to, $section) = @_; + return undef unless defined $to; + my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/; + return undef unless $page; + return ($self->man_url_prefix || '') + . ($part || 1) . "/" . $self->encode_entities($page) + . ($self->man_url_postfix || ''); + +} + + +sub idify { + my ($self, $t, $not_unique) = @_; + for ($t) { + s/<[^>]+>//g; # Strip HTML. + s/&[^;]+;//g; # Strip entities. + s/^\s+//; s/\s+$//; # Strip white space. + s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars. + s/^[^a-zA-Z]+//; # First char must be a letter. + s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid. + s/[-:.]+$//; # Strip trailing punctuation. + } + return $t if $not_unique; + my $i = ''; + $i++ while $self->{ids}{"$t$i"}++; + return "$t$i"; +} + + +sub batch_mode_page_object_init { + my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; + $self->batch_mode(1); + $self->batch_mode_current_level($depth); + return $self; +} + +sub html_header_after_title { +} + + +1; + +__END__ + + +require 5; +package Pod::Simple::HTMLBatch; +use strict; +use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION + $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA +); +$VERSION = '3.35'; +@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! + +# TODO: nocontents stylesheets. Strike some of the color variations? + +use Pod::Simple::HTML (); +BEGIN {*esc = \&Pod::Simple::HTML::esc } +use File::Spec (); + +use Pod::Simple::Search; +$SEARCH_CLASS ||= 'Pod::Simple::Search'; + +BEGIN { + if(defined &DEBUG) { } # no-op + elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } + else { *DEBUG = sub () {0}; } +} + +$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; +# flag to occasionally sleep for $SLEEPY - 1 seconds. + +$HTML_RENDER_CLASS ||= "Pod::Simple::HTML"; + +# +# Methods beginning with "_" are particularly internal and possibly ugly. +# + +Pod::Simple::_accessorize( __PACKAGE__, + 'verbose', # how verbose to be during batch conversion + 'html_render_class', # what class to use to render + 'search_class', # what to use to search for POD documents + 'contents_file', # If set, should be the name of a file (in current directory) + # to write the list of all modules to + 'index', # will set $htmlpage->index(...) to this (true or false) + 'progress', # progress object + 'contents_page_start', 'contents_page_end', + + 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad', + 'no_contents_links', # set to true to suppress automatic adding of << links. + '_contents', +); + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# Just so we can run from the command line more easily +sub go { + @ARGV == 2 or die sprintf( + "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n", + __PACKAGE__, __PACKAGE__, + ); + + if(defined($ARGV[1]) and length($ARGV[1])) { + my $d = $ARGV[1]; + -e $d or die "I see no output directory named \"$d\"\nAborting"; + -d $d or die "But \"$d\" isn't a directory!\nAborting"; + -w $d or die "Directory \"$d\" isn't writeable!\nAborting"; + } + + __PACKAGE__->batch_convert(@ARGV); +} +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + +sub new { + my $new = bless {}, ref($_[0]) || $_[0]; + $new->html_render_class($HTML_RENDER_CLASS); + $new->search_class($SEARCH_CLASS); + $new->verbose(1 + DEBUG); + $new->_contents([]); + + $new->index(1); + + $new-> _css_wad([]); $new->css_flurry(1); + $new->_javascript_wad([]); $new->javascript_flurry(1); + + $new->contents_file( + 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION) + ); + + $new->contents_page_start( join "\n", grep $_, + $Pod::Simple::HTML::Doctype_decl, + "", + "Perl Documentation", + $Pod::Simple::HTML::Content_decl, + "", + "\n\n

      Perl Documentation

      \n" + ); # override if you need a different title + + + $new->contents_page_end( sprintf( + "\n\n

      Generated by %s v%s under Perl v%s\n
      At %s GMT, which is %s local time.

      \n\n\n", + esc( + ref($new), + eval {$new->VERSION} || $VERSION, + $], scalar(gmtime), scalar(localtime), + ))); + + return $new; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub muse { + my $self = shift; + if($self->verbose) { + print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n"; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub batch_convert { + my($self, $dirs, $outdir) = @_; + $self ||= __PACKAGE__; # tolerate being called as an optionless function + $self = $self->new unless ref $self; # tolerate being used as a class method + + if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) { + $dirs = ''; + } elsif(ref $dirs) { + # OK, it's an explicit set of dirs to scan, specified as an arrayref. + } else { + # OK, it's an explicit set of dirs to scan, specified as a + # string like "/thing:/also:/whatever/perl" (":"-delim, as usual) + # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!) + require Config; + my $ps = quotemeta( $Config::Config{'path_sep'} || ":" ); + $dirs = [ grep length($_), split qr/$ps/, $dirs ]; + } + + $outdir = $self->filespecsys->curdir + unless defined $outdir and length $outdir; + + $self->_batch_convert_main($dirs, $outdir); +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _batch_convert_main { + my($self, $dirs, $outdir) = @_; + # $dirs is either false, or an arrayref. + # $outdir is a pathspec. + + $self->{'_batch_start_time'} ||= time(); + + $self->muse( "= ", scalar(localtime) ); + $self->muse( "Starting batch conversion to \"$outdir\"" ); + + my $progress = $self->progress; + if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) { + require Pod::Simple::Progress; + $progress = Pod::Simple::Progress->new( + ($self->verbose < 2) ? () # Default omission-delay + : ($self->verbose == 2) ? 1 # Reduce the omission-delay + : 0 # Eliminate the omission-delay + ); + $self->progress($progress); + } + + if($dirs) { + $self->muse(scalar(@$dirs), " dirs to scan: @$dirs"); + } else { + $self->muse("Scanning \@INC. This could take a minute or two."); + } + my $mod2path = $self->find_all_pods($dirs ? $dirs : ()); + $self->muse("Done scanning."); + + my $total = keys %$mod2path; + unless($total) { + $self->muse("No pod found. Aborting batch conversion.\n"); + return $self; + } + + $progress and $progress->goal($total); + $self->muse("Now converting pod files to HTML.", + ($total > 25) ? " This will take a while more." : () + ); + + $self->_spray_css( $outdir ); + $self->_spray_javascript( $outdir ); + + $self->_do_all_batch_conversions($mod2path, $outdir); + + $progress and $progress->done(sprintf ( + "Done converting %d files.", $self->{"__batch_conv_page_count"} + )); + return $self->_batch_convert_finish($outdir); + return $self; +} + + +sub _do_all_batch_conversions { + my($self, $mod2path, $outdir) = @_; + $self->{"__batch_conv_page_count"} = 0; + + foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) { + $self->_do_one_batch_conversion($module, $mod2path, $outdir); + sleep($SLEEPY - 1) if $SLEEPY; + } + + return; +} + +sub _batch_convert_finish { + my($self, $outdir) = @_; + $self->write_contents_file($outdir); + $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done."); + $self->muse( "= ", scalar(localtime) ); + $self->progress and $self->progress->done("All done!"); + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _do_one_batch_conversion { + my($self, $module, $mod2path, $outdir, $outfile) = @_; + + my $retval; + my $total = scalar keys %$mod2path; + my $infile = $mod2path->{$module}; + my @namelets = grep m/\S/, split "::", $module; + # this can stick around in the contents LoL + my $depth = scalar @namelets; + die "Contentless thingie?! $module $infile" unless @namelets; #sanity + + $outfile ||= do { + my @n = @namelets; + $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION; + $self->filespecsys->catfile( $outdir, @n ); + }; + + my $progress = $self->progress; + + my $page = $self->html_render_class->new; + if(DEBUG > 5) { + $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ", + ref($page), " render ($depth) $module => $outfile"); + } elsif(DEBUG > 2) { + $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile") + } + + # Give each class a chance to init the converter: + $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth) + if $page->can('batch_mode_page_object_init'); + # Init for the index (TOC), too. + $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth) + if $self->can('batch_mode_page_object_init'); + + # Now get busy... + $self->makepath($outdir => \@namelets); + + $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module"); + + if( $retval = $page->parse_from_file($infile, $outfile) ) { + ++ $self->{"__batch_conv_page_count"} ; + $self->note_for_contents_file( \@namelets, $infile, $outfile ); + } else { + $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false."); + } + + $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth) + if $page->can('batch_mode_page_object_kill'); + # The following isn't a typo. Note that it switches $self and $page. + $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth) + if $self->can('batch_mode_page_object_kill'); + + DEBUG > 4 and printf STDERR "%s %sb < $infile %s %sb\n", + $outfile, -s $outfile, $infile, -s $infile + ; + + undef($page); + return $retval; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' } + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub note_for_contents_file { + my($self, $namelets, $infile, $outfile) = @_; + + # I think the infile and outfile parts are never used. -- SMB + # But it's handy to have them around for debugging. + + if( $self->contents_file ) { + my $c = $self->_contents(); + push @$c, + [ join("::", @$namelets), $infile, $outfile, $namelets ] + # 0 1 2 3 + ; + DEBUG > 3 and print STDERR "Noting @$c[-1]\n"; + } + return; +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub write_contents_file { + my($self, $outdir) = @_; + my $outfile = $self->_contents_filespec($outdir) || return; + + $self->muse("Preparing list of modules for ToC"); + + my($toplevel, # maps toplevelbit => [all submodules] + $toplevel_form_freq, # ends up being 'foo' => 'Foo' + ) = $self->_prep_contents_breakdown; + + my $Contents = eval { $self->_wopen($outfile) }; + if( $Contents ) { + $self->muse( "Writing contents file $outfile" ); + } else { + warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all"; + return; + } + + $self->_write_contents_start( $Contents, $outfile, ); + $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq ); + $self->_write_contents_end( $Contents, $outfile, ); + return $outfile; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_start { + my($self, $Contents, $outfile) = @_; + my $starter = $self->contents_page_start || ''; + + { + my $css_wad = $self->_css_wad_to_markup(1); + if( $css_wad ) { + $starter =~ s{()}{\n$css_wad\n$1}i; # otherwise nevermind + } + + my $javascript_wad = $self->_javascript_wad_to_markup(1); + if( $javascript_wad ) { + $starter =~ s{()}{\n$javascript_wad\n$1}i; # otherwise nevermind + } + } + + unless(print $Contents $starter, "
      \n" ) { + warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Contents); + return 0; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_middle { + my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_; + + foreach my $t (sort keys %$toplevel2submodules) { + my @downlines = sort {$a->[-1] cmp $b->[-1]} + @{ $toplevel2submodules->{$t} }; + + printf $Contents qq[
      %s
      \n
      \n], + esc( $t, $toplevel_form_freq->{$t} ) + ; + + my($path, $name); + foreach my $e (@downlines) { + $name = $e->[0]; + $path = join( "/", '.', esc( @{$e->[3]} ) ) + . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION); + print $Contents qq{ }, esc($name), "  \n"; + } + print $Contents "
      \n\n"; + } + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _write_contents_end { + my($self, $Contents, $outfile) = @_; + unless( + print $Contents "
      \n", + $self->contents_page_end || '', + ) { + warn "Couldn't write to $outfile: $!"; + } + close($Contents) or warn "Couldn't close $outfile: $!"; + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _prep_contents_breakdown { + my($self) = @_; + my $contents = $self->_contents; + my %toplevel; # maps lctoplevelbit => [all submodules] + my %toplevel_form_freq; # ends up being 'foo' => 'Foo' + # (mapping anycase forms to most freq form) + + foreach my $entry (@$contents) { + my $toplevel = + $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs' + # group all the perlwhatever docs together + : $entry->[3][0] # normal case + ; + ++$toplevel_form_freq{ lc $toplevel }{ $toplevel }; + push @{ $toplevel{ lc $toplevel } }, $entry; + push @$entry, lc($entry->[0]); # add a sort-order key to the end + } + + foreach my $toplevel (sort keys %toplevel) { + my $fgroup = $toplevel_form_freq{$toplevel}; + $toplevel_form_freq{$toplevel} = + ( + sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b } + keys %$fgroup + # This hash is extremely unlikely to have more than 4 members, so this + # sort isn't so very wasteful + )[0]; + } + + return(\%toplevel, \%toplevel_form_freq) if wantarray; + return \%toplevel; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _contents_filespec { + my($self, $outdir) = @_; + my $outfile = $self->contents_file; + return unless $outfile; + return $self->filespecsys->catfile( $outdir, $outfile ); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub makepath { + my($self, $outdir, $namelets) = @_; + return unless @$namelets > 1; + for my $i (0 .. ($#$namelets - 1)) { + my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] ); + if(-e $dir) { + die "$dir exists but not as a directory!?" unless -d $dir; + next; + } + DEBUG > 3 and print STDERR " Making $dir\n"; + mkdir $dir, 0777 + or die "Can't mkdir $dir: $!\nAborting" + ; + } + return; +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub batch_mode_page_object_init { + my $self = shift; + my($page, $module, $infile, $outfile, $depth) = @_; + + # TODO: any further options to percolate onto this new object here? + + $page->default_title($module); + $page->index( $self->index ); + + $page->html_css( $self-> _css_wad_to_markup($depth) ); + $page->html_javascript( $self->_javascript_wad_to_markup($depth) ); + + $self->add_header_backlink($page, $module, $infile, $outfile, $depth); + $self->add_footer_backlink($page, $module, $infile, $outfile, $depth); + + + return $self; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub add_header_backlink { + my $self = shift; + return if $self->no_contents_links; + my($page, $module, $infile, $outfile, $depth) = @_; + $page->html_header_after_title( join '', + $page->html_header_after_title || '', + + qq[

      <<

      \n], + ) + if $self->contents_file + ; + return; +} + +sub add_footer_backlink { + my $self = shift; + return if $self->no_contents_links; + my($page, $module, $infile, $outfile, $depth) = @_; + $page->html_footer( join '', + qq[

      <<

      \n], + + $page->html_footer || '', + ) + if $self->contents_file + ; + return; +} + +sub url_up_to_contents { + my($self, $depth) = @_; + --$depth; + return join '/', ('..') x $depth, esc($self->contents_file); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub find_all_pods { + my($self, $dirs) = @_; + # You can override find_all_pods in a subclass if you want to + # do extra filtering or whatnot. But for the moment, we just + # pass to modnames2paths: + return $self->modnames2paths($dirs); +} + +#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- + +sub modnames2paths { # return a hashref mapping modulenames => paths + my($self, $dirs) = @_; + + my $m2p; + { + my $search = $self->search_class->new; + DEBUG and print STDERR "Searching via $search\n"; + $search->verbose(1) if DEBUG > 10; + $search->progress( $self->progress->copy->goal(0) ) if $self->progress; + $search->shadows(0); # don't bother noting shadowed files + $search->inc( $dirs ? 0 : 1 ); + $search->survey( $dirs ? @$dirs : () ); + $m2p = $search->name2path; + die "What, no name2path?!" unless $m2p; + } + + $self->muse("That's odd... no modules found!") unless keys %$m2p; + if( DEBUG > 4 ) { + print STDERR "Modules found (name => path):\n"; + foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) { + print STDERR " $m $$m2p{$m}\n"; + } + print STDERR "(total ", scalar(keys %$m2p), ")\n\n"; + } elsif( DEBUG ) { + print STDERR "Found ", scalar(keys %$m2p), " modules.\n"; + } + $self->muse( "Found ", scalar(keys %$m2p), " modules." ); + + # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref + return $m2p; +} + +#=========================================================================== + +sub _wopen { + # this is abstracted out so that the daemon class can override it + my($self, $outpath) = @_; + require Symbol; + my $out_fh = Symbol::gensym(); + DEBUG > 5 and print STDERR "Write-opening to $outpath\n"; + return $out_fh if open($out_fh, "> $outpath"); + require Carp; + Carp::croak("Can't write-open $outpath: $!"); +} + +#========================================================================== + +sub add_css { + my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_; + return unless $url; + unless($name) { + # cook up a reasonable name based on the URL + $name = $url; + if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) { + $name = $1; + $name =~ s/\.css//i; + } + } + $media ||= 'all'; + $content_type ||= 'text/css'; + + my $bunch = [$url, $name, $content_type, $media, $_code]; + if($is_default) { unshift @{ $self->_css_wad }, $bunch } + else { push @{ $self->_css_wad }, $bunch } + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _spray_css { + my($self, $outdir) = @_; + + return unless $self->css_flurry(); + $self->_gen_css_wad(); + + my $lol = $self->_css_wad; + foreach my $chunk (@$lol) { + my $url = $chunk->[0]; + my $outfile; + if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) { + $outfile = $self->filespecsys->catfile( $outdir, "$1" ); + DEBUG > 5 and print STDERR "Noting $$chunk[0] as a file I'll create.\n"; + } else { + DEBUG > 5 and print STDERR "OK, noting $$chunk[0] as an external CSS.\n"; + # Requires no further attention. + next; + } + + #$self->muse( "Writing autogenerated CSS file $outfile" ); + my $Cssout = $self->_wopen($outfile); + print $Cssout ${$chunk->[-1]} + or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Cssout); + DEBUG > 5 and print STDERR "Wrote $outfile\n"; + } + + return; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub _css_wad_to_markup { + my($self, $depth) = @_; + + my @css = @{ $self->_css_wad || return '' }; + return '' unless @css; + + my $rel = 'stylesheet'; + my $out = ''; + + --$depth; + my $uplink = $depth ? ('../' x $depth) : ''; + + foreach my $chunk (@css) { + next unless $chunk and @$chunk; + + my( $url1, $url2, $title, $type, $media) = ( + $self->_maybe_uplink( $chunk->[0], $uplink ), + esc(grep !ref($_), @$chunk) + ); + + $out .= qq{\n}; + + $rel = 'alternate stylesheet'; # alternates = all non-first iterations + } + return $out; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub _maybe_uplink { + # if the given URL looks relative, return the given uplink string -- + # otherwise return emptystring + my($self, $url, $uplink) = @_; + ($url =~ m{^\./} or $url !~ m{[/\:]} ) + ? $uplink + : '' + # qualify it, if/as needed +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +sub _gen_css_wad { + my $self = $_[0]; + my $css_template = $self->_css_template; + foreach my $variation ( + + # Commented out for sake of concision: + # + # 011n=black_with_red_on_white + # 001n=black_with_yellow_on_white + # 101n=black_with_green_on_white + # 110=white_with_yellow_on_black + # 010=white_with_green_on_black + # 011=white_with_blue_on_black + # 100=white_with_red_on_black + '110n=blkbluw', # black_with_blue_on_white + '010n=blkmagw', # black_with_magenta_on_white + '100n=blkcynw', # black_with_cyan_on_white + '101=whtprpk', # white_with_purple_on_black + '001=whtnavk', # white_with_navy_blue_on_black + '010a=grygrnk', # grey_with_green_on_black + '010b=whtgrng', # white_with_green_on_grey + '101an=blkgrng', # black_with_green_on_grey + '101bn=grygrnw', # grey_with_green_on_white + ) { + + my $outname = $variation; + my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3) + if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s; + @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op! + + my $this_css = + "/* This file is autogenerated. Do not edit. $variation */\n\n" + . $css_template; + + # Only look at three-digitty colors, for now at least. + if( $flipmode =~ m/n/ ) { + $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg; + $this_css =~ s/\bthin\b/medium/g; + } + $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b> + < join '', '#', ($1,$2,$3)[@swap] >eg if @swap; + + if( $flipmode =~ m/a/) + { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey + elsif($flipmode =~ m/b/) + { $this_css =~ s/#000\b/#666/gi } # white -> light grey + + my $name = $outname; + $name =~ tr/-_/ /; + $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); + } + + # Now a few indexless variations: + foreach my $variation ( + 'blkbluw', # black_with_blue_on_white + 'whtpurk', # white_with_purple_on_black + 'whtgrng', # white_with_green_on_grey + 'grygrnw', # grey_with_green_on_white + ) { + my $outname = $variation; + my $this_css = join "\n", + "/* This file is autogenerated. Do not edit. $outname */\n", + "\@import url(\"./_$variation.css\");", + ".indexgroup { display: none; }", + "\n", + ; + my $name = $outname; + $name =~ tr/-_/ /; + $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); + } + + return; +} + +sub _color_negate { + my $x = lc $_[0]; + $x =~ tr[0123456789abcdef] + [fedcba9876543210]; + return $x; +} + +#=========================================================================== + +sub add_javascript { + my($self, $url, $content_type, $_code) = @_; + return unless $url; + push @{ $self->_javascript_wad }, [ + $url, $content_type || 'text/javascript', $_code + ]; + return; +} + +sub _spray_javascript { + my($self, $outdir) = @_; + return unless $self->javascript_flurry(); + $self->_gen_javascript_wad(); + + my $lol = $self->_javascript_wad; + foreach my $script (@$lol) { + my $url = $script->[0]; + my $outfile; + + if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) { + $outfile = $self->filespecsys->catfile( $outdir, "$1" ); + DEBUG > 5 and print STDERR "Noting $$script[0] as a file I'll create.\n"; + } else { + DEBUG > 5 and print STDERR "OK, noting $$script[0] as an external JavaScript.\n"; + next; + } + + #$self->muse( "Writing JavaScript file $outfile" ); + my $Jsout = $self->_wopen($outfile); + + print $Jsout ${$script->[-1]} + or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all"; + close($Jsout); + DEBUG > 5 and print STDERR "Wrote $outfile\n"; + } + + return; +} + +sub _gen_javascript_wad { + my $self = $_[0]; + my $js_code = $self->_javascript || return; + $self->add_javascript( "_podly.js", 0, \$js_code); + return; +} + +sub _javascript_wad_to_markup { + my($self, $depth) = @_; + + my @scripts = @{ $self->_javascript_wad || return '' }; + return '' unless @scripts; + + my $out = ''; + + --$depth; + my $uplink = $depth ? ('../' x $depth) : ''; + + foreach my $s (@scripts) { + next unless $s and @$s; + + my( $url1, $url2, $type, $media) = ( + $self->_maybe_uplink( $s->[0], $uplink ), + esc(grep !ref($_), @$s) + ); + + $out .= qq{\n}; + } + return $out; +} + +#=========================================================================== + +sub _css_template { return $CSS } +sub _javascript { return $JAVASCRIPT } + +$CSS = <<'EOCSS'; +/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */ + +@media all { .hide { display: none; } } + +@media print { + .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none } + + * { + border-color: black !important; + color: black !important; + background-color: transparent !important; + background-image: none !important; + } + + dl.superindex > dd { + word-spacing: .6em; + } +} + +@media aural, braille, embossed { + div.indexgroup { display: none; } /* Too noisy, don't you think? */ + dl.superindex > dt:before { content: "Group "; } + dl.superindex > dt:after { content: " contains:"; } + .backlinktop a:before { content: "Back to contents"; } + .backlinkbottom a:before { content: "Back to contents"; } +} + +@media aural { + dl.superindex > dt { pause-before: 600ms; } +} + +@media screen, tty, tv, projection { + .noscreen { display: none; } + + a:link { color: #7070ff; text-decoration: underline; } + a:visited { color: #e030ff; text-decoration: underline; } + a:active { color: #800000; text-decoration: underline; } + body.contentspage a { text-decoration: none; } + a.u { color: #fff !important; text-decoration: none; } + + body.pod { + margin: 0 5px; + color: #fff; + background-color: #000; + } + + body.pod h1, body.pod h2, body.pod h3, body.pod h4 { + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + margin-top: 1.2em; + margin-bottom: .1em; + border-top: thin solid transparent; + /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */ + } + + body.pod h1 { border-top-color: #0a0; } + body.pod h2 { border-top-color: #080; } + body.pod h3 { border-top-color: #040; } + body.pod h4 { border-top-color: #010; } + + p.backlinktop + h1 { border-top: none; margin-top: 0em; } + p.backlinktop + h2 { border-top: none; margin-top: 0em; } + p.backlinktop + h3 { border-top: none; margin-top: 0em; } + p.backlinktop + h4 { border-top: none; margin-top: 0em; } + + body.pod dt { + font-size: 105%; /* just a wee bit more than normal */ + } + + .indexgroup { font-size: 80%; } + + .backlinktop, .backlinkbottom { + margin-left: -5px; + margin-right: -5px; + background-color: #040; + border-top: thin solid #050; + border-bottom: thin solid #050; + } + + .backlinktop a, .backlinkbottom a { + text-decoration: none; + color: #080; + background-color: #000; + border: thin solid #0d0; + } + .backlinkbottom { margin-bottom: 0; padding-bottom: 0; } + .backlinktop { margin-top: 0; padding-top: 0; } + + body.contentspage { + color: #fff; + background-color: #000; + } + + body.contentspage h1 { + color: #0d0; + margin-left: 1em; + margin-right: 1em; + text-indent: -.9em; + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + border-top: thin solid #fff; + border-bottom: thin solid #fff; + text-align: center; + } + + dl.superindex > dt { + font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif; + font-weight: normal; + font-size: 90%; + margin-top: .45em; + /* margin-bottom: -.15em; */ + } + dl.superindex > dd { + word-spacing: .6em; /* most important rule here! */ + } + dl.superindex > a:link { + text-decoration: none; + color: #fff; + } + + .contentsfooty { + border-top: thin solid #999; + font-size: 90%; + } + +} + +/* The End */ + +EOCSS + +#========================================================================== + +$JAVASCRIPT = <<'EOJAVASCRIPT'; + +// From http://www.alistapart.com/articles/alternate/ + +function setActiveStyleSheet(title) { + var i, a, main; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) { + a.disabled = true; + if(a.getAttribute("title") == title) a.disabled = false; + } + } +} + +function getActiveStyleSheet() { + var i, a; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if( a.getAttribute("rel").indexOf("style") != -1 + && a.getAttribute("title") + && !a.disabled + ) return a.getAttribute("title"); + } + return null; +} + +function getPreferredStyleSheet() { + var i, a; + for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) { + if( a.getAttribute("rel").indexOf("style") != -1 + && a.getAttribute("rel").indexOf("alt") == -1 + && a.getAttribute("title") + ) return a.getAttribute("title"); + } + return null; +} + +function createCookie(name,value,days) { + if (days) { + var date = new Date(); + date.setTime(date.getTime()+(days*24*60*60*1000)); + var expires = "; expires="+date.toGMTString(); + } + else expires = ""; + document.cookie = name+"="+value+expires+"; path=/"; +} + +function readCookie(name) { + var nameEQ = name + "="; + var ca = document.cookie.split(';'); + for(var i=0 ; i < ca.length ; i++) { + var c = ca[i]; + while (c.charAt(0)==' ') c = c.substring(1,c.length); + if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length); + } + return null; +} + +window.onload = function(e) { + var cookie = readCookie("style"); + var title = cookie ? cookie : getPreferredStyleSheet(); + setActiveStyleSheet(title); +} + +window.onunload = function(e) { + var title = getActiveStyleSheet(); + createCookie("style", title, 365); +} + +var cookie = readCookie("style"); +var title = cookie ? cookie : getPreferredStyleSheet(); +setActiveStyleSheet(title); + +// The End + +EOJAVASCRIPT + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +1; +__END__ + + + + +require 5; +package Pod::Simple::TextContent; +use strict; +use Carp (); +use Pod::Simple (); +use vars qw( @ISA $VERSION ); +$VERSION = '3.35'; +@ISA = ('Pod::Simple'); + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + $new->{'output_fh'} ||= *STDOUT{IO}; + $new->nix_X_codes(1); + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub _handle_element_start { + print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s; + return; +} + +sub _handle_text { + $_[1] =~ s/$Pod::Simple::shy//g; + $_[1] =~ s/$Pod::Simple::nbsp/ /g; + print {$_[0]{'output_fh'}} $_[1]; + return; +} + +sub _handle_element_end { + print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +1; + + +__END__ + + +require 5; +package Pod::Simple::LinkSection; + # Based somewhat dimly on Array::Autojoin +use vars qw($VERSION ); +$VERSION = '3.35'; + +use strict; +use Pod::Simple::BlackBox; +use vars qw($VERSION ); +$VERSION = '3.35'; + +use overload( # So it'll stringify nice + '""' => \&Pod::Simple::BlackBox::stringify_lol, + 'bool' => \&Pod::Simple::BlackBox::stringify_lol, + # '.=' => \&tack_on, # grudgingly support + + 'fallback' => 1, # turn on cleverness +); + +sub tack_on { + $_[0] = ['', {}, "$_[0]" ]; + return $_[0][2] .= $_[1]; +} + +sub as_string { + goto &Pod::Simple::BlackBox::stringify_lol; +} +sub stringify { + goto &Pod::Simple::BlackBox::stringify_lol; +} + +sub new { + my $class = shift; + $class = ref($class) || $class; + my $new; + if(@_ == 1) { + if (!ref($_[0] || '')) { # most common case: one bare string + return bless ['', {}, $_[0] ], $class; + } elsif( ref($_[0] || '') eq 'ARRAY') { + $new = [ @{ $_[0] } ]; + } else { + Carp::croak( "$class new() doesn't know to clone $new" ); + } + } else { # misc stuff + $new = [ '', {}, @_ ]; + } + + # By now it's a treelet: [ 'foo', {}, ... ] + foreach my $x (@$new) { + if(ref($x || '') eq 'ARRAY') { + $x = $class->new($x); # recurse + } elsif(ref($x || '') eq 'HASH') { + $x = { %$x }; + } + # otherwise leave it. + } + + return bless $new, $class; +} + +# Not much in this class is likely to be link-section specific -- +# but it just so happens that link-sections are about the only treelets +# that are exposed to the user. + +1; + +__END__ + +# TODO: let it be an option whether a given subclass even wants little treelets? + + +__END__ + + +require 5; +package Pod::Simple::Progress; +$VERSION = '3.35'; +use strict; + +# Objects of this class are used for noting progress of an +# operation every so often. Messages delivered more often than that +# are suppressed. +# +# There's actually nothing in here that's specific to Pod processing; +# but it's ad-hoc enough that I'm not willing to give it a name that +# implies that it's generally useful, like "IO::Progress" or something. +# +# -- sburke +# +#-------------------------------------------------------------------------- + +sub new { + my($class,$delay) = @_; + my $self = bless {'quiet_until' => 1}, ref($class) || $class; + $self->to(*STDOUT{IO}); + $self->delay(defined($delay) ? $delay : 5); + return $self; +} + +sub copy { + my $orig = shift; + bless {%$orig, 'quiet_until' => 1}, ref($orig); +} +#-------------------------------------------------------------------------- + +sub reach { + my($self, $point, $note) = @_; + if( (my $now = time) >= $self->{'quiet_until'}) { + my $goal; + my $to = $self->{'to'}; + print $to join('', + ($self->{'quiet_until'} == 1) ? () : '... ', + (defined $point) ? ( + '#', + ($goal = $self->{'goal'}) ? ( + ' ' x (length($goal) - length($point)), + $point, '/', $goal, + ) : $point, + $note ? ': ' : (), + ) : (), + $note || '', + "\n" + ); + $self->{'quiet_until'} = $now + $self->{'delay'}; + } + return $self; +} + +#-------------------------------------------------------------------------- + +sub done { + my($self, $note) = @_; + $self->{'quiet_until'} = 1; + return $self->reach( undef, $note ); +} + +#-------------------------------------------------------------------------- +# Simple accessors: + +sub delay { + return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] } +sub goal { + return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] } +sub to { + return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] } + +#-------------------------------------------------------------------------- + +unless(caller) { # Simple self-test: + my $p = __PACKAGE__->new->goal(5); + $p->reach(1, "Primus!"); + sleep 1; + $p->reach(2, "Secundus!"); + sleep 3; + $p->reach(3, "Tertius!"); + sleep 5; + $p->reach(4); + $p->reach(5, "Quintus!"); + sleep 1; + $p->done("All done"); +} + +#-------------------------------------------------------------------------- +1; +__END__ + +require 5; +package Pod::Simple::Debug; +use strict; +use vars qw($VERSION ); +$VERSION = '3.35'; + +sub import { + my($value,$variable); + + if(@_ == 2) { + $value = $_[1]; + } elsif(@_ == 3) { + ($variable, $value) = @_[1,2]; + + ($variable, $value) = ($value, $variable) + if defined $value and ref($value) eq 'SCALAR' + and not(defined $variable and ref($variable) eq 'SCALAR') + ; # tolerate getting it backwards + + unless( defined $variable and ref($variable) eq 'SCALAR') { + require Carp; + Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + } else { + require Carp; + Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + + if( defined &Pod::Simple::DEBUG ) { + require Carp; + Carp::croak("It's too late to call Pod::Simple::Debug -- " + . "Pod::Simple has already loaded\nAborting"); + } + + $value = 0 unless defined $value; + + unless($value =~ m/^-?\d+$/) { + require Carp; + Carp::croak( "$value isn't a numeric value." + . "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor" + . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting"); + } + + if( defined $variable ) { + # make a not-really-constant + *Pod::Simple::DEBUG = sub () { $$variable } ; + $$variable = $value; + print STDERR "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n"; + } else { + *Pod::Simple::DEBUG = eval " sub () { $value } "; + print STDERR "# Starting Pod::Simple::DEBUG = $value\n"; + } + + require Pod::Simple; + return; +} + +1; + + +__END__ + + +require 5; +package Pod::Simple::PullParserEndToken; +use Pod::Simple::PullParserToken (); +use strict; +use vars qw(@ISA $VERSION); +@ISA = ('Pod::Simple::PullParserToken'); +$VERSION = '3.35'; + +sub new { # Class->new(tagname); + my $class = shift; + return bless ['end', @_], ref($class) || $class; +} + +# Purely accessors: + +sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } +sub tag { shift->tagname(@_) } + +# shortcut: +sub is_tagname { $_[0][1] eq $_[1] } +sub is_tag { shift->is_tagname(@_) } + +1; + + +__END__ + +require 5; +package Pod::Simple::PullParser; +$VERSION = '3.35'; +use Pod::Simple (); +BEGIN {@ISA = ('Pod::Simple')} + +use strict; +use Carp (); + +use Pod::Simple::PullParserStartToken; +use Pod::Simple::PullParserEndToken; +use Pod::Simple::PullParserTextToken; + +BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } + +__PACKAGE__->_accessorize( + 'source_fh', # the filehandle we're reading from + 'source_scalar_ref', # the scalarref we're reading from + 'source_arrayref', # the arrayref we're reading from +); + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# And here is how we implement a pull-parser on top of a push-parser... + +sub filter { + my($self, $source) = @_; + $self = $self->new unless ref $self; + + $source = *STDIN{IO} unless defined $source; + $self->set_source($source); + $self->output_fh(*STDOUT{IO}); + + $self->run; # define run() in a subclass if you want to use filter()! + return $self; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +sub parse_string_document { + my $this = shift; + $this->set_source(\ $_[0]); + $this->run; +} + +sub parse_file { + my($this, $filename) = @_; + $this->set_source($filename); + $this->run; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# In case anyone tries to use them: + +sub run { + use Carp (); + if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed! + Carp::croak "You can call run() only on subclasses of " + . __PACKAGE__; + } else { + Carp::croak join '', + "You can't call run() because ", + ref($_[0]) || $_[0], " didn't define a run() method"; + } +} + +sub parse_lines { + use Carp (); + Carp::croak "Use set_source with ", __PACKAGE__, + " and subclasses, not parse_lines"; +} + +sub parse_line { + use Carp (); + Carp::croak "Use set_source with ", __PACKAGE__, + " and subclasses, not parse_line"; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + die "Couldn't construct for $class" unless $self; + + $self->{'token_buffer'} ||= []; + $self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken'; + $self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken'; + $self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken'; + + DEBUG > 1 and print STDERR "New pullparser object: $self\n"; + + return $self; +} + +# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +sub get_token { + my $self = shift; + DEBUG > 1 and print STDERR "\nget_token starting up on $self.\n"; + DEBUG > 2 and print STDERR " Items in token-buffer (", + scalar( @{ $self->{'token_buffer'} } ) , + ") :\n", map( + " " . $_->dump . "\n", @{ $self->{'token_buffer'} } + ), + @{ $self->{'token_buffer'} } ? '' : ' (no tokens)', + "\n" + ; + + until( @{ $self->{'token_buffer'} } ) { + DEBUG > 3 and print STDERR "I need to get something into my empty token buffer...\n"; + if($self->{'source_dead'}) { + DEBUG and print STDERR "$self 's source is dead.\n"; + push @{ $self->{'token_buffer'} }, undef; + } elsif(exists $self->{'source_fh'}) { + my @lines; + my $fh = $self->{'source_fh'} + || Carp::croak('You have to call set_source before you can call get_token'); + + DEBUG and print STDERR "$self 's source is filehandle $fh.\n"; + # Read those many lines at a time + for(my $i = Pod::Simple::MANY_LINES; $i--;) { + DEBUG > 3 and print STDERR " Fetching a line from source filehandle $fh...\n"; + local $/ = $Pod::Simple::NL; + push @lines, scalar(<$fh>); # readline + DEBUG > 3 and print STDERR " Line is: ", + defined($lines[-1]) ? $lines[-1] : "\n"; + unless( defined $lines[-1] ) { + DEBUG and print STDERR "That's it for that source fh! Killing.\n"; + delete $self->{'source_fh'}; # so it can be GC'd + last; + } + # but pass thru the undef, which will set source_dead to true + + # TODO: look to see if $lines[-1] is =encoding, and if so, + # do horribly magic things + + } + + if(DEBUG > 8) { + print STDERR "* I've gotten ", scalar(@lines), " lines:\n"; + foreach my $l (@lines) { + if(defined $l) { + print STDERR " line {$l}\n"; + } else { + print STDERR " line undef\n"; + } + } + print STDERR "* end of ", scalar(@lines), " lines\n"; + } + + $self->SUPER::parse_lines(@lines); + + } elsif(exists $self->{'source_arrayref'}) { + DEBUG and print STDERR "$self 's source is arrayref $self->{'source_arrayref'}, with ", + scalar(@{$self->{'source_arrayref'}}), " items left in it.\n"; + + DEBUG > 3 and print STDERR " Fetching ", Pod::Simple::MANY_LINES, " lines.\n"; + $self->SUPER::parse_lines( + splice @{ $self->{'source_arrayref'} }, + 0, + Pod::Simple::MANY_LINES + ); + unless( @{ $self->{'source_arrayref'} } ) { + DEBUG and print STDERR "That's it for that source arrayref! Killing.\n"; + $self->SUPER::parse_lines(undef); + delete $self->{'source_arrayref'}; # so it can be GC'd + } + # to make sure that an undef is always sent to signal end-of-stream + + } elsif(exists $self->{'source_scalar_ref'}) { + + DEBUG and print STDERR "$self 's source is scalarref $self->{'source_scalar_ref'}, with ", + length(${ $self->{'source_scalar_ref'} }) - + (pos(${ $self->{'source_scalar_ref'} }) || 0), + " characters left to parse.\n"; + + DEBUG > 3 and print STDERR " Fetching a line from source-string...\n"; + if( ${ $self->{'source_scalar_ref'} } =~ + m/([^\n\r]*)((?:\r?\n)?)/g + ) { + #print(">> $1\n"), + $self->SUPER::parse_lines($1) + if length($1) or length($2) + or pos( ${ $self->{'source_scalar_ref'} }) + != length( ${ $self->{'source_scalar_ref'} }); + # I.e., unless it's a zero-length "empty line" at the very + # end of "foo\nbar\n" (i.e., between the \n and the EOS). + } else { # that's the end. Byebye + $self->SUPER::parse_lines(undef); + delete $self->{'source_scalar_ref'}; + DEBUG and print STDERR "That's it for that source scalarref! Killing.\n"; + } + + + } else { + die "What source??"; + } + } + DEBUG and print STDERR "get_token about to return ", + Pod::Simple::pretty( @{$self->{'token_buffer'}} + ? $self->{'token_buffer'}[-1] : undef + ), "\n"; + return shift @{$self->{'token_buffer'}}; # that's an undef if empty +} + +sub unget_token { + my $self = shift; + DEBUG and print STDERR "Ungetting ", scalar(@_), " tokens: ", + @_ ? "@_\n" : "().\n"; + foreach my $t (@_) { + Carp::croak "Can't unget that, because it's not a token -- it's undef!" + unless defined $t; + Carp::croak "Can't unget $t, because it's not a token -- it's a string!" + unless ref $t; + Carp::croak "Can't unget $t, because it's not a token object!" + unless UNIVERSAL::can($t, 'type'); + } + + unshift @{$self->{'token_buffer'}}, @_; + DEBUG > 1 and print STDERR "Token buffer now has ", + scalar(@{$self->{'token_buffer'}}), " items in it.\n"; + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +# $self->{'source_filename'} = $source; + +sub set_source { + my $self = shift @_; + return $self->{'source_fh'} unless @_; + Carp::croak("Cannot assign new source to pull parser; create a new instance, instead") + if $self->{'source_fh'} || $self->{'source_scalar_ref'} || $self->{'source_arrayref'}; + my $handle; + if(!defined $_[0]) { + Carp::croak("Can't use empty-string as a source for set_source"); + } elsif(ref(\( $_[0] )) eq 'GLOB') { + $self->{'source_filename'} = '' . ($handle = $_[0]); + DEBUG and print STDERR "$self 's source is glob $_[0]\n"; + # and fall thru + } elsif(ref( $_[0] ) eq 'SCALAR') { + $self->{'source_scalar_ref'} = $_[0]; + DEBUG and print STDERR "$self 's source is scalar ref $_[0]\n"; + return; + } elsif(ref( $_[0] ) eq 'ARRAY') { + $self->{'source_arrayref'} = $_[0]; + DEBUG and print STDERR "$self 's source is array ref $_[0]\n"; + return; + } elsif(ref $_[0]) { + $self->{'source_filename'} = '' . ($handle = $_[0]); + DEBUG and print STDERR "$self 's source is fh-obj $_[0]\n"; + } elsif(!length $_[0]) { + Carp::croak("Can't use empty-string as a source for set_source"); + } else { # It's a filename! + DEBUG and print STDERR "$self 's source is filename $_[0]\n"; + { + local *PODSOURCE; + open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!"; + $handle = *PODSOURCE{IO}; + } + $self->{'source_filename'} = $_[0]; + DEBUG and print STDERR " Its name is $_[0].\n"; + + # TODO: file-discipline things here! + } + + $self->{'source_fh'} = $handle; + DEBUG and print STDERR " Its handle is $handle\n"; + return 1; +} + +# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ + +sub get_title_short { shift->get_short_title(@_) } # alias + +sub get_short_title { + my $title = shift->get_title(@_); + $title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s; + # turn "Foo::Bar -- bars for your foo" into "Foo::Bar" + return $title; +} + +sub get_title { shift->_get_titled_section( + 'NAME', max_token => 50, desperate => 1, @_) +} +sub get_version { shift->_get_titled_section( + 'VERSION', + max_token => 400, + accept_verbatim => 1, + max_content_length => 3_000, + @_, + ); +} +sub get_description { shift->_get_titled_section( + 'DESCRIPTION', + max_token => 400, + max_content_length => 3_000, + @_, +) } + +sub get_authors { shift->get_author(@_) } # a harmless alias + +sub get_author { + my $this = shift; + # Max_token is so high because these are + # typically at the end of the document: + $this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) || + $this->_get_titled_section('AUTHORS', max_token => 10_000, @_); +} + +#-------------------------------------------------------------------------- + +sub _get_titled_section { + # Based on a get_title originally contributed by Graham Barr + my($self, $titlename, %options) = (@_); + + my $max_token = delete $options{'max_token'}; + my $desperate_for_title = delete $options{'desperate'}; + my $accept_verbatim = delete $options{'accept_verbatim'}; + my $max_content_length = delete $options{'max_content_length'}; + my $nocase = delete $options{'nocase'}; + $max_content_length = 120 unless defined $max_content_length; + + Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ") + . join " ", map "[$_]", sort keys %options + ) + if keys %options; + + my %content_containers; + $content_containers{'Para'} = 1; + if($accept_verbatim) { + $content_containers{'Verbatim'} = 1; + $content_containers{'VerbatimFormatted'} = 1; + } + + my $token_count = 0; + my $title; + my @to_unget; + my $state = 0; + my $depth = 0; + + Carp::croak "What kind of titlename is \"$titlename\"?!" unless + defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity + my $titlename_re = quotemeta($titlename); + + my $head1_text_content; + my $para_text_content; + my $skipX; + + while( + ++$token_count <= ($max_token || 1_000_000) + and defined(my $token = $self->get_token) + ) { + push @to_unget, $token; + + if ($state == 0) { # seeking =head1 + if( $token->is_start and $token->tagname eq 'head1' ) { + DEBUG and print STDERR " Found head1. Seeking content...\n"; + ++$state; + $head1_text_content = ''; + } + } + + elsif($state == 1) { # accumulating text until end of head1 + if( $token->is_text ) { + unless ($skipX) { + DEBUG and print STDERR " Adding \"", $token->text, "\" to head1-content.\n"; + $head1_text_content .= $token->text; + } + } elsif( $token->is_tagname('X') ) { + # We're going to want to ignore X<> stuff. + $skipX = $token->is_start; + DEBUG and print STDERR +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag'; + } elsif( $token->is_end and $token->tagname eq 'head1' ) { + DEBUG and print STDERR " Found end of head1. Considering content...\n"; + $head1_text_content = uc $head1_text_content if $nocase; + if($head1_text_content eq $titlename + or $head1_text_content =~ m/\($titlename_re\)/s + # We accept "=head1 Nomen Modularis (NAME)" for sake of i18n + ) { + DEBUG and print STDERR " Yup, it was $titlename. Seeking next para-content...\n"; + ++$state; + } elsif( + $desperate_for_title + # if we're so desperate we'll take the first + # =head1's content as a title + and $head1_text_content =~ m/\S/ + and $head1_text_content !~ m/^[ A-Z]+$/s + and $head1_text_content !~ + m/\((?: + NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS + | COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS? + | CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT + )\)/sx + # avoid accepting things like =head1 Thingy Thongy (DESCRIPTION) + and ($max_content_length + ? (length($head1_text_content) <= $max_content_length) # sanity + : 1) + ) { + # Looks good; trim it + ($title = $head1_text_content) =~ s/\s+$//; + DEBUG and print STDERR " It looks titular: \"$title\".\n\n Using that.\n"; + last; + } else { + --$state; + DEBUG and print STDERR " Didn't look titular ($head1_text_content).\n", + "\n Dropping back to seeking-head1-content mode...\n"; + } + } + } + + elsif($state == 2) { + # seeking start of para (which must immediately follow) + if($token->is_start and $content_containers{ $token->tagname }) { + DEBUG and print STDERR " Found start of Para. Accumulating content...\n"; + $para_text_content = ''; + ++$state; + } else { + DEBUG and print + " Didn't see an immediately subsequent start-Para. Reseeking H1\n"; + $state = 0; + } + } + + elsif($state == 3) { + # accumulating text until end of Para + if( $token->is_text ) { + DEBUG and print STDERR " Adding \"", $token->text, "\" to para-content.\n"; + $para_text_content .= $token->text; + # and keep looking + + } elsif( $token->is_end and $content_containers{ $token->tagname } ) { + DEBUG and print STDERR " Found end of Para. Considering content: ", + $para_text_content, "\n"; + + if( $para_text_content =~ m/\S/ + and ($max_content_length + ? (length($para_text_content) <= $max_content_length) + : 1) + ) { + # Some minimal sanity constraints, I think. + DEBUG and print STDERR " It looks contentworthy, I guess. Using it.\n"; + $title = $para_text_content; + last; + } else { + DEBUG and print STDERR " Doesn't look at all contentworthy!\n Giving up.\n"; + undef $title; + last; + } + } + } + + else { + die "IMPOSSIBLE STATE $state!\n"; # should never happen + } + + } + + # Put it all back! + $self->unget_token(@to_unget); + + if(DEBUG) { + if(defined $title) { print STDERR " Returning title <$title>\n" } + else { print STDERR "Returning title <>\n" } + } + + return '' unless defined $title; + $title =~ s/^\s+//; + return $title; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +# +# Methods that actually do work at parse-time: + +sub _handle_element_start { + my $self = shift; # leaving ($element_name, $attr_hash_r) + DEBUG > 2 and print STDERR "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n"; + + push @{ $self->{'token_buffer'} }, + $self->{'start_token_class'}->new(@_); + return; +} + +sub _handle_text { + my $self = shift; # leaving ($text) + DEBUG > 2 and print STDERR "== $_[0]\n"; + push @{ $self->{'token_buffer'} }, + $self->{'text_token_class'}->new(@_); + return; +} + +sub _handle_element_end { + my $self = shift; # leaving ($element_name); + DEBUG > 2 and print STDERR "-- $_[0]\n"; + push @{ $self->{'token_buffer'} }, + $self->{'end_token_class'}->new(@_); + return; +} + +#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + +1; + + +__END__ + + +JUNK: + +sub _old_get_title { # some witchery in here + my $self = $_[0]; + my $title; + my @to_unget; + + while(1) { + push @to_unget, $self->get_token; + unless(defined $to_unget[-1]) { # whoops, short doc! + pop @to_unget; + last; + } + + DEBUG and print STDERR "-Got token ", $to_unget[-1]->dump, "\n"; + + (DEBUG and print STDERR "Too much in the buffer.\n"), + last if @to_unget > 25; # sanity + + my $pattern = ''; + if( #$to_unget[-1]->type eq 'end' + #and $to_unget[-1]->tagname eq 'Para' + #and + ($pattern = join('', + map {; + ($_->type eq 'start') ? ("<" . $_->tagname .">") + : ($_->type eq 'end' ) ? ("tagname .">") + : ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X') + : "BLORP" + } @to_unget + )) =~ m{NAME(X|)+$}s + ) { + # Whee, it fits the pattern + DEBUG and print STDERR "Seems to match =head1 NAME pattern.\n"; + $title = ''; + foreach my $t (reverse @to_unget) { + last if $t->type eq 'start' and $t->tagname eq 'Para'; + $title = $t->text . $title if $t->type eq 'text'; + } + undef $title if $title =~ m<^\s*$>; # make sure it's contentful! + last; + + } elsif ($pattern =~ m{(.+)$} + and !( $1 eq '1' and $2 eq 'NAME' ) + ) { + # Well, it fits a fallback pattern + DEBUG and print STDERR "Seems to match NAMEless pattern.\n"; + $title = ''; + foreach my $t (reverse @to_unget) { + last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s; + $title = $t->text . $title if $t->type eq 'text'; + } + undef $title if $title =~ m<^\s*$>; # make sure it's contentful! + last; + + } else { + DEBUG and $pattern and print STDERR "Leading pattern: $pattern\n"; + } + } + + # Put it all back: + $self->unget_token(@to_unget); + + if(DEBUG) { + if(defined $title) { print STDERR " Returning title <$title>\n" } + else { print STDERR "Returning title <>\n" } + } + + return '' unless defined $title; + return $title; +} + + +require 5; +package Pod::Simple::PullParserStartToken; +use Pod::Simple::PullParserToken (); +use strict; +use vars qw(@ISA $VERSION); +@ISA = ('Pod::Simple::PullParserToken'); +$VERSION = '3.35'; + +sub new { # Class->new(tagname, optional_attrhash); + my $class = shift; + return bless ['start', @_], ref($class) || $class; +} + +# Purely accessors: + +sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] } +sub tag { shift->tagname(@_) } + +sub is_tagname { $_[0][1] eq $_[1] } +sub is_tag { shift->is_tagname(@_) } + + +sub attr_hash { $_[0][2] ||= {} } + +sub attr { + if(@_ == 2) { # Reading: $token->attr('attrname') + ${$_[0][2] || return undef}{ $_[1] }; + } elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval') + ${$_[0][2] ||= {}}{ $_[1] } = $_[2]; + } else { + require Carp; + Carp::croak( + 'usage: $object->attr("val") or $object->attr("key", "newval")'); + return undef; + } +} + +1; + + +__END__ + +require 5; +package Pod::Simple::HTML; +use strict; +use Pod::Simple::PullParser (); +use vars qw( + @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION + $Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix + $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex + $Doctype_decl $Content_decl +); +@ISA = ('Pod::Simple::PullParser'); +$VERSION = '3.35'; +BEGIN { + if(defined &DEBUG) { } # no-op + elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } + else { *DEBUG = sub () {0}; } +} + +$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it. + # qq{\n}; + +$Content_decl ||= + q{}; + +$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION; +$Computerese = "" unless defined $Computerese; +$LamePad = '' unless defined $LamePad; + +$Linearization_Limit = 120 unless defined $Linearization_Limit; + # headings/items longer than that won't get an +$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?' + unless defined $Perldoc_URL_Prefix; +$Perldoc_URL_Postfix = '' + unless defined $Perldoc_URL_Postfix; + + +$Man_URL_Prefix = 'http://man.he.net/man'; +$Man_URL_Postfix = ''; + +$Title_Prefix = '' unless defined $Title_Prefix; +$Title_Postfix = '' unless defined $Title_Postfix; +%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text + # 'item-text' stuff in the index doesn't quite work, and may + # not be a good idea anyhow. + + +__PACKAGE__->_accessorize( + 'perldoc_url_prefix', + # In turning L into http://whatever/Foo%3a%3aBar, what + # to put before the "Foo%3a%3aBar". + # (for singleton mode only?) + 'perldoc_url_postfix', + # what to put after "Foo%3a%3aBar" in the URL. Normally "". + + 'man_url_prefix', + # In turning L into http://whatever/man/1/crontab, what + # to put before the "1/crontab". + 'man_url_postfix', + # what to put after the "1/crontab" in the URL. Normally "". + + 'batch_mode', # whether we're in batch mode + 'batch_mode_current_level', + # When in batch mode, how deep the current module is: 1 for "LWP", + # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc + + 'title_prefix', 'title_postfix', + # What to put before and after the title in the head. + # Should already be &-escaped + + 'html_h_level', + + 'html_header_before_title', + 'html_header_after_title', + 'html_footer', + 'top_anchor', + + 'index', # whether to add an index at the top of each page + # (actually it's a table-of-contents, but we'll call it an index, + # out of apparently longstanding habit) + + 'html_css', # URL of CSS file to point to + 'html_javascript', # URL of Javascript file to point to + + 'force_title', # should already be &-escaped + 'default_title', # should already be &-escaped +); + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +my @_to_accept; + +%Tagmap = ( + 'Verbatim' => "\n", + '/Verbatim' => "\n", + 'VerbatimFormatted' => "\n", + '/VerbatimFormatted' => "\n", + 'VerbatimB' => "", + '/VerbatimB' => "", + 'VerbatimI' => "", + '/VerbatimI' => "", + 'VerbatimBI' => "", + '/VerbatimBI' => "", + + + 'Data' => "\n", + '/Data' => "\n", + + 'head1' => "\n

      ", # And also stick in an + 'head2' => "\n

      ", # '' + 'head3' => "\n

      ", # '' + 'head4' => "\n

      ", # '' + '/head1' => "

      \n", + '/head2' => "

      \n", + '/head3' => "\n", + '/head4' => "\n", + + 'X' => "", + + changes(qw( + Para=p + B=b I=i + over-bullet=ul + over-number=ol + over-text=dl + over-block=blockquote + item-bullet=li + item-number=li + item-text=dt + )), + changes2( + map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ } + qw[ + sample=samp + definition=dfn + keyboard=kbd + variable=var + citation=cite + abbreviation=abbr + acronym=acronym + subscript=sub + superscript=sup + big=big + small=small + underline=u + strikethrough=s + preformat=pre + teletype=tt + ] # no point in providing a way to get ..., I think + ), + + '/item-bullet' => "
      • $LamePad\n", + '/item-number' => "$LamePad\n", + '/item-text' => "$LamePad\n", + 'item-body' => "\n
      ", + '/item-body' => "
      \n", + + + 'B' => "", '/B' => "", + 'I' => "", '/I' => "", + 'F' => "", '/F' => "", + 'C' => "", '/C' => "      ", + 'L' => "", # ideally never used! + '/L' => "", +); + +sub changes { + return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s + ? ( $1, => "\n<$2>", "/$1", => "\n" ) : die "Funky $_" + } @_; +} +sub changes2 { + return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s + ? ( $1, => "<$2>", "/$1", => "" ) : die "Funky $_" + } @_; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 } + # Just so we can run from the command line. No options. + # For that, use perldoc! +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub new { + my $new = shift->SUPER::new(@_); + #$new->nix_X_codes(1); + $new->nbsp_for_S(1); + $new->accept_targets( 'html', 'HTML' ); + $new->accept_codes('VerbatimFormatted'); + $new->accept_codes(@_to_accept); + DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n"; + + $new->perldoc_url_prefix( $Perldoc_URL_Prefix ); + $new->perldoc_url_postfix( $Perldoc_URL_Postfix ); + $new->man_url_prefix( $Man_URL_Prefix ); + $new->man_url_postfix( $Man_URL_Postfix ); + $new->title_prefix( $Title_Prefix ); + $new->title_postfix( $Title_Postfix ); + + $new->html_header_before_title( + qq[$Doctype_decl] + ); + $new->html_header_after_title( join "\n" => + "", + $Content_decl, + "\n", + $new->version_tag_comment, + "\n", + ); + $new->html_footer( qq[\n\n\n\n] ); + $new->top_anchor( "\n" ); + + $new->{'Tagmap'} = {%Tagmap}; + + return $new; +} + +sub __adjust_html_h_levels { + my ($self) = @_; + my $Tagmap = $self->{'Tagmap'}; + + my $add = $self->html_h_level; + return unless defined $add; + return if ($self->{'Adjusted_html_h_levels'}||0) == $add; + + $add -= 1; + for (1 .. 4) { + $Tagmap->{"head$_"} =~ s/$_/$_ + $add/e; + $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e; + } +} + +sub batch_mode_page_object_init { + my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; + DEBUG and print STDERR "Initting $self\n for $module\n", + " in $infile\n out $outfile\n depth $depth\n"; + $self->batch_mode(1); + $self->batch_mode_current_level($depth); + return $self; +} + +sub run { + my $self = $_[0]; + return $self->do_middle if $self->bare_output; + return + $self->do_beginning && $self->do_middle && $self->do_end; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub do_beginning { + my $self = $_[0]; + + my $title; + + if(defined $self->force_title) { + $title = $self->force_title; + DEBUG and print STDERR "Forcing title to be $title\n"; + } else { + # Actually try looking for the title in the document: + $title = $self->get_short_title(); + unless($self->content_seen) { + DEBUG and print STDERR "No content seen in search for title.\n"; + return; + } + $self->{'Title'} = $title; + + if(defined $title and $title =~ m/\S/) { + $title = $self->title_prefix . esc($title) . $self->title_postfix; + } else { + $title = $self->default_title; + $title = '' unless defined $title; + DEBUG and print STDERR "Title defaults to $title\n"; + } + } + + + my $after = $self->html_header_after_title || ''; + if($self->html_css) { + my $link = + $self->html_css =~ m/html_css # It's a big blob of markup, let's drop it in + : sprintf( # It's just a URL, so let's wrap it up + qq[\n], + $self->html_css, + ); + $after =~ s{()}{$link\n$1}i; # otherwise nevermind + } + $self->_add_top_anchor(\$after); + + if($self->html_javascript) { + my $link = + $self->html_javascript =~ m/html_javascript # It's a big blob of markup, let's drop it in + : sprintf( # It's just a URL, so let's wrap it up + qq[\n], + $self->html_javascript, + ); + $after =~ s{()}{$link\n$1}i; # otherwise nevermind + } + + print {$self->{'output_fh'}} + $self->html_header_before_title || '', + $title, # already escaped + $after, + ; + + DEBUG and print STDERR "Returning from do_beginning...\n"; + return 1; +} + +sub _add_top_anchor { + my($self, $text_r) = @_; + unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack + $$text_r .= $self->top_anchor || ''; + } + return; +} + +sub version_tag_comment { + my $self = shift; + return sprintf + "\n", + esc( + ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(), + $], scalar(gmtime), + ), $self->_modnote(), + ; +} + +sub _modnote { + my $class = ref($_[0]) || $_[0]; + return join "\n " => grep m/\S/, split "\n", + +qq{ +If you want to change this HTML document, you probably shouldn't do that +by changing it directly. Instead, see about changing the calling options +to $class, and/or subclassing $class, +then reconverting this document from the Pod source. +When in doubt, email the author of $class for advice. +See 'perldoc $class' for more info. +}; + +} + +sub do_end { + my $self = $_[0]; + print {$self->{'output_fh'}} $self->html_footer || ''; + return 1; +} + +# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +# Normally this would just be a call to _do_middle_main_loop -- but we +# have to do some elaborate things to emit all the content and then +# summarize it and output it /before/ the content that it's a summary of. + +sub do_middle { + my $self = $_[0]; + return $self->_do_middle_main_loop unless $self->index; + + if( $self->output_string ) { + # An efficiency hack + my $out = $self->output_string; #it's a reference to it + my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n"; + $$out .= $sneakytag; + $self->_do_middle_main_loop; + $sneakytag = quotemeta($sneakytag); + my $index = $self->index_as_html(); + if( $$out =~ s/$sneakytag/$index/s ) { + # Expected case + DEBUG and print STDERR "Inserted ", length($index), " bytes of index HTML into $out.\n"; + } else { + DEBUG and print STDERR "Odd, couldn't find where to insert the index in the output!\n"; + # I don't think this should ever happen. + } + return 1; + } + + unless( $self->output_fh ) { + require Carp; + Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that."); + } + + # If we get here, we're outputting to a FH. So we need to do some magic. + # Namely, divert all content to a string, which we output after the index. + my $fh = $self->output_fh; + my $content = ''; + { + # Our horrible bait and switch: + $self->output_string( \$content ); + $self->_do_middle_main_loop; + $self->abandon_output_string(); + $self->output_fh($fh); + } + print $fh $self->index_as_html(); + print $fh $content; + + return 1; +} + +########################################################################### + +sub index_as_html { + my $self = $_[0]; + # This is meant to be called AFTER the input document has been parsed! + + my $points = $self->{'PSHTML_index_points'} || []; + + @$points > 1 or return qq[
      \n]; + # There's no point in having a 0-item or 1-item index, I dare say. + + my(@out) = qq{\n
      }; + my $level = 0; + + my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent); + foreach my $p (@$points, ['head0', '(end)']) { + ($tagname, $text) = @$p; + $anchorname = $self->section_escape($text); + if( $tagname =~ m{^head(\d+)$} ) { + $target_level = 0 + $1; + } else { # must be some kinda list item + if($previous_tagname =~ m{^head\d+$} ) { + $target_level = $level + 1; + } else { + $target_level = $level; # no change needed + } + } + + # Get to target_level by opening or closing ULs + while($level > $target_level) + { --$level; push @out, (" " x $level) . "
    "; } + while($level < $target_level) + { ++$level; push @out, (" " x ($level-1)) + . "

    • I Same as \"I\" in current package. +B<|>I Run debugger command, piping DB::OUT to current pager. +B<||>I Same as B<|>I but DB::OUT is temporarily select()ed as well. +B<\=> [I I] Define a command alias, or list current aliases. +I Execute as a perl statement in current package. +B Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following settings are preserved: + history, breakpoints and actions, debugger Bptions + and the following command-line options: I<-w>, I<-I>, I<-e>. + +B [I] ... Set boolean option to true +B [IB] Query options +B [IB<=>I] [I=B<\">IB<\">] ... + Set options. Use quotes if spaces in value. + I, I chars used to recall command or spawn shell; + I program for output of \"|cmd\"; + I run Tk while prompting (with ReadLine); + I I I level of verbosity; + I Allows stepping off the end of the script. + I Debugger should stop as early as possible. + I Remote hostname:port for remote debugging + The following options affect what happens with B, B, and B commands: + I, I print only first N elements ('' for all); + I, I change style of array and hash dump; + I whether to print contents of globs; + I dump arrays holding debugged files; + I dump symbol tables of packages; + I dump contents of \"reused\" addresses; + I, I, I change style of string dump; + I Do not print the overload-stringified value; + Other options include: + I affects printing of return value after B command, + I affects printing messages on subroutine entry/exit. + I affects printing messages on possible breaking points. + I gives max length of evals/args listed in stack trace. + I affects screen appearance of the command line. + I bits control attempts to create a new TTY on events: + 1: on fork() 2: debugger is started inside debugger + 4: on startup + During startup options are initialized from \$ENV{PERLDB_OPTS}. + You can put additional initialization options I, I, + I, I, and I there (or use + B after you set them). + +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. +B Summary of debugger commands. +B [I] Get help [on a specific debugger command], enter B<|h> to page. +B Long help for debugger commands +B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the + named Perl I, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. + +Type '|h h' for a paged display if this was too hard to read. + +"; # Fix balance of vi % matching: }}}} + + # note: tabs in the following section are not-so-helpful + $summary = <<"END_SUM"; +I I + B [I|I] List source code B Stack trace + B<-> or B<.> List previous/current line B [I] Single step [in expr] + B [I] View around line B [I] Next, steps over subs + B I View source in file /B> Repeat last B or B + BIB BIB Search forw/backw B Return from subroutine + B Show module versions B [I|I] Continue until position +I B List break/watch/actions + B [...] Set debugger options B [I] [I] Toggle trace [max depth] ][trace expr] + B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint + B<$prc> [I|I] Redo a previous command B I Delete a/all breakpoints + B [I<-num>] Display last num commands B [I] I Do cmd before line + B<=> [I I] Define/list an alias B I Delete a/all actions + B [I] Get help on command B I Add a watch expression + B Complete help page B I Delete a/all watch exprs + B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess + B or B<^D> Quit B Attempt a restart +I B Execute perl code, also see: B,B,B I + B|B I Evals expr in list context, dumps the result or lists methods. + B