diff --git a/.gitignore b/.gitignore index c5afb05..385e7f8 100644 --- a/.gitignore +++ b/.gitignore @@ -47,6 +47,7 @@ coverage.dat # --- Editor and OS noise --- .DS_Store +.vscode/ *~ \#*\# .\#* diff --git a/README.md b/README.md index 22ae049..e8ead87 100644 --- a/README.md +++ b/README.md @@ -77,7 +77,7 @@ outside the tested support boundary. ## Development ```sh -nix develop # SBCL with CL_SOURCE_REGISTRY already set +nix develop # SBCL + cl-weave + paredit; registry already set nix run .#test # run the test suite nix flake check # full hermetic gate on x86_64-linux CI nix fmt # format Nix sources (treefmt) diff --git a/data/presentation/highlight-data.lisp b/data/highlight-data.lisp similarity index 76% rename from data/presentation/highlight-data.lisp rename to data/highlight-data.lisp index 6649e3d..b760b58 100644 --- a/data/presentation/highlight-data.lisp +++ b/data/highlight-data.lisp @@ -1,8 +1,7 @@ -;;; Highlight data tables: builtin names, operator token types, and the -;;; fallback (theme-less) ANSI role palette used by highlight.lisp. -(in-package #:nshell.presentation) +;;; Literal syntax-highlighting data kept separate from the classifier. +(in-package #:nshell.highlight) -(defvar *builtin-commands* +(defparameter +highlight-builtin-names+ '("echo" "printf" "pwd" "ls" "cd" "exit" "fg" "bg" "jobs" "disown" "set" "export" "unset" "alias" "abbr" "function" "source" "exec" "true" "false" "contains" "test" "type" "which" "history" "help") diff --git a/docs/notes/coverage-analysis.md b/docs/notes/coverage-analysis.md index 2497787..9f9a580 100644 --- a/docs/notes/coverage-analysis.md +++ b/docs/notes/coverage-analysis.md @@ -16,14 +16,20 @@ silently removed from the report. ## Reproduce ```sh -NSHELL_COVERAGE_DIR=/tmp/nshell-coverage \ +NSHELL_COVERAGE_DIR="$PWD/coverage" \ nix develop 'path:.' --command sbcl --script scripts/coverage.lisp ``` +The command writes `cover-index.html` and `coverage-summary.json` below the +selected directory. In a Nix check, where `$out` is provided, the same files +are retained below `$out/coverage/`. Without an explicit directory, the script +uses `$TMPDIR/nshell-coverage/` when `TMPDIR` is available; the dev-shell +`coverage` alias selects the repository's `coverage/` directory explicitly. + The command is release evidence only when the selected test count is non-zero, -the test and error counts are zero, the generated report exists, and both the -minimum and target fields have been inspected. A passing minimum with -`target-reached=false` is a warning, not a 100% coverage claim. +the test and error counts are zero, the generated HTML and JSON artifacts +exist, and both the minimum and target fields have been inspected. A passing +minimum with `target-reached=false` is a warning, not a 100% coverage claim. ## What the suite verifies diff --git a/docs/src/getting-started.md b/docs/src/getting-started.md index 022342f..ba03207 100644 --- a/docs/src/getting-started.md +++ b/docs/src/getting-started.md @@ -80,7 +80,7 @@ git clone https://github.com/nerima-lisp/nshell cd nshell nix build # produces ./result/bin/nshell nix flake check # full hermetic gate on x86_64-linux CI -nix develop # dev shell with SBCL + cl-weave +nix develop # dev shell with SBCL + cl-weave + paredit ``` `flake.nix` declares `x86_64-linux` and `aarch64-darwin`. The full hermetic diff --git a/docs/src/guide/recipes.md b/docs/src/guide/recipes.md index b7d973d..67bd5d3 100644 --- a/docs/src/guide/recipes.md +++ b/docs/src/guide/recipes.md @@ -53,6 +53,21 @@ Just the focused completion suite (`nshell/weave`): sbcl --script scripts/weave.lisp ``` +All repository entry points use `scripts/asdf-runtime.lisp` for source +discovery and compile policy. The Nix development shell supplies a complete +`CL_SOURCE_REGISTRY`; outside that shell, set `NSHELL_SOURCE_TREE` to an +explicit directory containing sibling Common Lisp systems, or set +`CL_SOURCE_REGISTRY` yourself. When no registry is supplied, the repository +itself is registered and the runtime does not scan a worktree's parent +directory. The shared runtime deliberately ignores inherited ASDF output +translations and writes compiled files below `NSHELL_ASDF_OUTPUT_DIR`, or a +temporary `nshell-asdf/` directory when that variable is unset: + +```sh +NSHELL_SOURCE_TREE=/path/to/common-lisp-systems \ + sbcl --script run-tests.lisp +``` + ### The non-sandboxed integration run Some cases need a real PTY, `stty`, and external binaries, which the Nix @@ -70,11 +85,13 @@ job-control lifecycle checks. ## Generate a coverage report ```sh -nix develop -c sbcl --script scripts/coverage.lisp +NSHELL_COVERAGE_DIR="$PWD/coverage" \ + nix develop -c sbcl --script scripts/coverage.lisp ``` -The report is written to `coverage/cover-index.html`. Set `NSHELL_COVERAGE_DIR` -to redirect the output. +The report is written to `coverage/cover-index.html`, with the gate result in +`coverage/coverage-summary.json`. Set `NSHELL_COVERAGE_DIR` to redirect both +artifacts. The default Nix check stores them under its `$out/coverage/` output. ## Performance evidence diff --git a/flake.nix b/flake.nix index c53e4d9..f25d5a6 100644 --- a/flake.nix +++ b/flake.nix @@ -552,10 +552,14 @@ # whole docs tree. treefmt.evalModule = treefmt-nix.lib.evalModule; - # The cl-weave CLI, which the suites' reporters are documented against. - # Interactive only: the registry the shell exports already carries every - # system, check dependencies included. - devShellPackages = ctx: [ cl-weave.packages.${ctx.system}.default ]; + # The cl-weave CLI, which the suites' reporters are documented against, + # and the Paredit CLI used for structural Common Lisp analysis. Both + # come from the same pinned cl-weave input so the development shell does + # not grow a second, independently versioned tooling stack. + devShellPackages = ctx: [ + cl-weave.packages.${ctx.system}.default + cl-weave.inputs.paredit-cli.packages.${ctx.system}.default + ]; overrideOutputs = ctx: @@ -576,14 +580,17 @@ devShells.default = ctx.generated.devShells.default.overrideAttrs (previous: { shellHook = previous.shellHook + '' export NSHELL_ROOT=$PWD - alias test='cd "$NSHELL_ROOT" && sbcl --script "$NSHELL_ROOT/run-tests.lisp"' - alias coverage='cd "$NSHELL_ROOT" && NSHELL_COVERAGE_DIR="$NSHELL_ROOT/coverage" sbcl --script "$NSHELL_ROOT/scripts/coverage.lisp"' - alias weave='cd "$NSHELL_ROOT" && sbcl --script "$NSHELL_ROOT/scripts/weave.lisp"' + export NSHELL_TIMEOUT_SECONDS=1800 + alias test='cd "$NSHELL_ROOT" && timeout --signal=TERM --kill-after=5s "$NSHELL_TIMEOUT_SECONDS" sbcl --script "$NSHELL_ROOT/run-tests.lisp"' + alias coverage='cd "$NSHELL_ROOT" && NSHELL_COVERAGE_DIR="$NSHELL_ROOT/coverage" timeout --signal=TERM --kill-after=5s "$NSHELL_TIMEOUT_SECONDS" sbcl --script "$NSHELL_ROOT/scripts/coverage.lisp"' + alias weave='cd "$NSHELL_ROOT" && timeout --signal=TERM --kill-after=5s "$NSHELL_TIMEOUT_SECONDS" sbcl --script "$NSHELL_ROOT/scripts/weave.lisp"' + alias paredit='paredit' echo "" echo "nshell development environment" echo " test - Run the full nshell suite (cl-weave, nshell/test)" echo " weave - Run the focused completion suite (nshell/weave)" echo " coverage - Run the test suite and write HTML coverage to coverage/" + echo " paredit - Run Paredit-aware Common Lisp analysis" echo " sbcl - Interactive Common Lisp (with cl-weave)" echo "" ''; @@ -625,8 +632,8 @@ # Generate the sb-cover report and enforce the configured source # expression minimum. The report also records the distance from - # the aspirational 100% target without making an unsupported - # claim that structural sb-cover forms are executable. + # the explicit 100% target without claiming that it has been + # reached when executable expressions remain uncovered. coverage = ctx.cl.mkScriptCheck { drv = ctx.package; entryPoint = "scripts/coverage.lisp"; diff --git a/nshell.asd b/nshell.asd index 2775636..e02a241 100644 --- a/nshell.asd +++ b/nshell.asd @@ -1,11 +1,3 @@ -;;; This form comes FIRST, before any defsystem. ASDF binds *package* to -;;; ASDF-USER only for a file it loads itself; read any other way — a REPL -;;; `load`, an editor evaluating the buffer, flake.nix parsing :version — the -;;; file is read in whatever package happens to be current, and an unqualified -;;; `defsystem` then fails to read at all. Saying it makes the file -;;; self-contained. See PACKAGE_STANDARD.md "asd の書き方". -(in-package #:asdf-user) - ;;; Metadata keys follow the org's canonical order: ;;; :description :long-description :author :maintainer :license :version ;;; :homepage :bug-tracker :source-control :depends-on :pathname :serial @@ -45,6 +37,7 @@ (:file "package-domain") (:file "package-application") (:file "package-infrastructure") + (:file "package-highlight") (:file "package-presentation") (:module "feature-command-line" :pathname "../packages/feature/command-line/src" @@ -62,11 +55,11 @@ (:file "domain/execution/command") (:file "domain/execution/pipeline") (:file "domain/execution/job") - (:file "domain/parsing/ast") - (:file "domain/parsing/ast-redirect-split") - (:file "domain/parsing/tokenizer-data") - (:file "domain/parsing/tokenizer-readers") - (:file "domain/parsing/tokenizer-handlers") + (:file "domain/parsing/ast") + (:file "domain/parsing/ast-redirect-split") + (:file "domain/parsing/tokenizer-data") + (:file "domain/parsing/tokenizer-readers") + (:file "domain/parsing/tokenizer-handlers") (:file "domain/parsing/parse-result") (:file "domain/parsing/control-flow-data") (:file "domain/parsing/control-flow") @@ -81,18 +74,18 @@ (:file "domain/parsing/parser-here-doc") (:file "domain/parsing/parser-reduction") (:file "domain/parsing/parser") - (:file "domain/environment/env") - (:file "domain/expansion/expand") - (:file "domain/expansion/brace") - (:file "domain/expansion/parameter-data") - (:file "domain/expansion/parameter-selection") - (:file "domain/expansion/parameter-braced") - (:file "domain/expansion/parameter") - (:file "domain/expansion/arithmetic") - (:file "domain/expansion/arithmetic-operator-data" - :pathname "../data/domain/expansion/arithmetic-operator-data") - (:file "domain/expansion/fields") - (:file "domain/abbreviation/expansion") + (:file "domain/environment/env") + (:file "domain/expansion/expand") + (:file "domain/expansion/brace") + (:file "domain/expansion/parameter-data") + (:file "domain/expansion/parameter-selection") + (:file "domain/expansion/parameter-braced") + (:file "domain/expansion/parameter") + (:file "domain/expansion/arithmetic") + (:file "domain/expansion/arithmetic-operator-data" + :pathname "../data/domain/expansion/arithmetic-operator-data") + (:file "domain/expansion/fields") + (:file "domain/abbreviation/expansion") (:file "domain/completion/candidate") (:file "domain/completion/catalog-build") (:file "domain/completion/catalog-command-data" @@ -118,23 +111,27 @@ (:file "domain/prompting/prompt") (:file "application/event-dispatcher") (:file "application/shell-context") - (:file "application/execute-pipeline-expansion") - (:file "application/execute-pipeline-redirect") - (:file "application/execute-pipeline-stage-external") - (:file "application/execute-pipeline-stage-background") - (:file "application/execute-pipeline-stage") - (:file "application/execute-pipeline-control") + (:file "application/execute-pipeline-expansion") + (:file "application/execute-pipeline-redirect") + (:file "application/execute-pipeline-stage-external") + (:file "application/execute-pipeline-stage-background") + (:file "application/execute-pipeline-stage") + (:file "application/execute-pipeline-control") (:file "application/manage-job") (:file "application/pipeline-diagram") (:file "application/builtin-spec-data" :pathname "../data/application/builtin-spec-data") (:file "application/builtin-spec") (:file "application/builtin-runtime") + (:file "application/builtin-macros") (:file "application/builtin-type-helpers") (:file "application/builtin-string-support") (:file "application/builtin-string") (:file "application/builtin-source-reader") (:file "application/builtin-source") + (:file "application/builtin-printf-format") + (:file "application/builtin-printf-parser") + (:file "application/builtin-printf") (:file "application/builtin-commands") (:file "application/builtin-commands-history") (:file "application/builtin-jobs") @@ -159,6 +156,7 @@ (:file "infrastructure/acl/pty") (:file "infrastructure/acl/pty-spawn") (:file "infrastructure/acl/signal-acl") + (:file "infrastructure/acl/process-capabilities") (:file "infrastructure/persistence/file-history") (:file "infrastructure/persistence/file-config") (:file "infrastructure/terminal/raw-mode") @@ -166,6 +164,9 @@ (:file "infrastructure/terminal/input-core") (:file "infrastructure/terminal/input-decode") (:file "infrastructure/terminal/input-read") + (:file "highlight-data" + :pathname "../data/highlight-data") + (:file "highlight") (:file "presentation/input-state-static-data" :pathname "../data/presentation/input-state-data") (:file "presentation/input-state-core") @@ -184,23 +185,20 @@ (:file "presentation/input-state-kill-yank") (:file "presentation/input-state-history-search") (:file "presentation/input-state-dispatch") - (:file "presentation/input-state-vi-data") - (:file "presentation/input-state-vi") - (:file "presentation/input-state-vi-edit") + (:file "presentation/input-state-vi-data") + (:file "presentation/input-state-vi") + (:file "presentation/input-state-vi-edit") (:file "presentation/input-state-session") (:file "presentation/repl-boundaries") (:file "presentation/prompt-display") (:file "presentation/completion-ui") (:file "presentation/autosuggest") - (:file "presentation/highlight-data" - :pathname "../data/presentation/highlight-data") - (:file "presentation/highlight") - (:file "presentation/repl-state") - (:file "presentation/repl-input-state") - (:file "presentation/repl-completion-seed") - (:file "presentation/repl-environment") - (:file "presentation/repl-session-init") - (:file "presentation/repl-process") + (:file "presentation/repl-state") + (:file "presentation/repl-input-state") + (:file "presentation/repl-completion-seed") + (:file "presentation/repl-environment") + (:file "presentation/repl-session-init") + (:file "presentation/repl-process") (:file "presentation/repl-execution-context") (:file "presentation/repl-execution-command") (:file "presentation/repl-execution") @@ -212,10 +210,10 @@ (:file "presentation/repl-output-handlers") (:file "presentation/repl-output-event-handlers") (:file "presentation/repl-output") - (:file "presentation/repl-session") - (:file "presentation/repl-batch") - (:file "presentation/repl") - (:file "main")) + (:file "presentation/repl-session") + (:file "presentation/repl-batch") + (:file "presentation/repl") + (:file "main")) ;; The three build keys and the :perform below are exempt from the metadata ;; order above -- PACKAGE_STANDARD.md names cl-weave's identical trio and ;; cl-tty-kit's :perform as "はどこに書いても構いません" -- and they sit here, @@ -276,16 +274,16 @@ ((:file "package") (:file "support/assertions") (:file "helpers-runner") - (:file "support/pbt") - (:file "support/pbt-shell") - (:file "support/input-state") - (:file "support/input-state-assertions") + (:file "support/pbt") + (:file "support/pbt-shell") + (:file "support/input-state") + (:file "support/input-state-assertions") (:file "support/repl") (:file "support/builtins") (:file "support/completion") - (:file "support/prompt") - (:file "support/history") - (:file "support/matchers") + (:file "support/prompt") + (:file "support/history") + (:file "support/matchers") (:file "unit/test-package-by-feature") (:file "unit/test-domain-events") (:file "unit/test-signals") @@ -302,13 +300,13 @@ (:file "unit/test-expansion-abbreviation") (:file "unit/test-completion-rules") (:file "unit/test-completion-rule-prover-boundaries") - (:file "unit/test-completion-rule-prover") - (:file "unit/test-completion-builtins") - (:file "unit/test-completion-knowledge-base") - (:file "unit/test-completion-path-reducer") - (:file "unit/test-completion-knowledge-base-behavior") - (:file "unit/test-completion-properties") - (:file "unit/test-completion-context") + (:file "unit/test-completion-rule-prover") + (:file "unit/test-completion-builtins") + (:file "unit/test-completion-knowledge-base") + (:file "unit/test-completion-path-reducer") + (:file "unit/test-completion-knowledge-base-behavior") + (:file "unit/test-completion-properties") + (:file "unit/test-completion-context") (:file "unit/test-repl") (:file "unit/test-repl-completion-data") (:file "unit/test-repl-background") diff --git a/run-tests.lisp b/run-tests.lisp index 51df9de..9d392f6 100644 --- a/run-tests.lisp +++ b/run-tests.lisp @@ -7,38 +7,30 @@ ;;;; the hermetic Nix check and a plain local run execute exactly the same code ;;;; path rather than two hand-rolled `--eval` chains that drift apart. ;;;; -;;;; Dependency resolution mirrors scripts/weave.lisp: inside `nix develop` or -;;;; the Nix sandbox the systems are already on CL_SOURCE_REGISTRY, and for a -;;;; plain ghq checkout the parent directory tree is registered so sibling -;;;; checkouts (../cl-weave, ../cl-prolog-kit, ...) are found automatically. An -;;;; explicit CL_SOURCE_REGISTRY still wins, because the existing configuration -;;;; is inherited rather than replaced. +;;;; Dependency resolution is shared with the auxiliary scripts through +;;;; scripts/asdf-runtime.lisp. An explicit CL_SOURCE_REGISTRY still wins; +;;;; otherwise NSHELL_SOURCE_TREE opts into one explicit sibling-system tree. (require :asdf) -(asdf:load-system :cl-host-kit) -(let* ((root (truename #P"./")) - (parent (host-kit:parent-directory-pathname root))) - (asdf:initialize-source-registry - (if (host-kit:getenv "CL_SOURCE_REGISTRY") - `(:source-registry - (:directory ,root) - :inherit-configuration) - `(:source-registry - (:directory ,root) - (:tree ,parent) - :inherit-configuration))) - ;; Warn rather than abort on compile-file warnings: the suite's own failures - ;; are the signal this script reports, and a style warning in a dependency - ;; should not masquerade as a test failure. - (setf asdf:*compile-file-warnings-behaviour* :warn - asdf:*compile-file-failure-behaviour* :warn) - (let ((passed-p - (handler-case - (progn - (asdf:load-system "nshell/test") - (funcall (find-symbol "RUN-TESTS" "NSHELL/TEST"))) - (error (condition) - (format *error-output* "~&nshell/test failed: ~A~%" condition) - nil)))) - (sb-ext:exit :code (if passed-p 0 1)))) +(let* ((script-path (truename (or *load-truename* + *load-pathname* + #P"./run-tests.lisp"))) + (root (uiop:pathname-directory-pathname script-path))) + (load (merge-pathnames #P"scripts/asdf-runtime.lisp" root)) + (format *error-output* "~&[nshell] configure runtime~%") + (finish-output *error-output*) + (nshell-configure-runtime root) + (format *error-output* "~&[nshell] load nshell/test~%") + (finish-output *error-output*) + (asdf:load-system "nshell/test") + (format *error-output* "~&[nshell] run tests~%") + (finish-output *error-output*) + (let ((runner (find-symbol "RUN-TESTS" "NSHELL/TEST"))) + (unless (and runner (fboundp runner)) + (error "NSHELL/TEST:RUN-TESTS is not available.")) + (unless (funcall runner) + (error "nshell/test reported failure."))) + (format *error-output* "~&[nshell] tests passed~%") + (finish-output *error-output*) + (sb-ext:exit :code 0)) diff --git a/scripts/asdf-runtime.lisp b/scripts/asdf-runtime.lisp index d70ff11..12e462e 100644 --- a/scripts/asdf-runtime.lisp +++ b/scripts/asdf-runtime.lisp @@ -16,3 +16,113 @@ (t ,(truename output-root)) :ignore-inherited-configuration)) output-root)) + +(defun %nshell-register-asd-file (registry source) + (let ((name (string-downcase (pathname-name source)))) + (unless (gethash name registry) + (setf (gethash name registry) source)))) + +(defparameter +nshell-source-registry-exclusions+ + '(".bzr" ".cdv" ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" + "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" "debian")) + +(defun %nshell-register-asd-directory (registry directory) + (dolist (source (asdf/source-registry:directory-asd-files directory)) + (%nshell-register-asd-file registry source))) + +(defun %nshell-register-asd-tree (registry directory exclusions) + (asdf/source-registry:collect-sub*directories-asd-files + directory + :exclude exclusions + :collect (lambda (source) + (%nshell-register-asd-file registry source)))) + +(defun %nshell-process-source-registry-form (registry form) + (let ((exclusions (copy-list +nshell-source-registry-exclusions+))) + (dolist (directive + (cdr (asdf/source-registry:validate-source-registry-form form))) + (destructuring-bind (keyword &rest arguments) + (if (consp directive) directive (list directive)) + (case keyword + (:directory + (%nshell-register-asd-directory registry + (uiop:ensure-directory-pathname + (pathname (first arguments))))) + (:tree + (%nshell-register-asd-tree registry + (uiop:ensure-directory-pathname + (pathname (first arguments))) + exclusions)) + (:exclude + (setf exclusions (copy-list arguments))) + (:also-exclude + (setf exclusions (append exclusions arguments))) + ((:ignore-inherited-configuration :inherit-configuration) + nil) + (:default-registry + (error "The nshell source registry cannot include the default registry.")) + (:include + (error "The nshell source registry cannot include ~S." (first arguments))) + (otherwise + (error "Unsupported nshell source-registry directive ~S." keyword))))))) + +(defun %nshell-build-source-registry (forms) + "Build an ASDF registry from FORMS without traversing implementation trees. + +ASDF's standard initializer wraps every registry with the implementation's +source tree. In the Nix shell that tree can contain recursive editor links, +so direct registration is the deterministic project boundary we need here. +Only explicit directories and trees are accepted; inherited and user-level +registries would make a build depend on the host machine." + (let ((registry (make-hash-table :test #'equal))) + (dolist (form forms) + (%nshell-process-source-registry-form registry form)) + registry)) + +(defun nshell-configure-source-registry (root) + "Register ROOT and an explicitly requested source tree with ASDF. + +An explicit CL_SOURCE_REGISTRY is appended after ROOT so project definitions +win name collisions. Outside that shell, NSHELL_SOURCE_TREE is opt-in +because a worktree parent can contain many unrelated checkouts and scanning it +makes source discovery both slow and nondeterministic." + (let* ((root (truename (uiop:ensure-directory-pathname root))) + (forms (list `(:source-registry + (:directory ,root) + :ignore-inherited-configuration))) + (source-registry (uiop:getenv "CL_SOURCE_REGISTRY"))) + (if source-registry + (setf forms + (nconc forms + (list + (asdf/source-registry:parse-source-registry-string + source-registry)))) + (let ((source-tree (uiop:getenv "NSHELL_SOURCE_TREE"))) + (when source-tree + (setf forms + (nconc forms + (list `(:source-registry + (:tree ,(truename + (uiop:ensure-directory-pathname + source-tree)))))))))) + (setf asdf/source-registry:*source-registry* + (%nshell-build-source-registry forms)) + root)) + +(defun nshell-configure-runtime (root) + "Configure ASDF source lookup and compile policy. + +Compiled systems are written beneath NSHELL_ASDF_OUTPUT_DIR when it is set, +or beneath the host temporary directory otherwise. This is required when the +source tree or its dependencies are read-only, as they are in a Nix build. + +SB-POSIX is required here, before the source registry below is replaced with +the project-only tree: cl-host-kit depends on it as a plain ASDF system name +(not a (:require ...) component), and its .asd file lives in SBCL's own +contrib tree, which the replacement registry deliberately excludes." + (require :sb-posix) + (let ((root (nshell-configure-source-registry root))) + (nshell-configure-writable-asdf-output) + (setf asdf:*compile-file-warnings-behaviour* :warn + asdf:*compile-file-failure-behaviour* :error) + root)) diff --git a/scripts/benchmark-completion.lisp b/scripts/benchmark-completion.lisp index f5f0ebe..02c4091 100644 --- a/scripts/benchmark-completion.lisp +++ b/scripts/benchmark-completion.lisp @@ -1,47 +1,43 @@ (require :asdf) -(asdf:load-system :cl-host-kit) -(let* ((root (truename #P"./")) - (parent (host-kit:parent-directory-pathname root)) - (jsonl-path (host-kit:getenv "NSHELL_BENCH_JSONL")) - (mode (string-downcase (or (host-kit:getenv "NSHELL_BENCH_MODE") "warm")))) - (asdf:initialize-source-registry - (if (host-kit:getenv "CL_SOURCE_REGISTRY") - (list :source-registry - (list :directory root) - :inherit-configuration) - (list :source-registry - (list :directory root) - (list :tree parent) - :inherit-configuration))) - (setf asdf:*compile-file-warnings-behaviour* :warn - asdf:*compile-file-failure-behaviour* :warn) - (handler-case - (progn - (unless (member mode '("warm" "process" "all") :test #'string=) - (error "NSHELL_BENCH_MODE must be warm, process, or all (got ~S)" mode)) - (asdf:load-system :nshell/benchmark :force t) - (labels ((run (stream) - (when (member mode '("warm" "all") :test #'string=) - (funcall (find-symbol "RUN-COMPLETION-BENCHMARK" "NSHELL/BENCHMARK") - :jsonl-stream stream)) - (when (member mode '("process" "all") :test #'string=) - (funcall (find-symbol "RUN-PROCESS-BENCHMARK" "NSHELL/BENCHMARK") - :jsonl-stream (or stream *standard-output*))))) - (if (and jsonl-path (plusp (length jsonl-path))) - (progn - (format t "~&JSONL output: ~A~%" jsonl-path) - (let ((failure nil)) - (with-open-file (stream jsonl-path :direction :output :if-exists :supersede - :if-does-not-exist :create :external-format :utf-8) - (handler-case - (run stream) - (error (condition) - (setf failure condition)))) - (when failure - (error failure)))) - (run nil))) - (sb-ext:exit :code 0)) - (error (condition) - (format *error-output* "~&nshell benchmark failed: ~A~%" condition) - (sb-ext:exit :code 1)))) +(let* ((script-path (truename (or *load-truename* + *load-pathname* + #P"./scripts/benchmark-completion.lisp"))) + (script-directory (uiop:pathname-directory-pathname script-path)) + (root (uiop:pathname-parent-directory-pathname script-directory))) + (load (merge-pathnames #P"asdf-runtime.lisp" script-directory)) + (nshell-configure-runtime root) + (let* ((jsonl-path (uiop:getenv "NSHELL_BENCH_JSONL")) + (mode (string-downcase (or (uiop:getenv "NSHELL_BENCH_MODE") "warm")))) + (handler-case + (progn + (unless (member mode '("warm" "process" "all") :test #'string=) + (error "NSHELL_BENCH_MODE must be warm, process, or all (got ~S)" mode)) + (asdf:load-system :nshell/benchmark :force t) + (labels ((run (stream) + (when (member mode '("warm" "all") :test #'string=) + (funcall (find-symbol "RUN-COMPLETION-BENCHMARK" "NSHELL/BENCHMARK") + :jsonl-stream stream)) + (when (member mode '("process" "all") :test #'string=) + (funcall (find-symbol "RUN-PROCESS-BENCHMARK" "NSHELL/BENCHMARK") + :jsonl-stream (or stream *standard-output*))))) + (if (and jsonl-path (plusp (length jsonl-path))) + (progn + (format t "~&JSONL output: ~A~%" jsonl-path) + (let ((failure nil)) + (with-open-file (stream jsonl-path + :direction :output + :if-exists :supersede + :if-does-not-exist :create + :external-format :utf-8) + (handler-case + (run stream) + (error (condition) + (setf failure condition)))) + (when failure + (error failure)))) + (run nil))) + (sb-ext:exit :code 0)) + (error (condition) + (format *error-output* "~&nshell benchmark failed: ~A~%" condition) + (sb-ext:exit :code 1))))) diff --git a/scripts/coverage.lisp b/scripts/coverage.lisp index 417d2dc..74ee94d 100644 --- a/scripts/coverage.lisp +++ b/scripts/coverage.lisp @@ -4,11 +4,9 @@ ;;;; ;;;; nshell/test depends on sibling nerima-lisp toolkit checkouts (cl-prolog-kit, ;;;; cl-parser-kit, ...). Inside `nix develop` those systems are already on the -;;;; ASDF source registry. For a plain local checkout we also register the -;;;; parent directory tree, so sibling ghq checkouts are discovered -;;;; automatically. When CL_SOURCE_REGISTRY is present (as it is in the Nix -;;;; development shell), register only this checkout and inherit that explicit -;;;; list. Without it, register the parent tree for a plain local checkout. +;;;; ASDF source registry. Outside that shell, set NSHELL_SOURCE_TREE to one +;;;; explicit directory containing those systems, or set CL_SOURCE_REGISTRY +;;;; yourself. The shared runtime never scans a worktree parent directory. ;;;; ;;;; :force :all is required, not :force t: :force t only forces recompiling ;;;; nshell/test itself, leaving the nshell (src/) dependency loaded from @@ -16,13 +14,13 @@ ;;;; reaches src/, and the report silently covers only test files. (require :asdf) +(defparameter *nshell-coverage-script-path* + (truename (or *load-truename* *load-pathname* #P"./scripts/coverage.lisp"))) + (load (merge-pathnames #P"asdf-runtime.lisp" - (uiop:pathname-directory-pathname - (or *load-truename* *load-pathname*)))) -(nshell-configure-writable-asdf-output) - + (uiop:pathname-directory-pathname *nshell-coverage-script-path*))) (require :sb-cover) (declaim (optimize sb-cover:store-coverage-data)) @@ -30,6 +28,11 @@ (progn (defun %coverage-string-prefix-p (prefix string) (and (<= (length prefix) (length string)) (string= prefix string :end2 (length prefix)))) + (defun %coverage-call (function &rest arguments) + (handler-case + (values (apply function arguments) nil) + (error (condition) + (values nil condition)))) (defun %next-coverage-row (text start end) (let ((odd (search "" text :start2 start :end2 end)) (even (search "" text :start2 start :end2 end))) @@ -53,15 +56,22 @@ (search total-marker row :start2 (+ covered-position (length covered-marker)))))) (if (or (null covered-position) (null total-position)) (values nil nil next-row) (values - (ignore-errors - (parse-integer - row - :start - (+ covered-position (length covered-marker)) - :junk-allowed - t)) - (ignore-errors - (parse-integer row :start (+ total-position (length total-marker)) :junk-allowed t)) + (nth-value 0 + (%coverage-call + #'parse-integer + row + :start + (+ covered-position (length covered-marker)) + :junk-allowed + t)) + (nth-value 0 + (%coverage-call + #'parse-integer + row + :start + (+ total-position (length total-marker)) + :junk-allowed + t)) next-row)))))) (defun %coverage-row-file-name (text start end) (let* ((row-end (search "" text :start2 start :end2 end)) @@ -130,12 +140,26 @@ (let ((raw (uiop:getenv name))) (if (null raw) default (let ((*read-eval* nil) - (value (ignore-errors (read-from-string raw)))) + (value (nth-value 0 (%coverage-call #'read-from-string raw)))) (if (and (realp value) (<= 0 value) (<= value 100)) (float value 1.0) (error "Invalid ~A value ~S; expected a number from 0 to 100." name raw)))))) (defun %json-boolean (value) (if value "true" "false")) + (defun %default-coverage-directory (root) + (let ((nix-output (uiop:getenv "out")) + (tmpdir (uiop:getenv "TMPDIR"))) + (cond + (nix-output + (merge-pathnames + #P"coverage/" + (uiop:ensure-directory-pathname nix-output))) + (tmpdir + (merge-pathnames + #P"nshell-coverage/" + (uiop:ensure-directory-pathname tmpdir))) + (t + (merge-pathnames #P"coverage/" root))))) (defun %write-coverage-summary (pathname files covered @@ -165,17 +189,14 @@ (%json-boolean tests-passed) (%json-boolean (and (plusp total) (>= percentage minimum))) (%json-boolean (and (plusp total) (>= percentage target)))))) - (let* ((root (truename #P"./")) - (parent (uiop:pathname-parent-directory-pathname root)) - (tmpdir (uiop:getenv "TMPDIR")) + (let* ((root (uiop:pathname-parent-directory-pathname + (uiop:pathname-directory-pathname + *nshell-coverage-script-path*))) (coverage-dir (uiop:ensure-directory-pathname (or (uiop:getenv "NSHELL_COVERAGE_DIR") - (if tmpdir (merge-pathnames - #P"nshell-coverage/" - (uiop:ensure-directory-pathname tmpdir)) - (merge-pathnames #P"coverage/" root))))) + (%default-coverage-directory root)))) (index-path (merge-pathnames #P"cover-index.html" coverage-dir)) (summary-path (merge-pathnames #P"coverage-summary.json" coverage-dir)) (source-root (uiop:native-namestring (truename (merge-pathnames #P"src/" root)))) @@ -184,15 +205,7 @@ (tests-passed nil) (report-passed nil) (coverage-passed nil)) - (asdf:initialize-source-registry - (if (uiop:getenv "CL_SOURCE_REGISTRY") - `(:source-registry - (:directory ,root) - :inherit-configuration) - `(:source-registry - (:directory ,root) - (:tree ,parent) - :inherit-configuration))) + (nshell-configure-runtime root) (ensure-directories-exist coverage-dir) (sb-cover:enable-coverage-logging) (unwind-protect (setf tests-passed (handler-case @@ -252,7 +265,7 @@ (unless coverage-passed (format *error-output* - "~&src executable expression coverage did not meet the configured minimum (~,2F%%).~%" + "~&src executable expression coverage did not meet the required minimum (~,2F%%).~%" minimum)))) (sb-ext:exit :code diff --git a/scripts/weave.lisp b/scripts/weave.lisp index 05da621..e9a9984 100644 --- a/scripts/weave.lisp +++ b/scripts/weave.lisp @@ -3,35 +3,18 @@ ;;;; Usage: sbcl --script scripts/weave.lisp ;;;; ;;;; Beyond cl-weave and cl-prolog-kit, this suite also depends on cl-prolog-kit/weave. -;;;; Inside `nix develop` those systems are already on the -;;;; ASDF source registry. For a plain local checkout we also register the -;;;; parent directory tree, so sibling ghq checkouts (../cl-weave, ../cl-prolog-kit) -;;;; are discovered automatically. An explicit CL_SOURCE_REGISTRY still wins -;;;; because we inherit the existing configuration. +;;;; The ASDF source and output configuration is shared with run-tests.lisp and +;;;; the coverage and benchmark entry points. (require :asdf) -(asdf:load-system :cl-host-kit) -(load - (merge-pathnames - #P"asdf-runtime.lisp" - (uiop:pathname-directory-pathname - (or *load-truename* *load-pathname*)))) -(nshell-configure-writable-asdf-output) - -(let* ((root (truename #P"./")) - (parent (host-kit:parent-directory-pathname root))) - (asdf:initialize-source-registry - (if (host-kit:getenv "CL_SOURCE_REGISTRY") - `(:source-registry - (:directory ,root) - :inherit-configuration) - `(:source-registry - (:directory ,root) - (:tree ,parent) - :inherit-configuration))) - (setf asdf:*compile-file-warnings-behaviour* :warn - asdf:*compile-file-failure-behaviour* :warn) +(let* ((script-path (truename (or *load-truename* + *load-pathname* + #P"./scripts/weave.lisp"))) + (script-directory (uiop:pathname-directory-pathname script-path)) + (root (uiop:pathname-parent-directory-pathname script-directory))) + (load (merge-pathnames #P"asdf-runtime.lisp" script-directory)) + (nshell-configure-runtime root) (let ((passed-p (handler-case (progn diff --git a/src/application/builtin-commands.lisp b/src/application/builtin-commands.lisp index 3296967..94ab051 100644 --- a/src/application/builtin-commands.lisp +++ b/src/application/builtin-commands.lisp @@ -1,320 +1,8 @@ (in-package #:nshell.application) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro define-builtin (name lambda-list ignore-variables &body body) - `(defun ,name ,lambda-list - ,@(when ignore-variables - `((declare (ignore ,@ignore-variables)))) - ,@body))) - (define-builtin %builtin-echo (context args) (context) (values (format nil "~{~a~^ ~}~%" args) 0)) -(defun %printf-pad (text width left-p &optional (pad-character #\Space)) - (let ((padding (max 0 (- (or width 0) (length text))))) - (if (zerop padding) - text - (let ((padding-text (make-string padding :initial-element pad-character))) - (if left-p - (concatenate 'string text padding-text) - (concatenate 'string padding-text text)))))) - -(defun %printf-flag-p (flags flag) - (find flag flags :test #'char=)) - -(defun %printf-read-escape (text index) - (if (>= index (length text)) - (values "\\" index nil) - (let ((character (char text index))) - (case character - (#\a (values (string (code-char 7)) (1+ index) nil)) - (#\b (values (string #\Backspace) (1+ index) nil)) - (#\c (values "" (1+ index) t)) - (#\e (values (string (code-char 27)) (1+ index) nil)) - (#\f (values (string #\Page) (1+ index) nil)) - (#\n (values (string #\Newline) (1+ index) nil)) - (#\r (values (string #\Return) (1+ index) nil)) - (#\t (values (string #\Tab) (1+ index) nil)) - (#\v (values (string (code-char 11)) (1+ index) nil)) - (#\\ (values (string #\\) (1+ index) nil)) - (#\0 - (let ((cursor (1+ index)) - (value 0) - (digits 0)) - (loop while (and (< cursor (length text)) - (< digits 3) - (find (char text cursor) "01234567" :test #'char=)) - do (setf value (+ (* value 8) - (- (char-code (char text cursor)) - (char-code #\0))) - cursor (1+ cursor) - digits (1+ digits))) - (values (string (or (code-char value) #\Null)) cursor nil))) - (otherwise (values (string character) (1+ index) nil)))))) - -(defun %printf-expand-escapes (text) - (let* ((stop nil) - (result - (with-output-to-string (out) - (loop with index = 0 - while (< index (length text)) - do (if (char= (char text index) #\\) - (multiple-value-bind (replacement next-index stop-p) - (%printf-read-escape text (1+ index)) - (write-string replacement out) - (setf index next-index - stop stop-p) - (when stop - (return))) - (progn - (write-char (char text index) out) - (incf index))))))) - (values result stop))) - -(defun %printf-parse-integer (argument) - (handler-case - (values (parse-integer argument :junk-allowed nil) t) - (error () (values 0 nil)))) - -(defun %printf-parse-real (argument) - (handler-case - (let ((*read-eval* nil)) - (multiple-value-bind (value position) - (read-from-string argument nil nil) - (if (and (realp value) - (= position (length argument))) - (values (coerce value 'double-float) t) - (values 0d0 nil)))) - (error () (values 0d0 nil)))) - -(defun %printf-integer-text (number conversion flags precision) - (let* ((negative (minusp number)) - (unsigned (if negative (abs number) number)) - (base (case conversion - ((#\x #\X) 16) - (#\o 8) - (otherwise 10))) - (digits (case base - (16 (format nil "~x" unsigned)) - (8 (format nil "~o" unsigned)) - (otherwise (format nil "~d" unsigned)))) - (digits (if (char= conversion #\X) - (string-upcase digits) - digits)) - (digits (if precision - (concatenate 'string - (make-string (max 0 (- precision (length digits))) - :initial-element #\0) - digits) - digits)) - (prefix (if (and (%printf-flag-p flags #\#) - (not (zerop unsigned))) - (case conversion - (#\x "0x") - (#\X "0X") - (#\o "0") - (otherwise "")) - "")) - (sign (cond - (negative "-") - ((%printf-flag-p flags #\+) "+") - ((%printf-flag-p flags #\Space) " ") - (t "")))) - (concatenate 'string sign prefix digits))) - -(defun %printf-format-value (argument conversion flags width precision) - (case conversion - (#\s - (values (%printf-pad (if precision - (subseq argument 0 (min precision (length argument))) - argument) - width - (%printf-flag-p flags #\-)) - t - nil)) - (#\b - (multiple-value-bind (text stop-p) (%printf-expand-escapes argument) - (values (%printf-pad (if precision - (subseq text 0 (min precision (length text))) - text) - width - (%printf-flag-p flags #\-)) - t - stop-p))) - (#\c - (values (%printf-pad (if (plusp (length argument)) - (string (char argument 0)) - (string #\Null)) - width - (%printf-flag-p flags #\-)) - t - nil)) - ((#\d #\i #\u #\o #\x #\X) - (multiple-value-bind (number valid-p) (%printf-parse-integer argument) - (values (%printf-pad (%printf-integer-text number conversion flags precision) - width - (%printf-flag-p flags #\-) - (if (and (%printf-flag-p flags #\0) - (not (%printf-flag-p flags #\-)) - (null precision)) - #\0 - #\Space)) - valid-p - nil))) - ((#\e #\E #\f #\g #\G) - (multiple-value-bind (number valid-p) (%printf-parse-real argument) - (let* ((digits (or precision 6)) - (directive (case conversion - ((#\e #\E) "e") - ((#\g #\G) "g") - (otherwise "f"))) - (text (format nil - (concatenate 'string "~," (princ-to-string digits) directive) - number)) - (text (if (and (member conversion '(#\E #\G)) - (position #\e text)) - (substitute #\E #\e text) - text)) - (text (if (and (not (minusp number)) - (%printf-flag-p flags #\+)) - (concatenate 'string "+" text) - (if (and (not (minusp number)) - (%printf-flag-p flags #\Space)) - (concatenate 'string " " text) - text)))) - (values (%printf-pad text width (%printf-flag-p flags #\-) - (if (and (%printf-flag-p flags #\0) - (not (%printf-flag-p flags #\-))) - #\0 - #\Space)) - valid-p - nil)))) - (otherwise (values "" nil nil)))) - -(defun %printf-format-once (format-string arguments) - (let ((format-index 0) - (argument-index 0) - (argument-conversion-p nil) - (valid-p t) - (stop-p nil)) - (values - (with-output-to-string (out) - (loop while (< format-index (length format-string)) - do (let ((character (char format-string format-index))) - (if (char/= character #\%) - (if (char= character #\\) - (multiple-value-bind (replacement next-index escape-stop-p) - (%printf-read-escape format-string (1+ format-index)) - (write-string replacement out) - (setf format-index next-index - stop-p escape-stop-p) - (when stop-p - (return))) - (progn - (write-char character out) - (incf format-index))) - (progn - (incf format-index) - (if (>= format-index (length format-string)) - (progn - (setf valid-p nil) - (return)) - (if (char= (char format-string format-index) #\%) - (progn - (write-char #\% out) - (incf format-index)) - (let ((flags "")) - (loop while (and (< format-index (length format-string)) - (find (char format-string format-index) - "-+0# " - :test #'char=)) - do (setf flags - (concatenate 'string - flags - (string (char format-string format-index))) - format-index (1+ format-index))) - (let ((width-start format-index) - (precision nil)) - (loop while (and (< format-index (length format-string)) - (digit-char-p (char format-string format-index))) - do (incf format-index)) - (let ((width (when (> format-index width-start) - (parse-integer format-string - :start width-start - :end format-index)))) - (when (and (< format-index (length format-string)) - (char= (char format-string format-index) #\.)) - (incf format-index) - (let ((precision-start format-index)) - (loop while (and (< format-index (length format-string)) - (digit-char-p (char format-string format-index))) - do (incf format-index)) - (setf precision - (if (= precision-start format-index) - 0 - (parse-integer format-string - :start precision-start - :end format-index))))) - (loop while (and (< format-index (length format-string)) - (find (char format-string format-index) - "hlLjzt" - :test #'char=)) - do (incf format-index)) - (if (>= format-index (length format-string)) - (progn - (setf valid-p nil) - (return)) - (let ((conversion (char format-string format-index))) - (incf format-index) - (setf argument-conversion-p t) - (if (find conversion "sbcdiuoxXeEfFgG" - :test #'char=) - (let ((argument - (if (< argument-index (length arguments)) - (nth argument-index arguments) - ""))) - (incf argument-index) - (multiple-value-bind (text value-valid-p value-stop-p) - (%printf-format-value argument conversion flags width precision) - (write-string text out) - (unless value-valid-p - (setf valid-p nil)) - (when value-stop-p - (setf stop-p t) - (return)))) - (progn - (setf valid-p nil) - (return))))))))))))))) - argument-index - argument-conversion-p - valid-p - stop-p))) - -(define-builtin %builtin-printf (context args) (context) - (let ((arguments (if (and args (string= (first args) "--")) - (rest args) - args))) - (if (null arguments) - (values nil 0) - (let* ((format-string (first arguments)) - (remaining (rest arguments)) - (valid-p t) - (output - (with-output-to-string (out) - (loop - (multiple-value-bind (text consumed argument-conversion-p once-valid-p stop-p) - (%printf-format-once format-string remaining) - (write-string text out) - (setf valid-p (and valid-p once-valid-p) - remaining (nthcdr consumed remaining)) - (when (or stop-p - (not once-valid-p) - (null remaining) - (not argument-conversion-p)) - (return))))))) - (values output (if valid-p 0 1)))))) - (define-builtin %builtin-pwd (context args) (args) (values (format nil "~a~%" (namestring (funcall (%filesystem-fn context :cwd)))) 0)) @@ -358,16 +46,16 @@ (namestring old-cwd) (if (nshell.domain.environment:env-defined-p environment "OLDPWD") (nshell.domain.environment:env-exported-p environment "OLDPWD") - t)) - environment + t))) + (setf environment (nshell.domain.environment:env-set environment "PWD" (namestring new-cwd) (if (nshell.domain.environment:env-defined-p environment "PWD") (nshell.domain.environment:env-exported-p environment "PWD") - t)) - (shell-context-environment context) environment)) + t))) + (setf (shell-context-environment context) environment)) (values (when (and args (string= (first args) "-")) (format nil "~a~%" (namestring new-cwd))) 0)))) @@ -377,8 +65,8 @@ (defun %parse-exit-status (argument) (handler-case (values (mod (parse-integer argument :junk-allowed nil) 256) t) - (error () - (values nil nil)))) + (error (condition) + (values nil nil condition)))) (define-builtin %builtin-exit (context args) () (cond @@ -416,7 +104,13 @@ (%execute-command-by-name-in-context context command command-args) (values output (%invert-status-code code)))))) -(defun %builtin-exec (context args) (declare (ignore context)) (if args (sb-ext:quit :unix-status (nshell.infrastructure.acl:run-external-exec (first args) (rest args))) (%builtin-usage "exec" "exec command [args...]"))) +(defun %builtin-exec (context args) + (if args + (funcall (%process-fn context :exit-process) + (funcall (%process-fn context :run-external-exec) + (first args) + (rest args))) + (%builtin-usage "exec" "exec command [args...]"))) (defun %contains-usage () (%builtin-usage @@ -463,7 +157,7 @@ (error-output (values error-output 2)) ((null operands) - (values (%contains-usage) 2)) + (values (%contains-usage) 2)) (t (let* ((needle (first operands)) (values (rest operands)) diff --git a/src/application/builtin-jobs.lisp b/src/application/builtin-jobs.lisp index 1f0958b..6c76862 100644 --- a/src/application/builtin-jobs.lisp +++ b/src/application/builtin-jobs.lisp @@ -29,7 +29,8 @@ (shell-context-dispatcher context) (shell-context-process-registry context) (shell-context-terminal-fns context) - job-monitor))) + job-monitor + (shell-context-process-fns context)))) (if job (values nil 0) (values (%missing-job-output "fg" (%job-spec-label args)) 1)))) @@ -39,7 +40,8 @@ (job-id (%resolve-job-id job-monitor args :active-only-p t)) (job (bg job-id (shell-context-dispatcher context) - job-monitor))) + job-monitor + (shell-context-process-fns context)))) (if job (values nil 0) (values (%missing-job-output "bg" (%job-spec-label args)) 1)))) @@ -97,7 +99,8 @@ (type-error () nil)))) (defun %parse-positive-integer (text) (let ((value (%parse-integer-designator text))) - (and value (plusp value) value))) + (when (and value (plusp value)) + value))) (defun %find-job-id-by-pid (job-monitor pid) (let ((found nil)) (nshell.domain.job-control:monitor-map-jobs @@ -146,7 +149,10 @@ (let ((job-id (%resolve-wait-job-id job-monitor job-spec))) (multiple-value-bind (job exit-code) (if job-id - (wait-for-job job-id process-registry job-monitor) + (wait-for-job job-id + process-registry + job-monitor + (shell-context-process-fns context)) (values nil nil)) (if job (setf last-code exit-code) @@ -253,14 +259,18 @@ (string= target "-"))) (nshell.domain.job-control:monitor-resolve-job-spec job-monitor target))) -(defun %kill-one-target (job-monitor target signal) +(defun %kill-one-target (context job-monitor target signal) (let ((job-id (%resolve-kill-job-id job-monitor target))) (cond - ((and job-id (signal-job job-id signal job-monitor)) + ((and job-id + (signal-job job-id + signal + job-monitor + (shell-context-process-fns context))) t) ((let ((pid (%parse-integer-designator target))) (when pid - (nshell.infrastructure.acl:kill-process pid signal) + (funcall (%process-fn context :kill-process) pid signal) t))) (t nil)))) (defun %kill-list-output () @@ -286,6 +296,7 @@ (dolist (target targets) (handler-case (unless (%kill-one-target + context job-monitor target signal-designator) (setf code 1) (format out "kill: no such process or job: ~a~%" diff --git a/src/application/builtin-macros.lisp b/src/application/builtin-macros.lisp new file mode 100644 index 0000000..248ba09 --- /dev/null +++ b/src/application/builtin-macros.lisp @@ -0,0 +1,8 @@ +(in-package #:nshell.application) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro define-builtin (name lambda-list ignore-variables &body body) + `(defun ,name ,lambda-list + ,@(when ignore-variables + `((declare (ignore ,@ignore-variables)))) + ,@body))) diff --git a/src/application/builtin-printf-format.lisp b/src/application/builtin-printf-format.lisp new file mode 100644 index 0000000..62661cb --- /dev/null +++ b/src/application/builtin-printf-format.lisp @@ -0,0 +1,208 @@ +(in-package #:nshell.application) + +(defun %printf-pad (text width left-p &optional (pad-character #\Space)) + (let ((padding (max 0 (- (or width 0) (length text))))) + (if (zerop padding) + text + (let ((padding-text (make-string padding :initial-element pad-character))) + (if left-p + (concatenate 'string text padding-text) + (concatenate 'string padding-text text)))))) + +(defun %printf-flag-p (flags flag) + (find flag flags :test #'char=)) + +(defun %printf-read-escape (text index) + (if (>= index (length text)) + (values "\\" index nil) + (let ((character (char text index))) + (case character + (#\a (values (string (code-char 7)) (1+ index) nil)) + (#\b (values (string #\Backspace) (1+ index) nil)) + (#\c (values "" (1+ index) t)) + (#\e (values (string (code-char 27)) (1+ index) nil)) + (#\f (values (string #\Page) (1+ index) nil)) + (#\n (values (string #\Newline) (1+ index) nil)) + (#\r (values (string #\Return) (1+ index) nil)) + (#\t (values (string #\Tab) (1+ index) nil)) + (#\v (values (string (code-char 11)) (1+ index) nil)) + (#\\ (values (string #\\) (1+ index) nil)) + (#\0 + (let ((cursor (1+ index)) + (value 0) + (digits 0)) + (loop while (and (< cursor (length text)) + (< digits 3) + (find (char text cursor) "01234567" :test #'char=)) + do (setf value (+ (* value 8) + (- (char-code (char text cursor)) + (char-code #\0))) + cursor (1+ cursor) + digits (1+ digits))) + (values (string (or (code-char value) #\Null)) cursor nil))) + (otherwise (values (string character) (1+ index) nil)))))) + +(defun %printf-expand-escapes (text) + (let* ((stop nil) + (result + (with-output-to-string (out) + (loop with index = 0 + while (< index (length text)) + do (if (char= (char text index) #\\) + (multiple-value-bind (replacement next-index stop-p) + (%printf-read-escape text (1+ index)) + (write-string replacement out) + (setf index next-index + stop stop-p) + (when stop + (return))) + (progn + (write-char (char text index) out) + (incf index))))))) + (values result stop))) + +(defun %printf-parse-integer (argument) + (handler-case + (values (parse-integer argument :junk-allowed nil) t) + (error () (values 0 nil)))) + +(defun %printf-parse-real (argument) + (handler-case + (let ((*read-eval* nil)) + (multiple-value-bind (value position) + (read-from-string argument nil nil) + (if (and (realp value) + (= position (length argument))) + (values (coerce value 'double-float) t) + (values 0d0 nil)))) + (error () (values 0d0 nil)))) + +(defun %printf-integer-text (number conversion flags precision) + (let* ((negative (minusp number)) + (unsigned (if negative (abs number) number)) + (base (cond + ((or (char= conversion #\x) (char= conversion #\X)) 16) + ((char= conversion #\o) 8) + (t 10))) + (digits (case base + (16 (format nil "~x" unsigned)) + (8 (format nil "~o" unsigned)) + (otherwise (format nil "~d" unsigned)))) + (digits (cond + ((char= conversion #\X) (string-upcase digits)) + ((char= conversion #\x) (string-downcase digits)) + (t digits))) + (digits (if precision + (concatenate 'string + (make-string (max 0 (- precision (length digits))) + :initial-element #\0) + digits) + digits)) + (prefix (if (and (%printf-flag-p flags #\#) + (not (zerop unsigned))) + (cond + ((char= conversion #\x) "0x") + ((char= conversion #\X) "0X") + ((char= conversion #\o) "0") + (t "")) + "")) + (sign (cond + (negative "-") + ((%printf-flag-p flags #\+) "+") + ((%printf-flag-p flags #\Space) " ") + (t "")))) + (concatenate 'string sign prefix digits))) + +(defun %printf-truncate (text precision) + (if precision + (subseq text 0 (min precision (length text))) + text)) + +(defun %printf-format-text-value (argument flags width precision) + (%printf-pad (%printf-truncate argument precision) + width + (%printf-flag-p flags #\-))) + +(defun %printf-format-binary-value (argument flags width precision) + (multiple-value-bind (text stop-p) (%printf-expand-escapes argument) + (values (%printf-pad (%printf-truncate text precision) + width + (%printf-flag-p flags #\-)) + stop-p))) + +(defun %printf-format-character-value (argument flags width) + (%printf-pad (if (plusp (length argument)) + (string (char argument 0)) + (string #\Null)) + width + (%printf-flag-p flags #\-))) + +(defun %printf-zero-pad-p (flags precision) + (and (%printf-flag-p flags #\0) + (not (%printf-flag-p flags #\-)) + (null precision))) + +(defun %printf-format-integer-value (argument conversion flags width precision) + (multiple-value-bind (number valid-p) (%printf-parse-integer argument) + (values (%printf-pad (%printf-integer-text number conversion flags precision) + width + (%printf-flag-p flags #\-) + (if (%printf-zero-pad-p flags precision) + #\0 + #\Space)) + valid-p))) + +(defun %printf-real-text (number conversion flags precision) + (let* ((digits (or precision 6)) + (text (cond + ((or (char= conversion #\e) (char= conversion #\E)) + (format nil "~,vE" digits number)) + ((or (char= conversion #\g) (char= conversion #\G)) + (format nil "~,vG" digits number)) + (t + (format nil "~,vF" digits number)))) + (text (if (or (char= conversion #\E) (char= conversion #\G)) + (substitute #\E #\d (substitute #\E #\e text)) + text))) + (if (and (not (minusp number)) + (%printf-flag-p flags #\+)) + (concatenate 'string "+" text) + (if (and (not (minusp number)) + (%printf-flag-p flags #\Space)) + (concatenate 'string " " text) + text)))) + +(defun %printf-format-real-value (argument conversion flags width precision) + (multiple-value-bind (number valid-p) (%printf-parse-real argument) + (values (%printf-pad (%printf-real-text number conversion flags precision) + width + (%printf-flag-p flags #\-) + (if (and (%printf-flag-p flags #\0) + (not (%printf-flag-p flags #\-))) + #\0 + #\Space)) + valid-p))) + +(defun %printf-format-value (argument conversion flags width precision) + (cond + ((char= conversion #\s) + (values (%printf-format-text-value argument flags width precision) + t + nil)) + ((char= conversion #\b) + (multiple-value-bind (text stop-p) + (%printf-format-binary-value argument flags width precision) + (values text t stop-p))) + ((char= conversion #\c) + (values (%printf-format-character-value argument flags width) + t + nil)) + ((find conversion "diuoxX" :test #'char=) + (multiple-value-bind (text valid-p) + (%printf-format-integer-value argument conversion flags width precision) + (values text valid-p nil))) + ((find conversion "eEfgG" :test #'char=) + (multiple-value-bind (text valid-p) + (%printf-format-real-value argument conversion flags width precision) + (values text valid-p nil))) + (t (values "" nil nil)))) diff --git a/src/application/builtin-printf-parser.lisp b/src/application/builtin-printf-parser.lisp new file mode 100644 index 0000000..105891a --- /dev/null +++ b/src/application/builtin-printf-parser.lisp @@ -0,0 +1,113 @@ +(in-package #:nshell.application) + +(defun %printf-read-flags (text index) + (let ((start index)) + (loop while (and (< index (length text)) + (find (char text index) "-+0# " :test #'char=)) + do (incf index)) + (values (subseq text start index) index))) + +(defun %printf-read-decimal (text index) + (let ((start index)) + (loop while (and (< index (length text)) + (digit-char-p (char text index))) + do (incf index)) + (values (when (> index start) + (parse-integer text :start start :end index)) + index))) + +(defun %printf-read-precision (text index) + (if (and (< index (length text)) + (char= (char text index) #\.)) + (multiple-value-bind (precision next-index) + (%printf-read-decimal text (1+ index)) + (values (or precision 0) next-index)) + (values nil index))) + +(defun %printf-skip-length (text index) + (loop while (and (< index (length text)) + (find (char text index) "hlLjzt" :test #'char=)) + do (incf index)) + index) + +(defun %printf-read-directive (text index) + (multiple-value-bind (flags index) (%printf-read-flags text index) + (multiple-value-bind (width index) (%printf-read-decimal text index) + (multiple-value-bind (precision index) (%printf-read-precision text index) + (setf index (%printf-skip-length text index)) + (if (>= index (length text)) + (values flags width precision nil index nil) + (values flags width precision (char text index) (1+ index) t)))))) + +(defun %printf-conversion-p (conversion) + (and conversion + (find conversion "sbcdiuoxXeEfFgG" :test #'char=))) + +(defun %printf-emit-directive (out format-string index arguments argument-index) + (multiple-value-bind (flags width precision conversion next-index directive-p) + (%printf-read-directive format-string index) + (cond + ((not directive-p) + (values next-index argument-index nil nil nil)) + ((not (%printf-conversion-p conversion)) + (values next-index argument-index nil nil t)) + (t + (let ((argument (if (< argument-index (length arguments)) + (nth argument-index arguments) + ""))) + (multiple-value-bind (text value-valid-p value-stop-p) + (%printf-format-value argument conversion flags width precision) + (write-string text out) + (values next-index (1+ argument-index) + value-valid-p value-stop-p t))))))) + +(defun %printf-format-once (format-string arguments) + (let ((format-index 0) + (argument-index 0) + (argument-conversion-p nil) + (valid-p t) + (stop-p nil)) + (values + (with-output-to-string (out) + (loop while (< format-index (length format-string)) + do (let ((character (char format-string format-index))) + (cond + ((char/= character #\%) + (if (char= character #\\) + (multiple-value-bind (replacement next-index escape-stop-p) + (%printf-read-escape format-string (1+ format-index)) + (write-string replacement out) + (setf format-index next-index + stop-p escape-stop-p) + (when stop-p + (return))) + (progn + (write-char character out) + (incf format-index)))) + (t + (incf format-index) + (cond + ((>= format-index (length format-string)) + (setf valid-p nil) + (return)) + ((char= (char format-string format-index) #\%) + (write-char #\% out) + (incf format-index)) + (t + (multiple-value-bind (next-index next-argument-index + directive-valid-p directive-stop-p + directive-argument-p) + (%printf-emit-directive out format-string format-index + arguments argument-index) + (setf format-index next-index + argument-index next-argument-index + argument-conversion-p + (or argument-conversion-p directive-argument-p) + valid-p (and valid-p directive-valid-p)) + (when (or (not directive-valid-p) directive-stop-p) + (setf stop-p directive-stop-p) + (return)))))))))) + argument-index + argument-conversion-p + valid-p + stop-p))) diff --git a/src/application/builtin-printf.lisp b/src/application/builtin-printf.lisp new file mode 100644 index 0000000..2e1782f --- /dev/null +++ b/src/application/builtin-printf.lisp @@ -0,0 +1,25 @@ +(in-package #:nshell.application) + +(define-builtin %builtin-printf (context args) (context) + (let ((arguments (if (and args (string= (first args) "--")) + (rest args) + args))) + (if (null arguments) + (values nil 0) + (let* ((format-string (first arguments)) + (remaining (rest arguments)) + (valid-p t) + (output + (with-output-to-string (out) + (loop + (multiple-value-bind (text consumed argument-conversion-p once-valid-p stop-p) + (%printf-format-once format-string remaining) + (write-string text out) + (setf valid-p (and valid-p once-valid-p) + remaining (nthcdr consumed remaining)) + (when (or stop-p + (not once-valid-p) + (null remaining) + (not argument-conversion-p)) + (return))))))) + (values output (if valid-p 0 1)))))) diff --git a/src/application/builtin-runtime.lisp b/src/application/builtin-runtime.lisp index 1580d26..77f00ae 100644 --- a/src/application/builtin-runtime.lisp +++ b/src/application/builtin-runtime.lisp @@ -94,7 +94,10 @@ :empty-directory "")) (defun %stat-path (context path) - (ignore-errors (funcall (%filesystem-fn context :stat) path))) + (handler-case + (values (funcall (%filesystem-fn context :stat) path) nil) + (error (condition) + (values nil condition)))) (defun %path-file-p (context path) (let ((fn (%optional-filesystem-fn context :file-exists-p))) diff --git a/src/application/builtin-type-helpers.lisp b/src/application/builtin-type-helpers.lisp index 3f86477..8a58434 100644 --- a/src/application/builtin-type-helpers.lisp +++ b/src/application/builtin-type-helpers.lisp @@ -18,14 +18,18 @@ (defun %type-option-p (option) (%builtin-option-like-p option)) +(defun %type-option-prefix-p (prefix option) + (and (stringp option) + (<= (length prefix) (length option)) + (equal prefix (subseq option 0 (length prefix))))) + (defun %type-option-kind (option) (cond ((%builtin-option-p option '("-a" "--all")) :all) ((%builtin-option-p option '("-s" "--short")) :short) ((%builtin-option-p option '("-f" "--no-functions")) :no-functions) ((or (string= option "--color") - (and (>= (length option) 8) - (string= option "--color=" :end1 8 :end2 8))) + (%type-option-prefix-p "--color=" option)) :color) ((%builtin-option-p option '("-q" "--query" "--quiet")) :query) ((%builtin-option-p option '("-p" "--path")) :path) @@ -36,8 +40,7 @@ (defun %type-color-enabled-p (option) (or (string= option "--color") - (and (>= (length option) 8) - (string= option "--color=" :end1 8 :end2 8) + (and (%type-option-prefix-p "--color=" option) (let ((value (subseq option 8))) (or (string= value "always") (string= value "auto")))))) @@ -53,8 +56,8 @@ (with-output-to-string (out) (dolist (line (%string-lines text)) (write-string - (nshell.presentation:highlight->ansi - (nshell.presentation:highlight-line line) + (nshell.highlight:highlight->ansi + (nshell.highlight:highlight-line line) line (nshell.domain.configuration:default-theme)) out) diff --git a/src/application/execute-pipeline-expansion.lisp b/src/application/execute-pipeline-expansion.lisp index 994e91a..fe2044a 100644 --- a/src/application/execute-pipeline-expansion.lisp +++ b/src/application/execute-pipeline-expansion.lisp @@ -22,14 +22,15 @@ arithmetic $((..)) > POSIX $(..) > bare (..) > literal character." (first forms) (let ((parts (gensym "PARTS")) (pos (gensym "POS"))) `(multiple-value-bind (,parts ,pos) ,(first forms) - (if ,pos - (values ,parts ,pos) - (%try-substitution-match ,@(rest forms)))))))) + (if ,pos + (values ,parts ,pos) + (%try-substitution-match ,@(rest forms)))))))) -(defun %make-pipeline-shell-context () +(defun %make-pipeline-shell-context (process-fns) (make-shell-context :environment (nshell.domain.environment:inject-os-environment - (nshell.domain.environment:make-default-environment)))) + (nshell.domain.environment:make-default-environment)) + :process-fns process-fns)) (defun execute-command-line (line history dispatcher) (nshell.domain.parsing:with-complete-command-line (result ast line) @@ -140,7 +141,7 @@ arithmetic $((..)) > POSIX $(..) > bare (..) > literal character." (%append-expanded-fragment-fields fields fragment-fields)))))) (defun %expand-command-name-from-fragments (command-node environment) - (nshell.domain.expansion::%single-command-name-or-error + (nshell.domain.expansion:single-command-name-or-error (nshell.domain.parsing:command-node-command command-node) (%expand-command-name-fields-from-fragments command-node environment))) @@ -206,7 +207,7 @@ arithmetic $((..)) > POSIX $(..) > bare (..) > literal character." "Run the command substitution whose opening #\( is at OPEN-PAREN. Returns (replacement next-pos) on success, or NIL when parens are empty/unbalanced. %execute-command-substitution-fields is defined later in execute-pipeline-control.lisp." - (let ((end (nshell.domain.parsing::%balanced-substitution-end value open-paren))) + (let ((end (nshell.domain.parsing:balanced-substitution-end value open-paren))) (when (and end (> end (1+ open-paren))) (values (if preserve-newlines-p (%execute-command-substitution-output diff --git a/src/application/execute-pipeline-stage-background.lisp b/src/application/execute-pipeline-stage-background.lisp index 43f574d..3e95fab 100644 --- a/src/application/execute-pipeline-stage-background.lisp +++ b/src/application/execute-pipeline-stage-background.lisp @@ -2,16 +2,25 @@ ;;; Background pipeline stage helpers. -(defun %background-process-pid (process) +(defun %background-call-process-operation (function &rest arguments) + (handler-case + (values (apply function arguments) nil) + (error (condition) + (values nil condition)))) + +(defun %background-process-pid (context process) "Return the OS PID of a background PROCESS object, or NIL if unavailable." - (ignore-errors (sb-ext:process-pid process))) + (%background-call-process-operation (%process-fn context :process-pid) process)) (defun %register-background-job (context processes command-line) "Register PROCESSES as a background job in CONTEXT's monitor and process registry. PROCESSES is a single process object (command) or a list (pipeline). -Returns the job ID, or NIL when PIDs cannot be obtained." + Returns the job ID, or NIL when PIDs cannot be obtained." (let* ((proc-list (if (listp processes) processes (list processes))) - (pids (delete nil (mapcar #'%background-process-pid proc-list)))) + (pids (delete nil + (mapcar (lambda (process) + (%background-process-pid context process)) + proc-list)))) (when pids (let ((job-id (nshell.domain.job-control:monitor-add-background-job (shell-context-job-monitor context) @@ -35,10 +44,10 @@ Returns the job ID, or NIL when PIDs cannot be obtained." (nshell.domain.parsing:pipeline-node-commands command)) (cond (error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values error 127)) (resources - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values (%process-substitution-error "is not supported in background jobs") @@ -53,8 +62,8 @@ Returns the job ID, or NIL when PIDs cannot be obtained." redirect-split)) (clean-pipeline (nshell.domain.parsing:make-pipeline-node clean-commands)) - (processes (nshell.infrastructure.acl:spawn-pipeline-async - clean-commands :redirects redirects)) + (processes (funcall (%process-fn context :spawn-pipeline-async) + clean-commands :redirects redirects)) (command-line (nshell.domain.parsing:ast-node->command-line clean-pipeline))) (when processes @@ -66,10 +75,10 @@ Returns the job ID, or NIL when PIDs cannot be obtained." (%expand-command-node-in-context context command) (cond (error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values error 127)) (resources - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values (%process-substitution-error "is not supported in background jobs") @@ -86,8 +95,8 @@ Returns the job ID, or NIL when PIDs cannot be obtained." (args (nshell.domain.parsing:command-node-arg-values clean-command)) (command-line (nshell.domain.parsing:ast-node->command-line clean-command)) - (process (nshell.infrastructure.acl:spawn-async - cmd args :redirects redirects))) + (process (funcall (%process-fn context :spawn-async) + cmd args :redirects redirects))) (when process (%register-background-job context process command-line)) (values nil 0)))))) diff --git a/src/application/execute-pipeline-stage-external.lisp b/src/application/execute-pipeline-stage-external.lisp index a51db71..e9b6343 100644 --- a/src/application/execute-pipeline-stage-external.lisp +++ b/src/application/execute-pipeline-stage-external.lisp @@ -1,8 +1,10 @@ (in-package #:nshell.application) -;; Keep the timeout variable special in this compilation unit as well so -;; SBCL does not warn when referencing the shared ACL configuration. -(declaim (special nshell.infrastructure.acl:*external-command-timeout*)) +(defun %wait-external-process-for-cleanup (context process) + (handler-case + (values (funcall (%process-fn context :process-wait) process) nil) + (error (condition) + (values nil condition)))) ;;; External process execution helpers for pipeline stages. @@ -69,17 +71,71 @@ (t *standard-input*)) opened-input))) -(defun %start-external-process-copiers (process stdout-buffer stderr-buffer) +(defstruct (%external-process-stage-plan + (:constructor %make-external-process-stage-plan + (command args input-target redirect-plan preserve-fds)) + (:conc-name %external-process-stage-plan-)) + command + args + input-target + redirect-plan + preserve-fds) + +(defun %external-process-stage-plan-from + (context command-node redirects process-substitution-resources) + (let* ((command (nshell.domain.parsing:command-node-command command-node)) + (args (%line-command-args command-node)) + (wrapper-p + (and command + (nshell.domain.parsing:redirects-require-shell-wrapper-p + redirects))) + (input-target + (unless wrapper-p + (nshell.domain.parsing:redirect-input-file-target redirects))) + (source-redirect-plan (%external-process-redirect-plan-from redirects)) + (redirect-plan + (if wrapper-p + (%make-external-process-redirect-plan + nil + :supersede + nil + :supersede + :stdout + :stderr + (%external-process-redirect-plan-merge-stderr-p + source-redirect-plan)) + source-redirect-plan)) + (effective-command (if wrapper-p "sh" command)) + (effective-args + (if wrapper-p + (list* "-c" + (nshell.domain.parsing:shell-redirect-script redirects) + "nshell-fd-wrapper" + command + args) + args)) + (preserve-fds + (%process-substitution-resource-fds + context + process-substitution-resources))) + (%make-external-process-stage-plan effective-command + effective-args + input-target + redirect-plan + preserve-fds))) + +(defun %start-external-process-copiers + (context process stdout-buffer stderr-buffer) (let ((stdout-thread - (nshell.infrastructure.acl::%start-stream-copier - (sb-ext:process-output process) + (funcall (%process-fn context :start-stream-copier) + (funcall (%process-fn context :process-output) process) stdout-buffer "nshell process stdout copier")) (stderr-thread nil)) (when stderr-buffer (setf stderr-thread - (nshell.infrastructure.acl::%start-stream-copier - (sb-ext:process-error process) + (funcall (%process-fn context :start-stream-copier) + (funcall (%process-fn context :process-error) process) stderr-buffer "nshell process stderr copier"))) (remove nil (list stdout-thread stderr-thread)))) @@ -142,109 +198,115 @@ nil) (values returned-output exit-code))))) +(defun %wait-for-external-process + (context process stdout-buffer stderr-buffer redirect-plan command) + (let ((timeout-seconds + (funcall (%process-fn context :external-command-timeout)))) + (unwind-protect + (funcall + (%process-fn context :wait-process-with-copiers) + process + (%start-external-process-copiers + context + process + stdout-buffer + stderr-buffer) + timeout-seconds + (lambda () + (%finish-external-process-output + stdout-buffer + stderr-buffer + redirect-plan + (funcall (%process-fn context :process-exit-status-code) + process))) + (lambda () + (format *error-output* + "nshell: ~a: timed out after ~a seconds~%" + command + timeout-seconds) + (%finish-external-process-output + stdout-buffer + stderr-buffer + redirect-plan + 124))) + (when (and process + (funcall (%process-fn context :process-alive-p) process)) + (%wait-external-process-for-cleanup context process))))) + +(defmacro %with-process-substitution-lifecycle + ((context resources process-started) &body body) + `(unwind-protect + (progn ,@body) + (if ,process-started + (%finish-process-substitution-resources ,context ,resources) + (%abort-process-substitution-resources ,context ,resources)))) + +(defun %execute-external-process + (context stage-plan stdin command &optional process-substitution-resources) + (let ((process-started nil)) + (%with-process-substitution-lifecycle + (context process-substitution-resources process-started) + (let* ((stdout-buffer (make-string-output-stream)) + ;; Asked once and reused: 2>&1 decides both whether a separate + ;; stderr buffer exists and what :error is. + (redirect-plan + (%external-process-stage-plan-redirect-plan stage-plan)) + (merge-stderr-p + (%external-process-redirect-plan-merge-stderr-p + redirect-plan)) + (stderr-buffer + (unless merge-stderr-p + (make-string-output-stream))) + (process + (funcall (%process-fn context :run-program) + (%external-process-stage-plan-command stage-plan) + (%external-process-stage-plan-args stage-plan) + :input stdin + :output :stream + :error (if merge-stderr-p :output :stream) + :wait nil + :search t + :preserve-fds + (%external-process-stage-plan-preserve-fds stage-plan)))) + (setf process-started t) + (%release-process-substitution-resources + context + process-substitution-resources) + (%wait-for-external-process + context + process + stdout-buffer + stderr-buffer + redirect-plan + command))))) + (defun %execute-external-pipeline-stage - (command-node input redirects &optional process-substitution-resources) + (context command-node input redirects &optional process-substitution-resources) "Execute COMMAND-NODE as an external process with optional INPUT string. Applies REDIRECTS and returns (output exit-code)." (let* ((command (nshell.domain.parsing:command-node-command command-node)) - (args (%line-command-args command-node)) - (wrapper-p - (and command - (nshell.domain.parsing:redirects-require-shell-wrapper-p - redirects))) - (input-target - (unless wrapper-p - (nshell.domain.parsing:redirect-input-file-target redirects))) - (source-redirect-plan (%external-process-redirect-plan-from redirects)) - ;; The child wrapper applies file redirects itself. Keep only the - ;; stream topology needed to route data that remains on the parent's - ;; captured stdout/stderr pipes. - (redirect-plan - (if wrapper-p - (%make-external-process-redirect-plan - nil - :supersede - nil - :supersede - :stdout - :stderr - (%external-process-redirect-plan-merge-stderr-p - source-redirect-plan)) - source-redirect-plan)) - (effective-command (if wrapper-p "sh" command)) - (effective-args - (if wrapper-p - (list* "-c" - (nshell.domain.parsing:shell-redirect-script redirects) - "nshell-fd-wrapper" - command - args) - args)) - (preserve-fds - (%process-substitution-resource-fds - process-substitution-resources)) - (process-started nil)) + (stage-plan + (%external-process-stage-plan-from + context + command-node + redirects + process-substitution-resources))) (handler-case (multiple-value-bind (stdin opened-input) - (%external-process-input-stream input-target input) + (%external-process-input-stream + (%external-process-stage-plan-input-target stage-plan) + input) (unwind-protect - (unwind-protect - (let* ((stdout-buffer (make-string-output-stream)) - ;; Asked once and reused: 2>&1 decides both whether a - ;; separate stderr buffer exists and what :error is. - (merge-stderr-p - (%external-process-redirect-plan-merge-stderr-p - redirect-plan)) - (stderr-buffer - (unless merge-stderr-p - (make-string-output-stream))) - (process (sb-ext:run-program - effective-command - effective-args - :input stdin - :output :stream - :error (if merge-stderr-p - :output - :stream) - :wait nil - :search t - :preserve-fds preserve-fds))) - (setf process-started t) - (%release-process-substitution-resources - process-substitution-resources) - (unwind-protect - (nshell.infrastructure.acl::%wait-process-with-copiers - process - (%start-external-process-copiers process - stdout-buffer - stderr-buffer) - nshell.infrastructure.acl:*external-command-timeout* - (lambda () - (%finish-external-process-output - stdout-buffer - stderr-buffer - redirect-plan - (nshell.infrastructure.acl:process-exit-status-code - process))) - (lambda () - (format *error-output* - "nshell: ~a: timed out after ~a seconds~%" - command - nshell.infrastructure.acl:*external-command-timeout*) - (%finish-external-process-output - stdout-buffer - stderr-buffer - redirect-plan - 124))) - (when (and process (sb-ext:process-alive-p process)) - (ignore-errors (sb-ext:process-wait process))))) - (when opened-input - (close opened-input))) - (if process-started - (%finish-process-substitution-resources - process-substitution-resources) - (%abort-process-substitution-resources - process-substitution-resources)))) + (%execute-external-process + context + stage-plan + stdin + command + process-substitution-resources) + (when opened-input + (close opened-input)))) (error (condition) - (%abort-process-substitution-resources process-substitution-resources) + (%abort-process-substitution-resources + context + process-substitution-resources) (values (format nil "nshell: ~a: ~a~%" command condition) 127))))) diff --git a/src/application/execute-pipeline-stage.lisp b/src/application/execute-pipeline-stage.lisp index 764f5ad..2f709c5 100644 --- a/src/application/execute-pipeline-stage.lisp +++ b/src/application/execute-pipeline-stage.lisp @@ -1,9 +1,10 @@ (in-package #:nshell.application) -(declaim (notinline nshell.infrastructure.acl:process-substitution-resource-path - nshell.infrastructure.acl:process-substitution-resource-fd)) - -(declaim (special nshell.infrastructure.acl:*external-command-timeout*)) +(defun %call-process-cleanup (function &rest arguments) + (handler-case + (values (apply function arguments) nil) + (error (condition) + (values nil condition)))) ;;; Pipeline stage execution and command expansion. ;;; execute-ast-in-context (defined in execute-pipeline-control.lisp) is @@ -35,25 +36,31 @@ (t nil))) -(defun %release-process-substitution-resources (resources) +(defun %release-process-substitution-resources (context resources) (dolist (resource resources) - (ignore-errors - (nshell.infrastructure.acl:release-process-substitution-fd resource)))) + (%call-process-cleanup + (%process-fn context :release-process-substitution-fd) + resource))) -(defun %finish-process-substitution-resources (resources) +(defun %finish-process-substitution-resources (context resources) (dolist (resource resources) - (ignore-errors - (nshell.infrastructure.acl:wait-process-substitution resource)) - (ignore-errors - (nshell.infrastructure.acl:release-process-substitution-fd resource)))) + (%call-process-cleanup + (%process-fn context :wait-process-substitution) + resource) + (%call-process-cleanup + (%process-fn context :release-process-substitution-fd) + resource))) -(defun %abort-process-substitution-resources (resources) +(defun %abort-process-substitution-resources (context resources) (dolist (resource resources) - (ignore-errors - (nshell.infrastructure.acl:close-process-substitution resource)))) + (%call-process-cleanup + (%process-fn context :close-process-substitution) + resource))) -(defun %process-substitution-resource-fds (resources) - (mapcar #'nshell.infrastructure.acl:process-substitution-resource-fd +(defun %process-substitution-resource-fds (context resources) + (mapcar (lambda (resource) + (funcall (%process-fn context :process-substitution-resource-fd) + resource)) resources)) (defun %materialize-process-substitution-in-context (context value) @@ -82,7 +89,7 @@ context commands) (when nested-resources - (%abort-process-substitution-resources nested-resources) + (%abort-process-substitution-resources context nested-resources) (return-from %materialize-process-substitution-in-context (values @@ -109,13 +116,18 @@ (nshell.domain.parsing:command-list-redirect-split-result-redirects redirect-split))) (handler-case (let ((resource - (nshell.infrastructure.acl:spawn-process-substitution - direction - clean-commands - :redirects - redirects))) + (funcall (%process-fn + context + :spawn-process-substitution) + direction + clean-commands + :redirects + redirects))) (values - (nshell.infrastructure.acl:process-substitution-resource-path + (funcall + (%process-fn + context + :process-substitution-resource-path) resource) resource nil)) @@ -145,7 +157,7 @@ (multiple-value-bind (path resource error) (%materialize-process-substitution-in-context context value) (when error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (return-from %expand-command-args-in-context (values nil nil error))) (setf args @@ -163,7 +175,7 @@ (not (null (member value '("<<" "<<-") :test #'string=)))))) (values args (nreverse resources) nil)) (nshell.domain.expansion:parameter-expansion-error (condition) - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values nil nil (format nil "nshell: ~a~%" condition)))))) @@ -203,7 +215,7 @@ command name expands to zero or multiple fields (ambiguous)." (%expand-command-node-in-context context command) (if error (progn - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (return-from %expand-command-nodes-in-context (values nil error nil))) (progn @@ -243,7 +255,7 @@ command name expands to zero or multiple fields (ambiguous)." (with-input-from-string (*standard-input* input) (%execute-clean-command-node-in-context context command-node redirects)) (%execute-clean-command-node-in-context context command-node redirects)) - (%execute-external-pipeline-stage command-node input redirects))) + (%execute-external-pipeline-stage context command-node input redirects))) (defun %execute-source-pipeline-in-context (context commands redirects) (let ((input nil) @@ -290,7 +302,7 @@ command name expands to zero or multiple fields (ambiguous)." (%restore-context-redirects context))))) (defun %execute-os-pipeline-with-process-substitutions - (clean-commands redirects resources &optional (pipefail-p nil)) + (context clean-commands redirects resources &optional (pipefail-p nil)) (let ((spawned-p nil)) (unwind-protect (handler-case @@ -299,16 +311,17 @@ command name expands to zero or multiple fields (ambiguous)." (values (with-output-to-string (*standard-output*) (multiple-value-bind (status statuses) - (nshell.infrastructure.acl:spawn-pipeline + (funcall (%process-fn context :spawn-pipeline) clean-commands :redirects redirects :pipefail-p pipefail-p :preserve-fds - (%process-substitution-resource-fds resources) + (%process-substitution-resource-fds context resources) :after-spawn (lambda () (setf spawned-p t) (%release-process-substitution-resources + context resources))) (setf exit-code (or status 0) pipeline-statuses (or statuses @@ -318,14 +331,14 @@ command name expands to zero or multiple fields (ambiguous)." (error (condition) (values (format nil "nshell: ~a~%" condition) 127 (list 127)))) (if spawned-p - (%finish-process-substitution-resources resources) - (%abort-process-substitution-resources resources))))) + (%finish-process-substitution-resources context resources) + (%abort-process-substitution-resources context resources))))) (defun execute-command-node-in-context (context command-node) (multiple-value-bind (expanded error resources) (%expand-command-node-in-context context command-node) (when error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (return-from execute-command-node-in-context (values error 127))) (let* ((redirect-split (%extract-command-redirects expanded)) (clean-command @@ -337,18 +350,25 @@ command name expands to zero or multiple fields (ambiguous)." (if resources (if (%shell-internal-command-p context clean-command) (progn - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values (%process-substitution-error "requires an external command") 127)) (%execute-external-pipeline-stage - clean-command nil redirects resources)) + context + clean-command + nil + redirects + resources)) (if (and (not (%shell-internal-command-p context clean-command)) (nshell.domain.parsing:redirects-require-shell-wrapper-p redirects)) (%execute-external-pipeline-stage - clean-command nil redirects) + context + clean-command + nil + redirects) (%execute-clean-command-node-in-context context clean-command redirects)))))) @@ -359,7 +379,7 @@ command name expands to zero or multiple fields (ambiguous)." (multiple-value-bind (expanded-commands error resources) (%expand-command-nodes-in-context context commands) (when error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (return-from execute-pipeline-node-in-context (values error 127))) (let* ((redirect-split (%extract-pipeline-redirects expanded-commands)) (clean-commands @@ -373,14 +393,15 @@ command name expands to zero or multiple fields (ambiguous)." (some (lambda (cmd) (%shell-internal-command-p context cmd)) clean-commands)) (progn - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (values (%process-substitution-error "is not supported for internal or CPS pipelines") 127)) (multiple-value-bind (output exit-code statuses) - (%execute-os-pipeline-with-process-substitutions - clean-commands redirects resources + (%execute-os-pipeline-with-process-substitutions + context + clean-commands redirects resources (shell-context-pipefail-p context)) (%record-pipeline-statuses context statuses) (values output exit-code))) @@ -396,7 +417,7 @@ command name expands to zero or multiple fields (ambiguous)." (setf output (with-output-to-string (*standard-output*) (multiple-value-bind (status statuses) - (nshell.infrastructure.acl:spawn-pipeline + (funcall (%process-fn context :spawn-pipeline) clean-commands :redirects redirects :pipefail-p @@ -409,16 +430,16 @@ command name expands to zero or multiple fields (ambiguous)." ;; -- Public pipeline API (OS-level) ------------------------------------------- -(defun execute-pipeline (pipeline-ast) +(defun execute-pipeline (pipeline-ast process-fns) "Execute a pipeline AST using OS-level pipes. Returns the last process exit code." (let ((commands (if (nshell.domain.parsing:pipeline-node-p pipeline-ast) (nshell.domain.parsing:pipeline-node-commands pipeline-ast) (list pipeline-ast)))) - (let ((context (%make-pipeline-shell-context))) + (let ((context (%make-pipeline-shell-context process-fns))) (multiple-value-bind (expanded-commands error resources) (%expand-command-nodes-in-context context commands) (when error - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (write-string error *error-output*) (return-from execute-pipeline 127)) (let* ((redirect-split (%extract-pipeline-redirects expanded-commands)) @@ -432,7 +453,7 @@ command name expands to zero or multiple fields (ambiguous)." (some (lambda (cmd) (%shell-internal-command-p context cmd)) clean-commands)) (progn - (%abort-process-substitution-resources resources) + (%abort-process-substitution-resources context resources) (write-string (%process-substitution-error "is not supported for internal commands") @@ -441,19 +462,20 @@ command name expands to zero or multiple fields (ambiguous)." (if resources (nth-value 1 - (%execute-os-pipeline-with-process-substitutions - clean-commands redirects resources + (%execute-os-pipeline-with-process-substitutions + context + clean-commands redirects resources (shell-context-pipefail-p context))) - (nshell.infrastructure.acl:spawn-pipeline + (funcall (%process-fn context :spawn-pipeline) clean-commands :redirects redirects :pipefail-p (shell-context-pipefail-p context))))))))) -(defun execute-pipeline-use-case (pipeline dispatcher) +(defun execute-pipeline-use-case (pipeline dispatcher process-fns) (when dispatcher (publish-event dispatcher (nshell.domain.events:make-pipeline-started-event pipeline nil))) - (let ((exit-code (or (execute-pipeline pipeline) 0))) + (let ((exit-code (or (execute-pipeline pipeline process-fns) 0))) (when dispatcher (publish-event dispatcher (nshell.domain.events:make-pipeline-completed-event pipeline exit-code))) diff --git a/src/application/manage-job.lisp b/src/application/manage-job.lisp index ddbe45c..ea71de0 100644 --- a/src/application/manage-job.lisp +++ b/src/application/manage-job.lisp @@ -1,10 +1,8 @@ (in-package #:nshell.application) -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :sb-posix)) - (defvar *job-monitor* (nshell.domain.job-control:make-job-monitor)) -(defvar *shell-pgid* (sb-posix:getpid)) +(defvar *job-process-fns* nil) +(defvar *shell-pgid* 0) (defvar *foreground-job-pgid* nil) (define-value-struct job-listing @@ -27,51 +25,95 @@ state status-code) +(defun %optional-job-process-fn (key) + (getf *job-process-fns* key)) + +(defun %job-process-fn (key) + (or (%optional-job-process-fn key) + (error "Missing job process capability ~s" key))) + +(defun %call-optional-job-process-fn (fn &rest args) + "Call optional process capability FN with ARGS. +Returns the capability result as the primary value and any failure condition +as the secondary value, so unsupported terminal operations remain observable +without aborting job-control cleanup." + (handler-case + (values (apply fn args) nil) + (error (condition) + (values nil condition)))) + (defun %set-acl-foreground-pgid (pgid) - (let ((symbol (find-symbol "*FOREGROUND-PGID*" "NSHELL.INFRASTRUCTURE.ACL"))) - (when symbol - (setf (symbol-value symbol) (or pgid 0)))) + (let ((fn (%optional-job-process-fn :set-foreground-pgid-state))) + (when fn + (funcall fn pgid))) (values)) (defun %continue-process-group (pgid) - (sb-posix:kill (- pgid) sb-unix:sigcont)) + (let ((fn (%optional-job-process-fn :continue-process-group))) + (when fn + (funcall fn pgid)))) + +(defun %get-foreground-pgroup () + (let ((fn (%optional-job-process-fn :get-foreground-pgroup))) + (when fn + (%call-optional-job-process-fn fn)))) + +(defun %set-foreground-pgroup (pgid) + (let ((fn (%optional-job-process-fn :set-foreground-pgroup))) + (when fn + (%call-optional-job-process-fn fn pgid)))) + +(defun %kill-process (pid signal) + (let ((fn (%optional-job-process-fn :kill-process))) + (when fn + (funcall fn pid signal)))) + +(defun %shell-process-group-id () + (or (and (integerp *shell-pgid*) + (plusp *shell-pgid*) + *shell-pgid*) + (let ((fn (%optional-job-process-fn :current-process-id))) + (and fn (%call-optional-job-process-fn fn))) + 0)) (defun fg (job-id &optional dispatcher process-registry terminal-fns - (job-monitor *job-monitor*)) + (job-monitor *job-monitor*) process-fns) "Move JOB-ID to the foreground, wait for it, then restore the shell PGID." (declare (ignore process-registry terminal-fns)) - (let ((job (%require-job job-id job-monitor))) - (when job - (let ((pgid (nshell.domain.execution:job-control-pgid job))) - (when pgid - (setf *foreground-job-pgid* pgid) - (unwind-protect - (progn - (%set-acl-foreground-pgid pgid) - (%continue-process-group pgid) - (nshell.domain.job-control:foreground-job job-monitor job-id) - (when dispatcher - (publish-event dispatcher - (nshell.domain.events:make-job-continued-event job-id))) - (%with-terminal-foreground-pgroup - pgid - (lambda () (%wait-job-pgid job job-id job-monitor)))) - (setf *foreground-job-pgid* nil) - (%set-acl-foreground-pgid nil))) - job)))) + (let ((*job-process-fns* (or process-fns *job-process-fns*))) + (let ((job (%require-job job-id job-monitor))) + (when job + (let ((pgid (nshell.domain.execution:job-control-pgid job))) + (when pgid + (setf *foreground-job-pgid* pgid) + (unwind-protect + (progn + (%set-acl-foreground-pgid pgid) + (%continue-process-group pgid) + (nshell.domain.job-control:foreground-job job-monitor job-id) + (when dispatcher + (publish-event dispatcher + (nshell.domain.events:make-job-continued-event job-id))) + (%with-terminal-foreground-pgroup + pgid + (lambda () (%wait-job-pgid job job-id job-monitor)))) + (setf *foreground-job-pgid* nil) + (%set-acl-foreground-pgid nil))) + job))))) -(defun bg (job-id &optional dispatcher (job-monitor *job-monitor*)) +(defun bg (job-id &optional dispatcher (job-monitor *job-monitor*) process-fns) "Continue JOB-ID in the background." - (let ((job (%require-job job-id job-monitor))) - (when job - (let ((pgid (nshell.domain.execution:job-control-pgid job))) - (when pgid - (%continue-process-group pgid)) - (nshell.domain.job-control:background-job job-monitor job-id) - (when dispatcher - (publish-event dispatcher - (nshell.domain.events:make-job-continued-event job-id))) - job)))) + (let ((*job-process-fns* (or process-fns *job-process-fns*))) + (let ((job (%require-job job-id job-monitor))) + (when job + (let ((pgid (nshell.domain.execution:job-control-pgid job))) + (when pgid + (%continue-process-group pgid)) + (nshell.domain.job-control:background-job job-monitor job-id) + (when dispatcher + (publish-event dispatcher + (nshell.domain.events:make-job-continued-event job-id))) + job))))) (defun jobs (&optional (job-monitor *job-monitor*)) "Return current job listings without writing to the terminal." @@ -98,10 +140,10 @@ (defun %foreground-signal-target-pgid () (let ((pgid (or *foreground-job-pgid* - (ignore-errors (nshell.infrastructure.acl:get-foreground-pgroup))))) + (%get-foreground-pgroup)))) (when (and pgid (nshell.domain.execution:valid-process-group-id-p pgid) - (/= pgid *shell-pgid*)) + (/= pgid (%shell-process-group-id))) pgid))) (defun %job-command-string (job) @@ -117,13 +159,12 @@ (otherwise "Unknown"))) (defun %with-terminal-foreground-pgroup (pgid thunk) - (let ((previous (ignore-errors (nshell.infrastructure.acl:get-foreground-pgroup)))) + (let ((previous (%get-foreground-pgroup))) (unwind-protect (progn - (ignore-errors (nshell.infrastructure.acl:set-foreground-pgroup pgid)) + (%set-foreground-pgroup pgid) (funcall thunk)) - (ignore-errors - (nshell.infrastructure.acl:set-foreground-pgroup (or previous *shell-pgid*)))))) + (%set-foreground-pgroup (or previous (%shell-process-group-id)))))) (defun %classify-job-wait-status (pid status &key stopped-p exited-p exit-status @@ -141,30 +182,22 @@ (defun %classify-job-wait-error (errno) (cond - ((= errno sb-posix:echild) + ((member errno '(:echild :no-child)) (%make-job-wait-event nil :no-child nil)) - ((= errno sb-posix:eintr) + ((member errno '(:eintr :interrupted)) (%make-job-wait-event nil :interrupted nil)) (t nil))) (defun %wait-job-pgid-event (pgid) - (handler-case - (multiple-value-bind (pid status) - (sb-posix:waitpid (- pgid) sb-posix:wuntraced) - (%classify-job-wait-status - pid status - :stopped-p #'sb-posix:wifstopped - :exited-p #'sb-posix:wifexited - :exit-status #'sb-posix:wexitstatus - :signaled-p #'sb-posix:wifsignaled - :term-signal #'sb-posix:wtermsig)) - (sb-posix:syscall-error (condition) - (let ((event - (%classify-job-wait-error - (sb-posix:syscall-errno condition)))) - (if event - event - (error condition)))))) + (multiple-value-bind (pid state detail) + (funcall (%job-process-fn :wait-job) (- pgid) :untraced t) + (case state + (:stopped (%make-job-wait-event pid :stopped nil)) + (:exited (%make-job-wait-event pid :exited detail)) + (:signaled (%make-job-wait-event pid :signaled (+ 128 detail))) + (:no-child (%make-job-wait-event nil :no-child nil)) + (:continued (%make-job-wait-event pid :continued nil)) + (otherwise (%make-job-wait-event pid :unknown nil))))) (defun %wait-job-pgid (job job-id job-monitor) (let* ((pgid (nshell.domain.execution:job-control-pgid job)) @@ -212,79 +245,77 @@ (defun %require-job (job-id &optional (job-monitor *job-monitor*)) (nshell.domain.job-control:monitor-find-job job-monitor job-id)) -(defun signal-job (job-id signal &optional (job-monitor *job-monitor*)) +(defun signal-job (job-id signal &optional (job-monitor *job-monitor*) process-fns) "Send SIGNAL to JOB-ID and synchronize the monitor after a successful signal." - (labels ((stop-signal-p (candidate) - (or (member candidate (list :sigstop :sigtstp)) - (and (integerp candidate) - (member candidate - (list sb-unix:sigstop sb-unix:sigtstp))))) - (continue-signal-p (candidate) - (or (eq candidate :sigcont) - (and (integerp candidate) - (= candidate sb-unix:sigcont)))) - (record-signal-state () - (let ((current-job - (nshell.domain.job-control:monitor-find-job - job-monitor job-id))) - (when (and current-job - (not (nshell.domain.execution:job-completed-p - current-job))) - (cond - ((stop-signal-p signal) - (nshell.domain.job-control:suspend-job - job-monitor job-id nil)) - ((and (continue-signal-p signal) - (nshell.domain.execution:job-stopped-p current-job)) - (nshell.domain.job-control:background-job - job-monitor job-id))))))) - (let ((job (%require-job job-id job-monitor))) - (when job - (let ((pgid (nshell.domain.execution:job-control-pgid job)) - (pids (nshell.domain.execution:job-known-pids job)) - (signaled-p nil)) - (if pgid - (progn - (nshell.infrastructure.acl:kill-process (- pgid) signal) - (setf signaled-p t)) - (dolist (pid pids) - (nshell.infrastructure.acl:kill-process pid signal) - (setf signaled-p t))) - (when signaled-p - (record-signal-state)) - job))))) + (let ((*job-process-fns* (or process-fns *job-process-fns*))) + (labels ((stop-signal-p (candidate) + (member candidate '(:sigstop :sigtstp))) + (continue-signal-p (candidate) + (eq candidate :sigcont)) + (record-signal-state () + (let ((current-job + (nshell.domain.job-control:monitor-find-job + job-monitor job-id))) + (when (and current-job + (not (nshell.domain.execution:job-completed-p + current-job))) + (cond + ((stop-signal-p signal) + (nshell.domain.job-control:suspend-job + job-monitor job-id nil)) + ((and (continue-signal-p signal) + (nshell.domain.execution:job-stopped-p current-job)) + (nshell.domain.job-control:background-job + job-monitor job-id))))))) + (let ((job (%require-job job-id job-monitor))) + (when job + (let ((pgid (nshell.domain.execution:job-control-pgid job)) + (pids (nshell.domain.execution:job-known-pids job)) + (signaled-p nil)) + (if pgid + (progn + (%kill-process (- pgid) signal) + (setf signaled-p t)) + (dolist (pid pids) + (%kill-process pid signal) + (setf signaled-p t))) + (when signaled-p + (record-signal-state)) + job)))))) (defun wait-for-job (job-id process-registry - &optional (job-monitor *job-monitor*)) + &optional (job-monitor *job-monitor*) process-fns) "Wait for JOB-ID using the registered SBCL process objects. The process registry is shared with the background reaper. Waiting through the same process objects avoids a second waitpid consumer and preserves the exit status when the reaper has already completed the domain job." - (let ((job (%require-job job-id job-monitor))) - (cond - ((null job) - (values nil nil)) - ((nshell.domain.execution:job-completed-p job) - (remhash job-id process-registry) - (values job - (or (nshell.domain.execution:job-exit-code job) - 0))) - (t - (let ((processes (%job-process-list (gethash job-id process-registry)))) - (if (null processes) - (values nil nil) - (progn - (%wait-job-processes processes) - (let ((exit-code (%job-process-exit-code job processes))) - (nshell.domain.job-control:complete-job - job-monitor job-id exit-code) - (remhash job-id process-registry) - (values job exit-code))))))))) + (let ((*job-process-fns* (or process-fns *job-process-fns*))) + (let ((job (%require-job job-id job-monitor))) + (cond + ((null job) + (values nil nil)) + ((nshell.domain.execution:job-completed-p job) + (remhash job-id process-registry) + (values job + (or (nshell.domain.execution:job-exit-code job) + 0))) + (t + (let ((processes (%job-process-list (gethash job-id process-registry)))) + (if (null processes) + (values nil nil) + (progn + (%wait-job-processes processes) + (let ((exit-code (%job-process-exit-code job processes))) + (nshell.domain.job-control:complete-job + job-monitor job-id exit-code) + (remhash job-id process-registry) + (values job exit-code)))))))))) (defun %job-process-exit-code (job processes) (let ((statuses (mapcar (lambda (process) - (nshell.infrastructure.acl:process-exit-status-code process)) + (let ((fn (%optional-job-process-fn :process-exit-status-code))) + (and fn (funcall fn process)))) (remove nil processes)))) (if (nshell.domain.execution:job-pipefail-p job) (or (find-if (lambda (status) @@ -295,9 +326,10 @@ exit status when the reaper has already completed the domain job." (nshell.domain.execution:job-exit-code job) 0)))) (defun %wait-job-processes (processes) - (dolist (process processes) - (when process - (sb-ext:process-wait process))) + (let ((fn (%optional-job-process-fn :process-wait))) + (dolist (process processes) + (when (and fn process) + (funcall fn process)))) processes) (defun %job-process-list (entry) (cond diff --git a/src/domain/expansion/fields.lisp b/src/domain/expansion/fields.lisp index 395dc21..63d65ae 100644 --- a/src/domain/expansion/fields.lisp +++ b/src/domain/expansion/fields.lisp @@ -96,11 +96,11 @@ returning the (possibly multiple) resulting fields." "Dispatch on STYLE and evaluate the matching form." (let ((style-var (gensym "STYLE"))) `(let ((,style-var ,style)) - (case ,style-var - ((nil) ,unquoted-form) - (:single ,single-form) - (:double ,double-form) - (t (error "Invalid quote style ~S" ,style-var)))))) + (case ,style-var + ((nil) ,unquoted-form) + (:single ,single-form) + (:double ,double-form) + (t (error "Invalid quote style ~S" ,style-var)))))) (defun expand-double-quoted (input env) "Expand INPUT as the contents of a double-quoted string. @@ -124,8 +124,8 @@ single string. Command substitution is applied by the caller before this." (boundaries nil :type list) (start nil :type (or null integer))) -(defun whitespace-field-separator-p (char) - (member char '(#\Space #\Tab #\Newline) :test #'char=)) +(defun whitespace-field-separator-p (character) + (member character '(#\Space #\Tab #\Newline) :test #'char=)) (defun whitespace-field-scanner-start-field (scanner index) (unless (whitespace-field-scanner-start scanner) @@ -200,13 +200,13 @@ single string. Command substitution is applied by the caller before this." (values nil (%command-name-candidate-error candidate (length fields)))))) -(defun %single-command-name-or-error (text fields) +(defun single-command-name-or-error (text fields) "Return one command name from FIELDS or the canonical ambiguity error." (%resolve-command-name-candidate (%make-command-name-candidate text fields))) (defun expand-command-name-by-quote-style (text style env) "Expand a command name and return either one field or an ambiguity error." - (%single-command-name-or-error + (single-command-name-or-error text (expand-command-name-fields-by-quote-style text style env))) diff --git a/src/domain/parsing/tokenizer-data.lisp b/src/domain/parsing/tokenizer-data.lisp index 661768d..d89c65d 100644 --- a/src/domain/parsing/tokenizer-data.lisp +++ b/src/domain/parsing/tokenizer-data.lisp @@ -184,7 +184,10 @@ fragments) (setf (tokenizer-state-pos state) (%token-extent-end extent)))) -(defun %balanced-substitution-end (input start) +(defun balanced-substitution-end (input start) + "Return the closing-parenthesis index for the substitution at START. + +Quotes and escaped characters do not affect the parenthesis depth." (let ((depth 0) (quote nil) (escaped nil)) @@ -208,4 +211,4 @@ (return index))))))) (defun %tokenizer-balanced-substitution-end (state start) - (%balanced-substitution-end (tokenizer-state-input state) start)) + (balanced-substitution-end (tokenizer-state-input state) start)) diff --git a/src/presentation/highlight.lisp b/src/highlight.lisp similarity index 80% rename from src/presentation/highlight.lisp rename to src/highlight.lisp index 5edd6fc..05f2e9d 100644 --- a/src/presentation/highlight.lisp +++ b/src/highlight.lisp @@ -1,23 +1,15 @@ -(in-package #:nshell.presentation) +(in-package #:nshell.highlight) -;; Highlight span value object; literal data tables live under data/. (define-value-struct %highlight-span ((start 0 :type integer) (end 0 :type integer) (role :normal :type keyword))) -;; -- Highlight roles (fish-inspired) ---------------------- (defun builtin-command-p (name) - (find name *builtin-commands* :test #'string=)) + (find name +highlight-builtin-names+ :test #'string=)) (defun classify-token-role (token-type token-value is-first-word) - "Map a token to its highlight role. Follows fish shell conventions: - - first word: command (blue) or builtin (bright blue) - - subsequent words: argument (normal/cyan for options) - - pipes/redirects: operator (yellow) - - strings/quoted: quote (orange) - - errors: error (red) - - comments: comment (gray)" + "Map a token to its syntax-highlight role." (case token-type (:word (cond @@ -64,14 +56,12 @@ role))) tokens))) -;; Rendering helpers for highlight spans. (defun fallback-highlight-control (role) (or (cdr (assoc role +fallback-highlight-ansi+ :test #'eq)) "~C[0m")) (defun theme-color->ansi (theme role) - "Convert a highlight ROLE to ANSI escape using THEME colors. - Falls back to known ANSI 16-color codes when theme lookup fails." + "Convert a highlight ROLE to ANSI escape using THEME colors." (let ((color (nshell.domain.configuration:theme-color theme role))) (if color (let ((code (nshell.infrastructure.terminal:ansi-color-code color))) @@ -83,16 +73,13 @@ (let ((result (make-string-output-stream)) (pos 0)) (dolist (span spans) - ;; Output unhighlighted gap (when (> (highlight-span-start span) pos) (write-string (subseq input pos (highlight-span-start span)) result)) - ;; Output highlighted span with color (format result "~a" (theme-color->ansi theme (highlight-span-role span))) (write-string (subseq input (highlight-span-start span) (highlight-span-end span)) result) (nshell.infrastructure.terminal:ansi-reset-style result) (setf pos (highlight-span-end span))) - ;; Output remaining text (when (< pos (length input)) (write-string (subseq input pos) result)) (get-output-stream-string result))) diff --git a/src/infrastructure/acl/process-capabilities.lisp b/src/infrastructure/acl/process-capabilities.lisp new file mode 100644 index 0000000..3e256c0 --- /dev/null +++ b/src/infrastructure/acl/process-capabilities.lisp @@ -0,0 +1,104 @@ +(in-package #:nshell.infrastructure.acl) + +;;; The application receives this table at the composition boundary. Keeping +;;; the SBCL and ACL details here lets execution depend on operations, not on +;;; a particular process implementation. + +(defun make-process-fns () + "Return the concrete process capability table for a live nshell session." + (list + :spawn-pipeline + (lambda (&rest args) + (apply #'spawn-pipeline args)) + :spawn-pipeline-async + (lambda (&rest args) + (apply #'spawn-pipeline-async args)) + :spawn-process-substitution + (lambda (&rest args) + (apply #'spawn-process-substitution args)) + ;; NOTINLINE: these two are defstruct accessors, which SBCL inlines by + ;; default. An inlined call bypasses the function cell entirely, so a + ;; test's WITH-TEMPORARY-FUNCTION mock on the accessor's symbol would be + ;; silently ignored without this declaration. + :process-substitution-resource-path + (lambda (resource) + (locally (declare (notinline process-substitution-resource-path)) + (process-substitution-resource-path resource))) + :process-substitution-resource-fd + (lambda (resource) + (locally (declare (notinline process-substitution-resource-fd)) + (process-substitution-resource-fd resource))) + :release-process-substitution-fd + (lambda (resource) + (release-process-substitution-fd resource)) + :wait-process-substitution + (lambda (resource) + (wait-process-substitution resource)) + :close-process-substitution + (lambda (resource) + (close-process-substitution resource)) + :spawn-async + (lambda (&rest args) + (apply #'spawn-async args)) + :run-program + (lambda (program args &rest options) + (apply #'sb-ext:run-program program args options)) + :process-output + (lambda (process) + (sb-ext:process-output process)) + :process-error + (lambda (process) + (sb-ext:process-error process)) + :process-alive-p + (lambda (process) + (sb-ext:process-alive-p process)) + :process-wait + (lambda (process) + (sb-ext:process-wait process)) + :process-pid + (lambda (process) + (sb-ext:process-pid process)) + :start-stream-copier + (lambda (&rest args) + (apply #'start-stream-copier args)) + :wait-process-with-copiers + (lambda (&rest args) + (apply #'wait-process-with-copiers args)) + :process-exit-status-code + (lambda (process) + (process-exit-status-code process)) + :external-command-timeout + (lambda () + *external-command-timeout*) + :run-external + (lambda (&rest args) + (apply #'run-external args)) + :run-external-capture + (lambda (&rest args) + (apply #'run-external-capture args)) + :run-external-exec + (lambda (&rest args) + (apply #'run-external-exec args)) + :exit-process + (lambda (status) + (sb-ext:quit :unix-status status)) + :kill-process + (lambda (&rest args) + (apply #'kill-process args)) + :continue-process-group + (lambda (pgid) + (kill-process (- pgid) :sigcont)) + :get-foreground-pgroup + (lambda () + (get-foreground-pgroup)) + :set-foreground-pgroup + (lambda (pgid) + (set-foreground-pgroup pgid)) + :set-foreground-pgid-state + (lambda (pgid) + (setf *foreground-pgid* (or pgid 0))) + :wait-job + (lambda (&rest args) + (apply #'wait-job args)) + :current-process-id + #'sb-posix:getpid)) diff --git a/src/infrastructure/acl/syscall-foreign.lisp b/src/infrastructure/acl/syscall-foreign.lisp index 13dea03..64a7e37 100644 --- a/src/infrastructure/acl/syscall-foreign.lisp +++ b/src/infrastructure/acl/syscall-foreign.lisp @@ -12,11 +12,6 @@ (request sb-alien:unsigned-long) (arg sb-sys:system-area-pointer)) -(defconstant +tiocgwinsz+ - #+darwin #x40087468 - #+linux #x5413 - #-(or darwin linux) 0) - (defconstant +tiocswinsz+ #+darwin #x80087467 #+linux #x5414 diff --git a/src/infrastructure/acl/syscall-process.lisp b/src/infrastructure/acl/syscall-process.lisp index 18da492..76aed2f 100644 --- a/src/infrastructure/acl/syscall-process.lisp +++ b/src/infrastructure/acl/syscall-process.lisp @@ -4,6 +4,12 @@ (defparameter *external-command-timeout* 30 "Maximum seconds for synchronous external commands. NIL disables the timeout.") +(defun %process-operation (function &rest arguments) + (handler-case + (values (apply function arguments) nil) + (error (condition) + (values nil condition)))) + (defun process-exit-status-code (proc) "Return shell-compatible exit status for an SBCL process." (let ((code (sb-ext:process-exit-code proc))) @@ -26,26 +32,24 @@ exit code, or 128+signal when it was terminated by a signal." while (plusp count) do (write-string buffer output :end count)) (when (streamp output) - (ignore-errors - (finish-output output))))) + (%process-operation #'finish-output output)))) -(defun %start-stream-copier (input output name) +(defun start-stream-copier (input output name) + "Copy INPUT to OUTPUT asynchronously and return the copier thread." (when input (sb-thread:make-thread (lambda () - (ignore-errors - (%copy-process-output input output))) + (%process-operation #'%copy-process-output input output)) :name name))) (defun %start-process-output-copier (proc output) - (%start-stream-copier (and proc (sb-ext:process-output proc)) - output - "nshell process output copier")) + (start-stream-copier (and proc (sb-ext:process-output proc)) + output + "nshell process output copier")) (defun %join-stream-copier (thread) (when thread - (ignore-errors - (sb-thread:join-thread thread)))) + (%process-operation #'sb-thread:join-thread thread))) (defun %join-process-output-copiers (copiers) (dolist (copier copiers) @@ -62,7 +66,7 @@ exit code, or 128+signal when it was terminated by a signal." do (sleep (min sleep-seconds (max 0 remaining-seconds))) (setf sleep-seconds (min 0.01 (* 2 sleep-seconds)))) (unless (sb-ext:process-alive-p proc) - (ignore-errors (sb-ext:process-wait proc)) + (%process-operation #'sb-ext:process-wait proc) t))) (defun %terminate-process (proc) @@ -73,21 +77,23 @@ exit code, or 128+signal when it was terminated by a signal." ;; negative PID can target nshells own group and terminate its host. (actual-pgid (and (integerp pid) (plusp pid) - (ignore-errors (sb-posix:getpgid pid)))) + (nth-value 0 (%process-operation #'sb-posix:getpgid pid)))) (owns-process-group-p (and (integerp actual-pgid) (plusp actual-pgid) (= pid actual-pgid)))) (flet ((terminate (signal) (if owns-process-group-p - (ignore-errors (%send-process-group-signal pid signal)) + (%process-operation #'%send-process-group-signal pid signal) (when (sb-ext:process-alive-p proc) - (ignore-errors (sb-ext:process-kill proc signal)))))) + (%process-operation #'sb-ext:process-kill proc signal))))) (terminate sb-unix:sigterm) (%wait-process-exit-with-timeout proc 0.5) (terminate sb-unix:sigkill) - (ignore-errors (sb-ext:process-wait proc)))))) + (%process-operation #'sb-ext:process-wait proc))))) -(defun %wait-process-with-copiers (proc copiers timeout-seconds success-fn timeout-fn) +(defun wait-process-with-copiers + (proc copiers timeout-seconds success-fn timeout-fn) + "Wait for PROC while joining COPIERS, calling one of the result callbacks." (unwind-protect (if (or (null timeout-seconds) (%wait-process-exit-with-timeout proc timeout-seconds)) @@ -103,7 +109,7 @@ exit code, or 128+signal when it was terminated by a signal." (defun %wait-process-with-output (proc output timeout-seconds timeout-fn) (let ((copier (%start-process-output-copier proc output))) - (%wait-process-with-copiers + (wait-process-with-copiers proc (list copier) timeout-seconds @@ -127,9 +133,11 @@ exit code, or 128+signal when it was terminated by a signal." return (subseq entry (length prefix))))) (defun %executable-file-p (path) - (ignore-errors - (not (zerop (logand (sb-posix:stat-mode (sb-posix:stat path)) - #o111))))) + (handler-case + (not (zerop (logand (sb-posix:stat-mode (sb-posix:stat path)) + #o111))) + (error (condition) + (values nil condition)))) (defun %resolve-external-command (command &optional (environment (%get-environment))) (nshell.domain.completion::%first-command-path-candidate @@ -148,6 +156,19 @@ exit code, or 128+signal when it was terminated by a signal." (defun %spawn-external-command (resolved-cmd args environment &key input output (error nil error-supplied-p)) (sb-ext:run-program resolved-cmd args :input input :output output :error (if error-supplied-p error (if *redirected-stderr* *error-output* :output)) :wait nil :search nil :environment environment)) +(defun %open-and-register-process-stream (pathname register &rest open-options) + (let ((stream nil) + (registered-p nil)) + (unwind-protect + (progn + (setf stream (apply #'open pathname open-options)) + (funcall register stream) + (setf registered-p t) + stream) + (unless registered-p + (when stream + (%process-operation #'close stream)))))) + (defun %resolve-input-redirect (redirects register) "Return the standard-input stream REDIRECTS ask for, calling REGISTER on any stream opened here so the caller can close it afterwards. With no input @@ -156,7 +177,8 @@ redirection the process inherits *STANDARD-INPUT*." (nshell.domain.parsing:redirect-input-spec redirects) (flet ((track (stream) (funcall register stream) stream)) (case kind - (:< (track (open target :direction :input :if-does-not-exist :error))) + (:< (%open-and-register-process-stream + target register :direction :input :if-does-not-exist :error)) (:<<< (track (%here-string-stream target))) ((:<< :<<-) (track (%here-document-stream target))) (t *standard-input*))))) @@ -167,10 +189,9 @@ process's own stdout, calling REGISTER on any stream opened here." (multiple-value-bind (target mode) (nshell.domain.parsing:redirect-output-spec redirects) (if target - (let ((stream (open target :direction :output - :if-exists mode :if-does-not-exist :create))) - (funcall register stream) - stream) + (%open-and-register-process-stream + target register + :direction :output :if-exists mode :if-does-not-exist :create) t))) (defun %spawn-in-own-process-group (resolved-cmd args environment input output &key (error nil error-supplied-p)) @@ -183,7 +204,7 @@ process's own stdout, calling REGISTER on any stream opened here." (when proc (let ((pid (sb-ext:process-pid proc))) (when (plusp pid) - (ignore-errors (set-process-group pid pid)))) + (%process-operation #'set-process-group pid pid))) proc))) (defun spawn-async (cmd args &key redirects) @@ -203,7 +224,7 @@ process's own stdout, calling REGISTER on any stream opened here." (format *error-output* "nshell: ~a: ~a~%" cmd err) nil)) (dolist (stream redirect-streams) - (ignore-errors (close stream))))))) + (%process-operation #'close stream)))))) (defun %foreground-external-command-timeout () "Return the timeout to apply to a foreground external command's wait: NIL @@ -255,7 +276,7 @@ normal foreground timeout policy." (format *error-output* "exec: ~a: ~a~%" cmd err) 1))) - (defun run-external (cmd args) +(defun run-external (cmd args) "Execute CMD with ARGS synchronously, printing output. Returns exit code." (handler-case (multiple-value-bind (resolved-cmd environment) @@ -264,8 +285,8 @@ normal foreground timeout policy." (%report-external-command-not-found cmd) (return-from run-external 127)) (let ((proc (%spawn-external-command resolved-cmd args environment - :input *standard-input* - :output :stream))) + :input *standard-input* + :output :stream))) (if proc (let* ((pid (sb-ext:process-pid proc)) (pgid (and (integerp pid) (plusp pid) pid)) diff --git a/src/infrastructure/acl/syscall-redirection.lisp b/src/infrastructure/acl/syscall-redirection.lisp index 4a4cab9..f45354f 100644 --- a/src/infrastructure/acl/syscall-redirection.lisp +++ b/src/infrastructure/acl/syscall-redirection.lisp @@ -28,7 +28,23 @@ (defun %close-owned-redirect-stream (stream) (when (and stream (streamp stream)) - (ignore-errors (close stream)))) + (handler-case + (values (close stream) nil) + (error (condition) + (values nil condition))))) + +(defun %install-redirect-stream (filename installer &rest open-options) + (let ((stream nil) + (installed-p nil)) + (unwind-protect + (progn + (setf stream (apply #'open filename open-options)) + (funcall installer stream) + (setf installed-p t) + stream) + (unless installed-p + (when stream + (%close-owned-redirect-stream stream)))))) (defun %release-owned-stdout () (let ((stream *redirected-stdout-owned*)) @@ -36,51 +52,47 @@ (%close-owned-redirect-stream stream)) (setf *redirected-stdout-owned* nil))) -(defun %release-owned-stderr () - (let ((stream *redirected-stderr-owned*)) - (when (and stream (not (eq stream *redirected-stdout-owned*))) - (%close-owned-redirect-stream stream)) - (setf *redirected-stderr-owned* nil))) - -(defun %release-owned-stdin () - (%close-owned-redirect-stream *redirected-stdin-owned*) - (setf *redirected-stdin-owned* nil)) - (defun redirect-output (filename mode) "Redirect *STANDARD-OUTPUT* to FILENAME until RESTORE-REDIRECTS runs. MODE is a CL :IF-EXISTS value -- :SUPERSEDE for shell `>`, :APPEND for `>>`." - (let ((stream (open filename - :direction :output - :if-exists mode - :if-does-not-exist :create))) - (%remember-redirected-stdout) - (setf *redirected-stdout-owned* stream - *standard-output* stream))) + (%install-redirect-stream + filename + (lambda (stream) + (%remember-redirected-stdout) + (setf *redirected-stdout-owned* stream + *standard-output* stream)) + :direction :output + :if-exists mode + :if-does-not-exist :create)) (defun redirect-error (filename mode) "Redirect *ERROR-OUTPUT* to FILENAME until RESTORE-REDIRECTS runs. MODE is a CL :IF-EXISTS value -- :SUPERSEDE for shell `2>`, :APPEND for `2>>`." - (let ((stream (open filename - :direction :output - :if-exists mode - :if-does-not-exist :create))) - (%remember-redirected-stderr) - (setf *redirected-stderr-owned* stream - *error-output* stream))) + (%install-redirect-stream + filename + (lambda (stream) + (%remember-redirected-stderr) + (setf *redirected-stderr-owned* stream + *error-output* stream)) + :direction :output + :if-exists mode + :if-does-not-exist :create)) (defun redirect-output-and-error (filename mode) "Redirect both *STANDARD-OUTPUT* and *ERROR-OUTPUT* to the same open stream on FILENAME, for shell `&>`/`&>>`. MODE is a CL :IF-EXISTS value." - (let ((stream (open filename - :direction :output - :if-exists mode - :if-does-not-exist :create))) - (%remember-redirected-stdout) - (%remember-redirected-stderr) - (setf *redirected-stdout-owned* stream - *redirected-stderr-owned* stream - *standard-output* stream - *error-output* stream))) + (%install-redirect-stream + filename + (lambda (stream) + (%remember-redirected-stdout) + (%remember-redirected-stderr) + (setf *redirected-stdout-owned* stream + *redirected-stderr-owned* stream + *standard-output* stream + *error-output* stream)) + :direction :output + :if-exists mode + :if-does-not-exist :create)) (defun redirect-output-to-error () (%remember-redirected-stdout) @@ -100,10 +112,14 @@ keeps it from double-closing a stream this function never owned." (defun redirect-input (filename) "Redirect *STANDARD-INPUT* to read from FILENAME until RESTORE-REDIRECTS runs, for shell `<`. Signals if FILENAME does not exist." - (let ((stream (open filename :direction :input :if-does-not-exist :error))) - (%remember-redirected-stdin) - (setf *redirected-stdin-owned* stream - *standard-input* stream))) + (%install-redirect-stream + filename + (lambda (stream) + (%remember-redirected-stdin) + (setf *redirected-stdin-owned* stream + *standard-input* stream)) + :direction :input + :if-does-not-exist :error)) (defun redirect-input-string (value) "Redirect *STANDARD-INPUT* to VALUE plus a trailing newline, for a shell diff --git a/src/package-domain.lisp b/src/package-domain.lisp index 585fe8c..fc9faa6 100644 --- a/src/package-domain.lisp +++ b/src/package-domain.lisp @@ -104,7 +104,8 @@ control-flow forms, reporting incomplete input so the reader can ask for a continuation line. A pure string-to-AST function with no filesystem access.") (:use #:cl) (:import-from #:nshell.util #:define-value-struct) - (:export #:tokenize #:shell-assignment-word-p #:parse-command-line + (:export #:tokenize #:balanced-substitution-end + #:shell-assignment-word-p #:parse-command-line #:shell-input-blank-p #:shell-word-separator-p #:shell-operator-separator-p #:shell-token-separator-p #:shell-command-separator-token-p @@ -214,6 +215,7 @@ that is what keeps expansion testable without a disk.") #:expand-variables #:expand-tilde #:expand-glob #:expand-all #:expand-by-quote-style #:expand-command-name-fields-by-quote-style + #:single-command-name-or-error #:expand-command-name-by-quote-style #:expand-double-quoted #:expand-arithmetic #:evaluate-arithmetic #:expand-braces #:argv-reference-fields #:*positional-args* diff --git a/src/package-highlight.lisp b/src/package-highlight.lisp new file mode 100644 index 0000000..400d5b4 --- /dev/null +++ b/src/package-highlight.lisp @@ -0,0 +1,12 @@ +;;; Shared syntax-highlighting package. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:nshell.highlight + (:documentation + "Syntax-highlight data and rendering shared by application and presentation.") + (:use #:cl) + (:import-from #:nshell.util #:define-value-struct) + (:export #:highlight-line + #:highlight-span-start #:highlight-span-end + #:highlight-span-role + #:highlight->ansi #:theme-color->ansi))) diff --git a/src/package-infrastructure.lisp b/src/package-infrastructure.lisp index 8411c60..7cb2310 100644 --- a/src/package-infrastructure.lisp +++ b/src/package-infrastructure.lisp @@ -12,6 +12,7 @@ stores in the shell context, which is what makes the layers above it mockable.") (:use #:cl) (:import-from #:nshell.util #:define-value-struct) (:export #:*exported-environment* + #:make-process-fns #:spawn-pipeline #:spawn-pipeline-async #:wait-job #:spawn-process-substitution #:process-substitution-resource-p @@ -36,8 +37,9 @@ stores in the shell context, which is what makes the layers above it mockable.") #:child-status #:child-status-p #:child-status-pid #:child-status-status #:reap-children #:get-terminal-size #:terminal-size-unavailable #:terminal-size-unavailable-fd - #:*external-command-timeout* - #:run-external #:run-external-capture #:run-external-exec + #:*external-command-timeout* + #:start-stream-copier #:wait-process-with-copiers + #:run-external #:run-external-capture #:run-external-exec #:process-exit-status-code #:with-git-runner #:clear-git-status-cache #:get-git-status)) diff --git a/src/package-presentation.lisp b/src/package-presentation.lisp index c6c3667..6026b23 100644 --- a/src/package-presentation.lisp +++ b/src/package-presentation.lisp @@ -7,8 +7,8 @@ "Presentation: everything the user sees and types at. Holds the line editor's input state and the reducer that advances it one key event at a time -- emacs and vi bindings, kill ring, undo, incremental history search, completion cycling --- plus syntax highlighting, autosuggestion, prompt drawing, and the REPL itself -in its interactive, batch, and script forms.") +-- plus autosuggestion, prompt drawing, and the REPL itself in its interactive, +batch, and script forms.") (:use #:cl) (:import-from #:nshell.util #:define-value-struct) (:export #:input-state #:input-state-p #:make-input-state @@ -36,9 +36,6 @@ in its interactive, batch, and script forms.") #:run-repl #:run-repl-batch #:run-repl-script #:trampoline #:render-prompt #:compute-suggestion #:accept-suggestion - #:render-completions #:apply-completion - #:highlight-line - #:highlight-span-start #:highlight-span-end - #:highlight-span-role - #:highlight->ansi #:theme-color->ansi #:segment-kind->role)) + #:render-completions #:apply-completion + #:segment-kind->role)) ) diff --git a/src/presentation/prompt-display.lisp b/src/presentation/prompt-display.lisp index 3f32f5b..c2a488b 100644 --- a/src/presentation/prompt-display.lisp +++ b/src/presentation/prompt-display.lisp @@ -1,9 +1,9 @@ (in-package #:nshell.presentation) -(defun %char-visible-width (char) - "Terminal column width of CHAR, delegating to cl-tty-kit's Unicode-aware +(defun %char-visible-width (character) + "Terminal column width of CHARACTER, delegating to cl-tty-kit's Unicode-aware classifier (control/combining -> 0, wide/emoji -> 2, otherwise 1)." - (cl-tty-kit:char-width char)) + (cl-tty-kit:char-width character)) (defun %string-visible-width (text) "Sum of the terminal column widths of the characters in TEXT." @@ -53,9 +53,9 @@ it and treats a negative WIDTH as 0." segment) else append (let ((truncated (%truncate-string-to-width text remaining))) - (when (plusp (length truncated)) - (setf remaining 0) - (list (nshell.domain.prompting:make-prompt-segment + (when (plusp (length truncated)) + (setf remaining 0) + (list (nshell.domain.prompting:make-prompt-segment truncated kind))))))) @@ -65,7 +65,8 @@ it and treats a negative WIDTH as 0." (multiple-value-bind (rows cols) (nshell.infrastructure.acl:get-terminal-size) (declare (ignore rows)) (if (plusp cols) cols 80)) - (error () 80))) + (error (condition) + (values 80 condition)))) (defun segment-kind->role (kind) "Map prompt segment kind to highlight role for theme lookup." @@ -95,7 +96,7 @@ it and treats a negative WIDTH as 0." (let ((text (nshell.domain.prompting:prompt-segment-text seg)) (kind (nshell.domain.prompting:prompt-segment-kind seg))) (format stream "~a~a" - (theme-color->ansi theme (segment-kind->role kind)) + (nshell.highlight:theme-color->ansi theme (segment-kind->role kind)) text) (nshell.infrastructure.terminal:ansi-reset-style stream)))) diff --git a/src/presentation/repl-execution-context.lisp b/src/presentation/repl-execution-context.lisp index e916a5e..290fac8 100644 --- a/src/presentation/repl-execution-context.lisp +++ b/src/presentation/repl-execution-context.lisp @@ -13,12 +13,7 @@ (not (null (host-kit:directory-exists-p path)))))) (defparameter +repl-process-fns+ - (list :run-external - (lambda (command args) - (nshell.infrastructure.acl:run-external command args)) - :run-external-capture - (lambda (command args) - (nshell.infrastructure.acl:run-external-capture command args)))) + (nshell.infrastructure.acl:make-process-fns)) (defparameter +repl-redirect-fns+ (list :redirect-output #'nshell.infrastructure.acl:redirect-output diff --git a/src/presentation/repl-output-completion-help.lisp b/src/presentation/repl-output-completion-help.lisp index 5b51a36..c43d839 100644 --- a/src/presentation/repl-output-completion-help.lisp +++ b/src/presentation/repl-output-completion-help.lisp @@ -59,9 +59,6 @@ (setf (gethash (first spec) cache) t)))) "Set of catalogued external commands that should be enriched from help output.") -(defun %completion-help-catalogued-command-p (command) - (gethash command *completion-help-catalog-command-cache*)) - (defun %completion-help-text-p (output) (and (stringp output) (plusp (length output)) @@ -97,8 +94,8 @@ (multiple-value-bind (output exit-code) (funcall *completion-help-fetcher* command) (%completion-help-cache-help-text command output exit-code)) - (error () - :missing))) + (error (condition) + (values :missing condition)))) (progn (defun %warm-command-completion-help (command) diff --git a/src/presentation/repl-rendering.lisp b/src/presentation/repl-rendering.lisp index 32ce750..7625799 100644 --- a/src/presentation/repl-rendering.lisp +++ b/src/presentation/repl-rendering.lisp @@ -33,9 +33,12 @@ (format t "~C[7m~a~C[27m" #\Esc segment #\Esc) (handler-case (format t "~a" - (highlight->ansi (highlight-line segment) segment theme)) - (error () - (format t "~a" segment)))) + (nshell.highlight:highlight->ansi + (nshell.highlight:highlight-line segment) + segment theme)) + (error (condition) + (format t "~a" segment) + (values nil condition)))) (setf local-start local-end)))) (defun render-edit-buffer (text theme &key selection-start selection-end) @@ -81,7 +84,8 @@ (setf *prompt-rendered-origin-row* row *prompt-rendered-origin-column* column)) (setf *prompt-rendered-origin-known-p* t)) - (error () nil))) + (error (condition) + (values nil condition)))) (unless *prompt-rendered-origin-known-p* (setf *prompt-rendered-origin-row* 1 *prompt-rendered-origin-column* 1 @@ -114,7 +118,7 @@ (let* ((terminal-width (multiple-value-bind (rows cols) (handler-case (nshell.infrastructure.acl:get-terminal-size) - (error () (values 24 80))) + (error (condition) (values 24 80 condition))) (declare (ignore rows)) cols)) (prompt-width @@ -160,5 +164,5 @@ *prompt-rendered-cursor-row* (rendered-position-row cursor-position) *prompt-rendered-terminal-width* terminal-width *prompt-rendered-prompt-width* prompt-width)) - (finish-output) - (lambda () (read-key-cont)))) + (finish-output) + (lambda () (read-key-cont)))) diff --git a/t/integration/test-file-config.lisp b/t/integration/test-file-config.lisp index 4aee6e1..5846fd2 100644 --- a/t/integration/test-file-config.lisp +++ b/t/integration/test-file-config.lisp @@ -3,63 +3,62 @@ (describe "file-config-tests" (it "file-config-missing-file" "Loading a missing config file returns NIL." - (let* ((test-path (format nil "/tmp/nshell-test-config-missing-~d.lisp" - (random 1000000)))) - (unwind-protect - (progn - (setf nshell.infrastructure.persistence::*config-file-path-override* - (pathname test-path)) - (when (probe-file test-path) - (delete-file test-path)) - (expect (nshell.infrastructure.persistence:load-config) :to-be-null)) - (setf nshell.infrastructure.persistence::*config-file-path-override* nil) - (when (probe-file test-path) - (delete-file test-path))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "config-missing.lisp" directory))) + (unwind-protect + (progn + (setf nshell.infrastructure.persistence::*config-file-path-override* + test-path) + (when (probe-file test-path) + (delete-file test-path)) + (expect (nshell.infrastructure.persistence:load-config) :to-be-null)) + (setf nshell.infrastructure.persistence::*config-file-path-override* nil) + (when (probe-file test-path) + (delete-file test-path)))))) (it "file-config-roundtrip" "Saving and loading config preserves the stored lines." - (let* ((test-path (format nil "/tmp/nshell-test-config-~d.lisp" - (random 1000000))) - (config '("set -g prompt nshell" - "export PATH=/usr/local/bin:$PATH" - ""))) - (unwind-protect - (progn - (setf nshell.infrastructure.persistence::*config-file-path-override* - (pathname test-path)) - (when (probe-file test-path) - (delete-file test-path)) - (expect t :to-be (nshell.infrastructure.persistence:save-config config)) - (expect config :to-equal (nshell.infrastructure.persistence:load-config))) - (setf nshell.infrastructure.persistence::*config-file-path-override* nil) - (when (probe-file test-path) - (delete-file test-path))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "config.lisp" directory)) + (config '("set -g prompt nshell" + "export PATH=/usr/local/bin:$PATH" + ""))) + (unwind-protect + (progn + (setf nshell.infrastructure.persistence::*config-file-path-override* + test-path) + (when (probe-file test-path) + (delete-file test-path)) + (expect t :to-be (nshell.infrastructure.persistence:save-config config)) + (expect config :to-equal (nshell.infrastructure.persistence:load-config))) + (setf nshell.infrastructure.persistence::*config-file-path-override* nil) + (when (probe-file test-path) + (delete-file test-path)))))) (it "interactive-startup-sources-config" "Interactive initialization applies .nshellrc through the normal source boundary." - (let* ((config-path (format nil "/tmp/nshell-test-startup-config-~d.lisp" - (random 1000000))) - (history-path (format nil "/tmp/nshell-test-startup-history-~d" - (random 1000000)))) - (unwind-protect - (progn - (with-open-file (stream config-path - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (write-line "set -x NSHELL_CONFIG_LOADED yes" stream)) - (setf nshell.infrastructure.persistence::*config-file-path-override* - (pathname config-path) - nshell.infrastructure.persistence::*history-file-path-override* - (pathname history-path)) - (nshell.presentation::initialize-repl-state) - (expect "yes" :to-equal (repl-test-env "NSHELL_CONFIG_LOADED"))) - (setf nshell.infrastructure.persistence::*config-file-path-override* nil - nshell.infrastructure.persistence::*history-file-path-override* nil) - (when (probe-file config-path) - (delete-file config-path)) - (when (probe-file history-path) - (delete-file history-path))))) + (host-kit:with-temporary-directory (directory) + (let ((config-path (merge-pathnames "startup-config.lisp" directory)) + (history-path (merge-pathnames "startup-history" directory))) + (unwind-protect + (progn + (with-open-file (stream config-path + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (write-line "set -x NSHELL_CONFIG_LOADED yes" stream)) + (setf nshell.infrastructure.persistence::*config-file-path-override* + config-path + nshell.infrastructure.persistence::*history-file-path-override* + history-path) + (nshell.presentation::initialize-repl-state) + (expect "yes" :to-equal (repl-test-env "NSHELL_CONFIG_LOADED"))) + (setf nshell.infrastructure.persistence::*config-file-path-override* nil + nshell.infrastructure.persistence::*history-file-path-override* nil) + (when (probe-file config-path) + (delete-file config-path)) + (when (probe-file history-path) + (delete-file history-path)))))) (it "interactive-config-reports-nonzero-status" "A nonzero sourced config status is reported on standard error." (with-temporary-functions diff --git a/t/integration/test-file-history.lisp b/t/integration/test-file-history.lisp index 8aa4464..e2dd88d 100644 --- a/t/integration/test-file-history.lisp +++ b/t/integration/test-file-history.lisp @@ -3,64 +3,65 @@ (describe "file-history-tests" (it "file-history-append" "Appending to file history works" - (let* ((test-path (format nil "/tmp/nshell-test-history-~d.lisp" (random 1000000)))) - (unwind-protect - (progn - ;; Override history file path for test isolation - (setf nshell.infrastructure.persistence:*history-file-path-override* - (pathname test-path)) - ;; Clean up any previous test data - (when (probe-file test-path) (delete-file test-path)) - (nshell.infrastructure.persistence:append-history-entry "test command") - (let ((loaded (nshell.infrastructure.persistence:load-history-file))) - (expect (consp loaded) :to-be-truthy) - (expect "test command" :to-equal (first loaded)))) - ;; Cleanup - (setf nshell.infrastructure.persistence:*history-file-path-override* nil) - (when (probe-file test-path) (delete-file test-path))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "history.lisp" directory))) + (unwind-protect + (progn + ;; Override history file path for test isolation + (setf nshell.infrastructure.persistence:*history-file-path-override* + test-path) + ;; Clean up any previous test data + (when (probe-file test-path) (delete-file test-path)) + (nshell.infrastructure.persistence:append-history-entry "test command") + (let ((loaded (nshell.infrastructure.persistence:load-history-file))) + (expect (consp loaded) :to-be-truthy) + (expect "test command" :to-equal (first loaded)))) + ;; Cleanup + (setf nshell.infrastructure.persistence:*history-file-path-override* nil) + (when (probe-file test-path) (delete-file test-path)))))) (it "file-history-multiline-round-trip" "Multiline command history survives persistence." - (let* ((test-path (format nil "/tmp/nshell-test-history-multiline-~d.lisp" - (random 1000000))) - (command (format nil "for item in one two~% echo $item~%done"))) - (unwind-protect - (progn - (setf nshell.infrastructure.persistence:*history-file-path-override* - (pathname test-path)) - (when (probe-file test-path) (delete-file test-path)) - (nshell.infrastructure.persistence:append-history-entry command) - (expect (list command) :to-equal - (nshell.infrastructure.persistence:load-history-file))) - (setf nshell.infrastructure.persistence:*history-file-path-override* nil) - (when (probe-file test-path) (delete-file test-path))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "history-multiline.lisp" directory)) + (command (format nil "for item in one two~% echo $item~%done"))) + (unwind-protect + (progn + (setf nshell.infrastructure.persistence:*history-file-path-override* + test-path) + (when (probe-file test-path) (delete-file test-path)) + (nshell.infrastructure.persistence:append-history-entry command) + (expect (list command) :to-equal + (nshell.infrastructure.persistence:load-history-file))) + (setf nshell.infrastructure.persistence:*history-file-path-override* nil) + (when (probe-file test-path) (delete-file test-path)))))) (it "file-history-unframed-lines" "Unframed history records are not loaded." - (let ((test-path (format nil "/tmp/nshell-test-history-unframed-~d.lisp" - (random 1000000)))) - (unwind-protect - (progn - (setf nshell.infrastructure.persistence:*history-file-path-override* - (pathname test-path)) - (when (probe-file test-path) (delete-file test-path)) - (with-open-file (stream test-path :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (format stream "unframed one~%unframed two~%")) - (expect (nshell.infrastructure.persistence:load-history-file) :to-be-null)) - (setf nshell.infrastructure.persistence:*history-file-path-override* nil) - (when (probe-file test-path) (delete-file test-path))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "history-unframed.lisp" directory))) + (unwind-protect + (progn + (setf nshell.infrastructure.persistence:*history-file-path-override* + test-path) + (when (probe-file test-path) (delete-file test-path)) + (with-open-file (stream test-path :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (format stream "unframed one~%unframed two~%")) + (expect (nshell.infrastructure.persistence:load-history-file) :to-be-null)) + (setf nshell.infrastructure.persistence:*history-file-path-override* nil) + (when (probe-file test-path) (delete-file test-path)))))) (it "file-history-missing-file" "Loading a missing history file returns NIL." - (let* ((test-path (format nil "/tmp/nshell-test-history-missing-~d.lisp" - (random 1000000)))) - (unwind-protect - (progn - (setf nshell.infrastructure.persistence:*history-file-path-override* - (pathname test-path)) - (when (probe-file test-path) (delete-file test-path)) - (expect (nshell.infrastructure.persistence:load-history-file) :to-be-null)) - (setf nshell.infrastructure.persistence:*history-file-path-override* nil) - (when (probe-file test-path) (delete-file test-path)))))) + (host-kit:with-temporary-directory (directory) + (let ((test-path (merge-pathnames "history-missing.lisp" directory))) + (unwind-protect + (progn + (setf nshell.infrastructure.persistence:*history-file-path-override* + test-path) + (when (probe-file test-path) (delete-file test-path)) + (expect (nshell.infrastructure.persistence:load-history-file) :to-be-null)) + (setf nshell.infrastructure.persistence:*history-file-path-override* nil) + (when (probe-file test-path) (delete-file test-path))))))) diff --git a/t/integration/test-terminal-presentation.lisp b/t/integration/test-terminal-presentation.lisp index d986f4f..fa8738f 100644 --- a/t/integration/test-terminal-presentation.lisp +++ b/t/integration/test-terminal-presentation.lisp @@ -6,9 +6,9 @@ (dolist (line (list "echo \"hi" "echo \\")) (let ((state (input-state))) (dolist (event (read-key-events-from-string (format nil "~a~%" line))) - (multiple-value-bind (next-state output) + (multiple-value-bind (next-state output) (nshell.presentation:reduce-input-state state event) - (setf state + (setf state (if (eq output :execute) (with-parsed-command-line (result (nshell.presentation:input-state-buffer next-state)) @@ -24,50 +24,48 @@ (it "terminal-execute-on-structural-incomplete-input-indents-continuation" "REPL execution promotes structural incomplete input to an indented continuation." (with-repl-test-state - (dolist (case '(("echo hi |" . "echo hi |~% ") - ("echo hi &&" . "echo hi &&~% ") - ("if true" . "if true~% "))) - (destructuring-bind (line . expected-format) case + (dolist (line '("echo hi |" "echo hi &&" "if true")) + (let ((expected (concatenate 'string line (string #\Newline) " "))) (setf nshell.presentation::*input-state* (nshell.presentation::make-repl-input-state :buffer line)) (capture-process-output-event :execute) - (expect (format nil expected-format) :to-equal (nshell.presentation:input-state-buffer - nshell.presentation::*input-state*)) + (expect expected :to-equal (nshell.presentation:input-state-buffer + nshell.presentation::*input-state*)) (expect (length (nshell.presentation:input-state-buffer nshell.presentation::*input-state*)) :to-equal (nshell.presentation:input-state-cursor-pos nshell.presentation::*input-state*)))))) (it "terminal-highlight-uses-parser-diagnostics" "Presentation highlighting marks parser diagnostics as errors." - (let* ((spans (nshell.presentation:highlight-line "| echo nope")) + (let* ((spans (nshell.highlight:highlight-line "| echo nope")) (first-span (first spans))) (expect (null first-span) :to-be-falsy) - (expect :error :to-be (nshell.presentation:highlight-span-role first-span)) - (expect 0 :to-equal (nshell.presentation:highlight-span-start first-span)) - (expect 1 :to-equal (nshell.presentation:highlight-span-end first-span)))) + (expect :error :to-be (nshell.highlight:highlight-span-role first-span)) + (expect 0 :to-equal (nshell.highlight:highlight-span-start first-span)) + (expect 1 :to-equal (nshell.highlight:highlight-span-end first-span)))) (it "terminal-highlight-span-constructor-is-internal-boundary" "Highlight spans are produced by highlight-line rather than public raw construction." - (expect (fboundp 'nshell.presentation::make-highlight-span) :to-be-falsy) - (expect (fboundp 'nshell.presentation::highlight-span-p) :to-be-falsy) - (expect (fboundp 'nshell.presentation::copy-highlight-span) :to-be-falsy) - (expect (fboundp 'nshell.presentation::%make-highlight-span) :to-be-truthy)) + (expect (fboundp 'nshell.highlight::make-highlight-span) :to-be-falsy) + (expect (fboundp 'nshell.highlight::highlight-span-p) :to-be-falsy) + (expect (fboundp 'nshell.highlight::copy-highlight-span) :to-be-falsy) + (expect (fboundp 'nshell.highlight::%make-highlight-span) :to-be-truthy)) (it "terminal-highlight-span-type-is-internal-boundary" "Highlight spans are opaque presentation values with public projections only." - (let ((span (first (nshell.presentation:highlight-line "| echo nope")))) - (expect span :to-be-type-of 'nshell.presentation::%highlight-span) - (expect (find-symbol "HIGHLIGHT-SPAN" :nshell.presentation) :to-be-falsy))) + (let ((span (first (nshell.highlight:highlight-line "| echo nope")))) + (expect span :to-be-type-of 'nshell.highlight::%highlight-span) + (expect (find-symbol "HIGHLIGHT-SPAN" :nshell.highlight) :to-be-falsy))) (it "terminal-highlight-span-raw-accessors-stay-internal" "Highlight span projections stay behind explicit public accessors." - (let ((span (first (nshell.presentation:highlight-line "| echo nope")))) - (expect (fboundp 'nshell.presentation::%highlight-span-start) :to-be-truthy) - (expect (fboundp 'nshell.presentation::%highlight-span-end) :to-be-truthy) - (expect (fboundp 'nshell.presentation::%highlight-span-role) :to-be-truthy) - (expect (nshell.presentation:highlight-span-start span) :to-equal (nshell.presentation::%highlight-span-start span)) - (expect (nshell.presentation:highlight-span-end span) :to-equal (nshell.presentation::%highlight-span-end span)) - (expect (nshell.presentation:highlight-span-role span) :to-be (nshell.presentation::%highlight-span-role span)))) + (let ((span (first (nshell.highlight:highlight-line "| echo nope")))) + (expect (fboundp 'nshell.highlight::%highlight-span-start) :to-be-truthy) + (expect (fboundp 'nshell.highlight::%highlight-span-end) :to-be-truthy) + (expect (fboundp 'nshell.highlight::%highlight-span-role) :to-be-truthy) + (expect (nshell.highlight:highlight-span-start span) :to-equal (nshell.highlight::%highlight-span-start span)) + (expect (nshell.highlight:highlight-span-end span) :to-equal (nshell.highlight::%highlight-span-end span)) + (expect (nshell.highlight:highlight-span-role span) :to-be (nshell.highlight::%highlight-span-role span)))) (it "terminal-highlight-uses-public-ansi-boundary" "Presentation color rendering depends on the terminal ANSI public contract." diff --git a/t/support/builtins.lisp b/t/support/builtins.lisp index 9b62460..e2c941b 100644 --- a/t/support/builtins.lisp +++ b/t/support/builtins.lisp @@ -29,14 +29,18 @@ :cwd (lambda () #p"/tmp/") :chdir (lambda (path) (declare (ignore path)) t)) :process-fns - (let ((fns (list :run-external - (or external-runner - (lambda (command args) - (declare (ignore command args)) - 0))))) - (if external-capture-runner - (list* :run-external-capture external-capture-runner fns) - fns)) + ;; :run-external and :run-external-capture are listed ahead of + ;; MAKE-PROCESS-FNS's real implementations so GETF's first-match finds + ;; these fakes instead: an absent capture-runner must stay absent (NIL) + ;; so %RUN-EXTERNAL-COMMAND-IN-CONTEXT falls back to :run-external, + ;; rather than silently picking up the real external-process runner. + (list* :run-external + (or external-runner + (lambda (command args) + (declare (ignore command args)) + 0)) + :run-external-capture external-capture-runner + (nshell.infrastructure.acl:make-process-fns)) :redirect-fns (list :redirect-output #'nshell.infrastructure.acl:redirect-output :redirect-error #'nshell.infrastructure.acl:redirect-error @@ -94,13 +98,13 @@ output-empty contains) (append (when (not (null code)) - `((expect ,code :to-equal ,actual-code))) + `((expect ,actual-code :to-equal ,code))) (when output - `((expect ,output :to-equal ,actual-output))) + `((expect ,actual-output :to-equal ,output))) (when output-null `((expect ,actual-output :to-be-null))) (when output-empty - `((expect "" :to-equal ,actual-output))) + `((expect ,actual-output :to-equal ""))) (when contains `((expect (%builtin-output-contains-all-p ,actual-output ,contains) :to-be-truthy))) `((values ,actual-output ,actual-code)))) @@ -139,8 +143,8 @@ (defmacro with-builtins-source-ok ((output code context lines) expected-output &body extra-assertions) "Like WITH-BUILTINS-SOURCE but automatically asserts exit-code=0 and string output equality." `(with-builtins-source (,output ,code ,context ,lines) - (expect 0 :to-equal ,code) - (expect ,expected-output :to-equal ,output) + (expect ,code :to-equal 0) + (expect ,output :to-equal ,expected-output) ,@extra-assertions)) (defmacro with-stubbed-command-executor ((&rest cases) &body body) @@ -193,23 +197,23 @@ form should return (values output exit-code). Example: (multiple-value-bind (output code) (call-builtin ,context ,name ,add-args) (expect output :to-be-null) - (expect 0 :to-equal code)) - (expect ,expansion :to-equal (gethash ,key ,table-form)) - (expect 0 :to-equal (nth-value 1 (call-builtin ,context ,name (list "-q" ,key)))) - (expect 1 :to-equal (nth-value 1 (call-builtin ,context ,name (list "-q" ,missing-key)))) + (expect code :to-equal 0)) + (expect (gethash ,key ,table-form) :to-equal ,expansion) + (expect (nth-value 1 (call-builtin ,context ,name (list "-q" ,key))) :to-equal 0) + (expect (nth-value 1 (call-builtin ,context ,name (list "-q" ,missing-key))) :to-equal 1) ,@(when body-contains `((multiple-value-bind (output code) (call-builtin ,context ,name (list ,key)) - (expect 0 :to-equal code) + (expect code :to-equal 0) ,@(mapcar (lambda (needle) `(expect (search ,needle output) :to-be-truthy)) body-contains)))) (multiple-value-bind (output code) (call-builtin ,context ,name nil) - (expect 0 :to-equal code) + (expect code :to-equal 0) (expect (search ,list-fragment output) :to-be-truthy)) (assert-builtin-call (,context ,name '("-e")) :code 2 :output ,erase-error-output) - (expect 0 :to-equal (nth-value 1 (call-builtin ,context ,name ,erase-args))) + (expect (nth-value 1 (call-builtin ,context ,name ,erase-args)) :to-equal 0) (expect (gethash ,key ,table-form) :to-be-null))) diff --git a/t/support/pbt-shell.lisp b/t/support/pbt-shell.lisp index 61434d7..21d9193 100644 --- a/t/support/pbt-shell.lisp +++ b/t/support/pbt-shell.lisp @@ -20,21 +20,23 @@ t))) (defun %default-test-process-fns () - (list :spawn (lambda (&rest args) - (declare (ignore args)) - :spawned) - :wait (lambda (&rest args) - (declare (ignore args)) - :waited) - :signal (lambda (&rest args) + (append + (list :spawn (lambda (&rest args) (declare (ignore args)) - :signaled) - :run-external (lambda (command args) - (declare (ignore command args)) - 0) - :run-external-capture (lambda (command args) - (declare (ignore command args)) - (values nil 0)))) + :spawned) + :wait (lambda (&rest args) + (declare (ignore args)) + :waited) + :signal (lambda (&rest args) + (declare (ignore args)) + :signaled) + :run-external (lambda (command args) + (declare (ignore command args)) + 0) + :run-external-capture (lambda (command args) + (declare (ignore command args)) + (values nil 0))) + (nshell.infrastructure.acl:make-process-fns))) (defun %default-test-terminal-fns () (list :get-size (lambda () diff --git a/t/unit/test-builtins-core-io.lisp b/t/unit/test-builtins-core-io.lisp index a368719..f5dccd6 100644 --- a/t/unit/test-builtins-core-io.lisp +++ b/t/unit/test-builtins-core-io.lisp @@ -30,6 +30,113 @@ :code 0 :output (format nil "literal~%")))) + (it "printf-covers-option-escape-and-formatting-boundaries" + "printf handles its option terminator, escape forms, widths, precisions, and errors." + (with-builtins-context (context) + (assert-builtin-cases (context "printf") + (nil + :code 0 + :output-null t) + (("--" "%s" "x") + :code 0 + :output "x") + (("%b" "left\\cignored") + :code 0 + :output "left") + (("%b" "A\\010B") + :code 0 + :output (concatenate 'string "A" (string #\Backspace) "B")) + (("%b" "\\a\\b\\e\\f\\n\\r\\t\\v\\\\") + :code 0 + :output (concatenate 'string + (string (code-char 7)) + (string #\Backspace) + (string (code-char 27)) + (string #\Page) + (string #\Newline) + (string #\Return) + (string #\Tab) + (string (code-char 11)) + "\\")) + (("literal\\q") + :code 0 + :output "literalq") + (("trailing\\") + :code 0 + :output "trailing\\") + (("%%") + :code 0 + :output "%") + (("%c" "Z") + :code 0 + :output "Z") + (("%c" "") + :code 0 + :output (string #\Null)) + (("%+d" "7") + :code 0 + :output "+7") + (("% d" "7") + :code 0 + :output " 7") + (("%i" "-7") + :code 0 + :output "-7") + (("%u" "7") + :code 0 + :output "7") + (("%#o" "8") + :code 0 + :output "010") + (("%#x" "15") + :code 0 + :output "0xf") + (("%#X" "15") + :code 0 + :output "0XF") + (("%.3d" "7") + :code 0 + :output "007") + (("%05.3d" "7") + :code 0 + :output " 007") + (("%-5s" "x") + :code 0 + :output "x ") + (("%2lls" "x") + :code 0 + :output " x") + (("%.s" "x") + :code 0 + :output-empty t) + (("%f" "1.5") + :code 0 + :output (format nil "~,6f" 1.5d0)) + (("%.2f" "1.5") + :code 0 + :output (format nil "~,2f" 1.5d0)) + (("%+f" "1.5") + :code 0 + :output (concatenate 'string "+" (format nil "~,6f" 1.5d0))) + (("% f" "1.5") + :code 0 + :output (concatenate 'string " " (format nil "~,6f" 1.5d0))) + (("%E" "1.5") + :code 0 + :contains '("E")) + (("%f" "not-a-number") + :code 1 + :output (format nil "~,6f" 0d0)) + (("%q" "x") + :code 1 + :output-empty t) + (("%") + :code 1 + :output-empty t) + (("literal" "ignored") + :code 0 + :output "literal")))) + (it "pwd-returns-current-working-directory" "pwd returns the context cwd as a string with a trailing newline." (with-builtins-context (context) diff --git a/t/unit/test-builtins-source.lisp b/t/unit/test-builtins-source.lisp index dde857e..7e344ca 100644 --- a/t/unit/test-builtins-source.lisp +++ b/t/unit/test-builtins-source.lisp @@ -130,7 +130,8 @@ process)) (with-temporary-function ('nshell.application::%background-process-pid - (lambda (proc) + (lambda (ignored-context proc) + (declare (ignore ignored-context)) (when (eq proc process) 4321))) (with-called-source (output code context '("first arg & second")) @@ -170,7 +171,8 @@ processes)) (with-temporary-function ('nshell.application::%background-process-pid - (lambda (proc) + (lambda (ignored-context proc) + (declare (ignore ignored-context)) (case proc (:left-process 4321) (:right-process 4322)))) diff --git a/t/unit/test-execute-pipeline.lisp b/t/unit/test-execute-pipeline.lisp index 2c27b35..034c3b0 100644 --- a/t/unit/test-execute-pipeline.lisp +++ b/t/unit/test-execute-pipeline.lisp @@ -54,7 +54,9 @@ :process-exited :pipeline-completed) (nshell.domain.events:domain-event-type event) - (expect 0 :to-equal (nshell.application:execute-pipeline-use-case ast dispatcher)) + (expect 0 :to-equal + (nshell.application:execute-pipeline-use-case + ast dispatcher (%default-test-process-fns))) (expect (nshell.application:drain-events dispatcher) :to-be-null) (let ((delivered (nreverse events))) (expect (member :pipeline-started delivered) :to-be-truthy) @@ -69,7 +71,8 @@ (code nil) (output (with-output-to-string (*standard-output*) (setf code - (nshell.application:execute-pipeline-use-case ast nil))))) + (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 0 :to-equal code) (expect "pipeline-api" :to-equal output)))) @@ -82,7 +85,8 @@ (code nil)) (let ((error-output (with-output-to-string (*error-output*) - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 127 :to-equal code) (expect (format nil "nshell: $NSHELL_PIPELINE_CMD: command name expansion produced 2 fields~%") :to-equal error-output))))) @@ -94,7 +98,8 @@ (code nil)) (let ((error-output (with-output-to-string (*error-output*) - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 127 :to-equal code) (expect (format nil "nshell: NSHELL_MISSING_REQUIRED: required value~%") :to-equal error-output)))) @@ -138,16 +143,16 @@ (unwind-protect (progn (ensure-directories-exist root) - (expect 0 :to-equal (nshell.application:execute-pipeline-use-case ast nil)) + (expect 0 :to-equal + (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns))) (expect (probe-file output) :to-be-truthy) (with-open-file (stream output :direction :input) (let ((actual (make-string (file-length stream)))) (read-sequence actual stream) (expect content :to-equal actual)))) - (handler-case - (when (probe-file root) - (host-kit:delete-directory-tree root :validate t)) - (error ()))))) + (when (probe-file root) + (host-kit:delete-directory-tree root :validate t))))) (it "pipeline-stage-streams-opens-file-and-here-string-inputs" "Pipeline stage setup materializes file and here-string input redirects." @@ -245,7 +250,8 @@ (ast (nshell.domain.parsing:make-pipeline-node (list writer counter))) (code nil) (output (capture-standard-output - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 0 :to-equal code) (expect (format nil "3~%") :to-equal output))) @@ -259,7 +265,8 @@ (ast (nshell.domain.parsing:make-pipeline-node (list writer counter))) (code nil) (output (capture-standard-output - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 0 :to-equal code) (expect (format nil "6~%") :to-equal output))) @@ -274,7 +281,8 @@ (ast (nshell.domain.parsing:make-pipeline-node (list writer counter))) (code nil) (output (capture-standard-output - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 0 :to-equal code) (expect (format nil "3~%") :to-equal output) (expect "OUT" :to-equal (host-kit:read-file-string target))))) @@ -290,7 +298,8 @@ (ast (nshell.domain.parsing:make-pipeline-node (list writer counter))) (code nil) (output (capture-standard-output - (setf code (nshell.application:execute-pipeline-use-case ast nil))))) + (setf code (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns)))))) (expect 0 :to-equal code) (expect (format nil "0~%") :to-equal output) (expect "OUTERR" :to-equal (host-kit:read-file-string target))))) @@ -300,7 +309,9 @@ (let ((ast (nshell.domain.parsing:make-command-node "definitely-not-a-real-command" nil))) - (expect 127 :to-equal (nshell.application:execute-pipeline-use-case ast nil)))) + (expect 127 :to-equal + (nshell.application:execute-pipeline-use-case + ast nil (%default-test-process-fns))))) (it "execute-pipeline-node-in-context-times-out-external-stages-in-cps-mode" "The CPS execution path drains external output and times out long-running stages." @@ -433,7 +444,8 @@ (length (nshell.application::%process-substitution-inner-commands pipeline)))) (expect (nshell.application::%process-substitution-inner-commands nil) :to-be-null)) (it "process-substitution-resource-cleanup-is-best-effort" - (let ((released nil)) + (let ((context (make-test-shell-context)) + (released nil)) (with-temporary-functions (((quote nshell.infrastructure.acl:release-process-substitution-fd) (lambda (resource) @@ -441,10 +453,12 @@ (when (eq resource :bad) (error "release failure"))))) (nshell.application::%release-process-substitution-resources + context (list :first :bad :last))) (expect (list :last :bad :first) :to-equal released))) (it "process-substitution-finish-and-abort-release-all-resources" - (let ((waited nil) + (let ((context (make-test-shell-context)) + (waited nil) (released nil) (closed nil)) (with-temporary-functions @@ -459,8 +473,8 @@ ((quote nshell.infrastructure.acl:close-process-substitution) (lambda (resource) (push resource closed)))) - (nshell.application::%finish-process-substitution-resources (list :ok :bad)) - (nshell.application::%abort-process-substitution-resources (list :left :right))) + (nshell.application::%finish-process-substitution-resources context (list :ok :bad)) + (nshell.application::%abort-process-substitution-resources context (list :left :right))) (expect (list :bad :ok) :to-equal waited) (expect (list :bad :ok) :to-equal released) (expect (list :right :left) :to-equal closed))) @@ -472,6 +486,7 @@ (expect (list 3 4) :to-equal (nshell.application::%process-substitution-resource-fds + (make-test-shell-context) (list (list :fd 3) (list :fd 4)))))) (it "source-pipeline-exit-status-honors-pipefail" (expect 2 :to-equal (nshell.application::%source-pipeline-exit-status (list 0 2) nil)) @@ -559,7 +574,8 @@ (declare (ignore ignored-context)) (values commands nil (list :nested)))) ((quote nshell.application::%abort-process-substitution-resources) - (lambda (resources) + (lambda (ignored-context resources) + (declare (ignore ignored-context)) (setf aborted resources)))) (multiple-value-bind (path resource error) (nshell.application::%materialize-process-substitution-in-context @@ -600,8 +616,8 @@ (declare (ignore ignored-context value)) (values nil nil "substitution failed"))) ((quote nshell.application::%abort-process-substitution-resources) - (lambda (resources) - (declare (ignore resources)) + (lambda (ignored-context resources) + (declare (ignore ignored-context resources)) (setf abort-called t)))) (multiple-value-bind (args resources error) (nshell.application::%expand-command-args-in-context context command) @@ -628,7 +644,8 @@ (values command nil (list :resource)) (values nil "node failed" nil)))) ((quote nshell.application::%abort-process-substitution-resources) - (lambda (resources) + (lambda (ignored-context resources) + (declare (ignore ignored-context)) (setf aborted resources)))) (multiple-value-bind (commands error resources) (nshell.application::%expand-command-nodes-in-context @@ -639,7 +656,8 @@ (expect error :to-equal "node failed") (expect aborted :to-equal (list :resource)))))) (it "os-process-substitution-pipeline-releases-resources-after-spawn" - (let ((captured nil) + (let ((context (make-test-shell-context)) + (captured nil) (released nil) (waited nil)) (with-temporary-functions @@ -661,6 +679,7 @@ (push resource waited)))) (multiple-value-bind (output code) (nshell.application::%execute-os-pipeline-with-process-substitutions + context '(:command) nil (list :resource) @@ -671,7 +690,8 @@ (expect released :to-equal (list :resource :resource)) (expect waited :to-equal (list :resource)))))) (it "os-process-substitution-pipeline-aborts-on-spawn-failure" - (let ((closed nil)) + (let ((context (make-test-shell-context)) + (closed nil)) (with-temporary-functions (((quote nshell.infrastructure.acl:process-substitution-resource-fd) (lambda (resource) @@ -686,6 +706,7 @@ (push resource closed)))) (multiple-value-bind (output code) (nshell.application::%execute-os-pipeline-with-process-substitutions + context '(:command) nil (list :resource) @@ -703,7 +724,8 @@ (declare (ignore ignored-context ignored-command)) (values command nil (list :resource)))) ((quote nshell.application::%abort-process-substitution-resources) - (lambda (resources) + (lambda (ignored-context resources) + (declare (ignore ignored-context)) (setf aborted resources)))) (multiple-value-bind (output code) (nshell.application::execute-command-node-in-context context command) @@ -723,7 +745,8 @@ nil (list :resource)))) ((quote nshell.application::%abort-process-substitution-resources) - (lambda (resources) + (lambda (ignored-context resources) + (declare (ignore ignored-context)) (setf aborted resources)))) (multiple-value-bind (output code) (nshell.application::execute-pipeline-node-in-context context pipeline) @@ -742,8 +765,8 @@ nil (list :resource)))) ((quote nshell.application::%execute-os-pipeline-with-process-substitutions) - (lambda (commands redirects resources pipefail-p) - (declare (ignore commands redirects resources pipefail-p)) + (lambda (ignored-context commands redirects resources pipefail-p) + (declare (ignore ignored-context commands redirects resources pipefail-p)) (values "os output" 12)))) (multiple-value-bind (output code) (nshell.application::execute-pipeline-node-in-context context pipeline) diff --git a/t/unit/test-expansion.lisp b/t/unit/test-expansion.lisp index 1782e4c..ec70d6d 100644 --- a/t/unit/test-expansion.lisp +++ b/t/unit/test-expansion.lisp @@ -13,10 +13,10 @@ Each case is (EXPECTED INPUT &rest ARGS)." (let ((expander (gensym "EXPANDER-"))) `(let ((,expander ,builder)) - ,@(mapcar (lambda (case) - (destructuring-bind (expected &rest args) case - `(expect (,predicate ',expected (funcall ,expander ,@args)) :to-be-truthy))) - cases)))) + ,@(mapcar (lambda (case) + (destructuring-bind (expected &rest args) case + `(expect (,predicate ',expected (funcall ,expander ,@args)) :to-be-truthy))) + cases)))) (defmacro %assert-expansion-cases-with-env ((predicate expander env-form) &body cases) "Assert CASES against an EXPANDER that takes INPUT and ENV." @@ -25,40 +25,40 @@ Each case is (EXPECTED INPUT &rest ARGS)." (expander-fn (gensym "EXPANDER-"))) `(let ((,env ,env-form) (,expander-fn ,expander)) - (%assert-expansion-cases (,predicate - (lambda (,input) - (funcall ,expander-fn ,input ,env))) - ,@cases)))) + (%assert-expansion-cases (,predicate + (lambda (,input) + (funcall ,expander-fn ,input ,env))) + ,@cases)))) (defmacro %assert-multiple-value-cases ((predicate builder) &body cases) "Assert CASES against a BUILDER that returns multiple values." (let ((expander (gensym "EXPANDER-"))) `(let ((,expander ,builder)) - ,@(mapcar (lambda (case) - (destructuring-bind (expected &rest args) case - `(expect (,predicate ',expected - (multiple-value-list - (funcall ,expander ,@args))) :to-be-truthy))) - cases)))) + ,@(mapcar (lambda (case) + (destructuring-bind (expected &rest args) case + `(expect (,predicate ',expected + (multiple-value-list + (funcall ,expander ,@args))) :to-be-truthy))) + cases)))) (defmacro %assert-quote-style-dispatch-case (style expected branch) `(let ((observed-branch nil)) - (expect ,expected :to-equal (nshell.domain.expansion:expand-by-quote-style - ,style - (progn (setf observed-branch :unquoted) '("unquoted")) - (progn (setf observed-branch :single) '("single")) - (progn (setf observed-branch :double) '("double")))) - (expect ,branch :to-be observed-branch))) + (expect ,expected :to-equal (nshell.domain.expansion:expand-by-quote-style + ,style + (progn (setf observed-branch :unquoted) '("unquoted")) + (progn (setf observed-branch :single) '("single")) + (progn (setf observed-branch :double) '("double")))) + (expect ,branch :to-be observed-branch))) (defmacro %assert-command-name-case (input style expected-command expected-error-count env) `(multiple-value-bind (command error) (nshell.domain.expansion:expand-command-name-by-quote-style ,input ,style ,env) - (expect ,expected-command :to-equal command) - (if ,expected-error-count - (expect (format nil "nshell: ~a: command name expansion produced ~d fields~%" - ,input ,expected-error-count) :to-equal error) - (expect error :to-be-null)))) + (expect ,expected-command :to-equal command) + (if ,expected-error-count + (expect (format nil "nshell: ~a: command name expansion produced ~d fields~%" + ,input ,expected-error-count) :to-equal error) + (expect error :to-be-null)))) (describe "expansion-tests" (it "dollar-var-expansion" @@ -180,17 +180,17 @@ Each case is (EXPECTED INPUT &rest ARGS)." (it "single-command-name-or-error-validates-non-empty-cardinality" "Command-position resolution drops empty fields before validating cardinality." (multiple-value-bind (command error) - (nshell.domain.expansion::%single-command-name-or-error "$EMPTY" '("")) + (nshell.domain.expansion:single-command-name-or-error "$EMPTY" '("")) (expect command :to-be-null) (expect (format nil "nshell: $EMPTY: command name expansion produced 0 fields~%") :to-equal error)) (multiple-value-bind (command error) - (nshell.domain.expansion::%single-command-name-or-error "$CMD" '("" "echo" "")) + (nshell.domain.expansion:single-command-name-or-error "$CMD" '("" "echo" "")) (expect "echo" :to-equal command) (expect error :to-be-null)) (multiple-value-bind (command error) - (nshell.domain.expansion::%single-command-name-or-error "$CMD" '("echo" "printf")) - (expect command :to-be-null) - (expect (format nil "nshell: $CMD: command name expansion produced 2 fields~%") :to-equal error))) + (nshell.domain.expansion:single-command-name-or-error "$CMD" '("echo" "printf")) + (expect command :to-be-null) + (expect (format nil "nshell: $CMD: command name expansion produced 2 fields~%") :to-equal error))) (it "command-name-candidate-resolves-non-empty-cardinality" "command-name-candidate owns empty-field removal before command resolution." diff --git a/t/unit/test-manage-job.lisp b/t/unit/test-manage-job.lisp index 88f744f..4ad7dd4 100644 --- a/t/unit/test-manage-job.lisp +++ b/t/unit/test-manage-job.lisp @@ -30,7 +30,7 @@ (nth-value 1 (find-symbol "MAKE-JOB-LISTING" "NSHELL.APPLICATION"))) :to-be-falsy) (expect (fboundp 'nshell.application::copy-job-listing) :to-be-falsy) - (expect (fboundp '(setf nshell.application:job-listing-command)) :to-be-falsy) + (expect (fboundp (list 'setf 'nshell.application:job-listing-command)) :to-be-falsy) (expect "printf ok" :to-equal (nshell.application:job-listing-command listing)))) (it "bg-marks-job-as-background-and-publishes-continuation" @@ -79,9 +79,17 @@ (job (make-test-job 0 "sleep" :args '("10") :pgid 4321)) (job-id (nshell.domain.job-control:monitor-add-job monitor job)) (set-foreground-calls nil) + (foreground-pgid 0) + (process-fns + (list :get-foreground-pgroup (lambda () 1000) + :set-foreground-pgroup + (lambda (pgid) + (push pgid set-foreground-calls)) + :set-foreground-pgid-state + (lambda (pgid) + (setf foreground-pgid (or pgid 0))))) (nshell.application:*shell-pgid* 1000) - (nshell.application:*foreground-job-pgid* nil) - (nshell.infrastructure.acl::*foreground-pgid* 0)) + (nshell.application:*foreground-job-pgid* nil)) (with-temporary-functions (('nshell.application::%continue-process-group (lambda (pgid) @@ -92,19 +100,15 @@ (expect job-id :to-equal waited-job-id) (expect monitor :to-be waited-monitor) (expect 4321 :to-equal nshell.application:*foreground-job-pgid*) - (expect 4321 :to-equal nshell.infrastructure.acl::*foreground-pgid*) + (expect 4321 :to-equal foreground-pgid) (error "wait failed"))) - ('nshell.infrastructure.acl:get-foreground-pgroup - (lambda () 1000)) - ('nshell.infrastructure.acl:set-foreground-pgroup - (lambda (pgid) - (push pgid set-foreground-calls)))) + ) (handler-case - (nshell.application:fg job-id nil nil nil monitor) + (nshell.application:fg job-id nil nil nil monitor process-fns) (error (condition) (expect (search "wait failed" (princ-to-string condition)) :to-be-truthy))) (expect nshell.application:*foreground-job-pgid* :to-be-null) - (expect 0 :to-equal nshell.infrastructure.acl::*foreground-pgid*) + (expect 0 :to-equal foreground-pgid) (expect '(1000 4321) :to-equal set-foreground-calls)))) (it "fg-publishes-continuation-to-dispatcher" "FG emits a continuation event through the supplied dispatcher." @@ -113,9 +117,17 @@ (job (make-test-job 0 "sleep" :args '("10") :pgid 4321)) (job-id (nshell.domain.job-control:monitor-add-job monitor job)) (set-foreground-calls nil) + (foreground-pgid 0) + (process-fns + (list :get-foreground-pgroup (lambda () 1000) + :set-foreground-pgroup + (lambda (pgid) + (push pgid set-foreground-calls)) + :set-foreground-pgid-state + (lambda (pgid) + (setf foreground-pgid (or pgid 0))))) (nshell.application:*shell-pgid* 1000) - (nshell.application:*foreground-job-pgid* nil) - (nshell.infrastructure.acl::*foreground-pgid* 0)) + (nshell.application:*foreground-job-pgid* nil)) (with-event-capture (continued dispatcher :job-continued) (nshell.domain.events:domain-event-type event) (with-temporary-functions @@ -128,15 +140,11 @@ (expect job-id :to-equal waited-job-id) (expect monitor :to-be waited-monitor) (expect 4321 :to-equal nshell.application:*foreground-job-pgid*) - (expect 4321 :to-equal nshell.infrastructure.acl::*foreground-pgid*) + (expect 4321 :to-equal foreground-pgid) waited-job)) - ('nshell.infrastructure.acl:get-foreground-pgroup - (lambda () 1000)) - ('nshell.infrastructure.acl:set-foreground-pgroup - (lambda (pgid) - (push pgid set-foreground-calls)))) + ) (expect job :to-be - (nshell.application:fg job-id dispatcher nil nil monitor))) + (nshell.application:fg job-id dispatcher nil nil monitor process-fns))) (expect (nshell.application:drain-events dispatcher) :to-be-null) (expect '(1000 4321) :to-equal set-foreground-calls) (expect '(:job-continued) :to-equal (nreverse continued))))) @@ -240,19 +248,19 @@ (let ((nshell.application:*shell-pgid* 1000) (nshell.application:*foreground-job-pgid* nil)) (with-temporary-function - ('nshell.infrastructure.acl:get-foreground-pgroup + ('nshell.application::%get-foreground-pgroup (lambda () 1000)) (expect (nshell.application::%foreground-signal-target-pgid) :to-be-null))) (let ((nshell.application:*shell-pgid* 1000) (nshell.application:*foreground-job-pgid* 1000)) (with-temporary-function - ('nshell.infrastructure.acl:get-foreground-pgroup + ('nshell.application::%get-foreground-pgroup (lambda () 2000)) (expect (nshell.application::%foreground-signal-target-pgid) :to-be-null))) (let ((nshell.application:*shell-pgid* 1000) (nshell.application:*foreground-job-pgid* nil)) (with-temporary-function - ('nshell.infrastructure.acl:get-foreground-pgroup + ('nshell.application::%get-foreground-pgroup (lambda () 2000)) (expect 2000 :to-equal (nshell.application::%foreground-signal-target-pgid))))) @@ -305,7 +313,7 @@ (calls nil)) (nshell.domain.job-control:background-job monitor job-id) (with-temporary-function - ((quote nshell.infrastructure.acl:kill-process) + ((quote nshell.application::%kill-process) (lambda (pid signal) (push (list pid signal) calls) 0)) @@ -371,14 +379,14 @@ (it "classifies wait errors without an OS wait" "Known wait errors become application events while unknown errors remain unclassified." (let* ((no-child - (nshell.application::%classify-job-wait-error sb-posix:echild)) + (nshell.application::%classify-job-wait-error :echild)) (interrupted - (nshell.application::%classify-job-wait-error sb-posix:eintr)) + (nshell.application::%classify-job-wait-error :eintr)) (unknown-errno - (1+ (max sb-posix:echild sb-posix:eintr)))) + (nshell.application::%classify-job-wait-error :enoent))) (expect :no-child :to-be (nshell.application::job-wait-event-state no-child)) (expect :interrupted :to-be (nshell.application::job-wait-event-state interrupted)) (expect nil :to-equal - (nshell.application::%classify-job-wait-error unknown-errno))))) + unknown-errno))))