diff --git a/.gitignore b/.gitignore
index 385e7f8..c5afb05 100644
--- a/.gitignore
+++ b/.gitignore
@@ -47,7 +47,6 @@ coverage.dat
# --- Editor and OS noise ---
.DS_Store
-.vscode/
*~
\#*\#
.\#*
diff --git a/README.md b/README.md
index e8ead87..22ae049 100644
--- a/README.md
+++ b/README.md
@@ -77,7 +77,7 @@ outside the tested support boundary.
## Development
```sh
-nix develop # SBCL + cl-weave + paredit; registry already set
+nix develop # SBCL with CL_SOURCE_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/highlight-data.lisp b/data/presentation/highlight-data.lisp
similarity index 76%
rename from data/highlight-data.lisp
rename to data/presentation/highlight-data.lisp
index b760b58..6649e3d 100644
--- a/data/highlight-data.lisp
+++ b/data/presentation/highlight-data.lisp
@@ -1,7 +1,8 @@
-;;; Literal syntax-highlighting data kept separate from the classifier.
-(in-package #:nshell.highlight)
+;;; Highlight data tables: builtin names, operator token types, and the
+;;; fallback (theme-less) ANSI role palette used by highlight.lisp.
+(in-package #:nshell.presentation)
-(defparameter +highlight-builtin-names+
+(defvar *builtin-commands*
'("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 9f9a580..2497787 100644
--- a/docs/notes/coverage-analysis.md
+++ b/docs/notes/coverage-analysis.md
@@ -16,20 +16,14 @@ silently removed from the report.
## Reproduce
```sh
-NSHELL_COVERAGE_DIR="$PWD/coverage" \
+NSHELL_COVERAGE_DIR=/tmp/nshell-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 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.
+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.
## What the suite verifies
diff --git a/docs/notes/macro-consolidation-audit.md b/docs/notes/macro-consolidation-audit.md
index 210ae7d..4c2ef93 100644
--- a/docs/notes/macro-consolidation-audit.md
+++ b/docs/notes/macro-consolidation-audit.md
@@ -10,7 +10,7 @@ Beyond `define-value-struct` (`docs/notes/value-struct-audit.md`), 26 other
boilerplate categories this goal targets:
- **Builtin command dispatch.** `define-builtin`
- (`application/builtin-macros.lisp`) auto-generates ignore-declarations;
+ (`application/builtin-commands.lisp`) auto-generates ignore-declarations;
`%with-option-arguments` / `%with-required-argument`
(`application/builtin-runtime.lisp`) capture the shared "parse leading
option flags, validate required args" skeleton; `%table-builtin-case`
@@ -20,8 +20,8 @@ boilerplate categories this goal targets:
(`application/builtin-string-support.lisp`) cover the `string` subcommand
family; `define-test-predicate-table` (`application/builtin-test.lisp`)
covers `test`/`[`. Registration itself is a single data table
- (`+builtin-registry-specs+` in `data/application/builtin-spec-data.lisp`),
- not hand-written per-command code.
+ (`+builtin-registry-specs+` in `application/builtin-spec-data.lisp`), not
+ hand-written per-command code.
- **Value structs.** 37 value structs generate their
accessor/predicate/constructor boilerplate from `define-value-struct`
instead of by hand (`docs/notes/value-struct-audit.md`).
diff --git a/docs/src/getting-started.md b/docs/src/getting-started.md
index ba03207..022342f 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 + paredit
+nix develop # dev shell with SBCL + cl-weave
```
`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 67bd5d3..b7d973d 100644
--- a/docs/src/guide/recipes.md
+++ b/docs/src/guide/recipes.md
@@ -53,21 +53,6 @@ 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
@@ -85,13 +70,11 @@ job-control lifecycle checks.
## Generate a coverage report
```sh
-NSHELL_COVERAGE_DIR="$PWD/coverage" \
- nix develop -c sbcl --script scripts/coverage.lisp
+nix develop -c sbcl --script scripts/coverage.lisp
```
-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.
+The report is written to `coverage/cover-index.html`. Set `NSHELL_COVERAGE_DIR`
+to redirect the output.
## Performance evidence
diff --git a/flake.nix b/flake.nix
index f25d5a6..c53e4d9 100644
--- a/flake.nix
+++ b/flake.nix
@@ -552,14 +552,10 @@
# whole docs tree.
treefmt.evalModule = treefmt-nix.lib.evalModule;
- # 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
- ];
+ # 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 ];
overrideOutputs =
ctx:
@@ -580,17 +576,14 @@
devShells.default = ctx.generated.devShells.default.overrideAttrs (previous: {
shellHook = previous.shellHook + ''
export NSHELL_ROOT=$PWD
- 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'
+ 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"'
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 ""
'';
@@ -632,8 +625,8 @@
# Generate the sb-cover report and enforce the configured source
# expression minimum. The report also records the distance from
- # the explicit 100% target without claiming that it has been
- # reached when executable expressions remain uncovered.
+ # the aspirational 100% target without making an unsupported
+ # claim that structural sb-cover forms are executable.
coverage = ctx.cl.mkScriptCheck {
drv = ctx.package;
entryPoint = "scripts/coverage.lisp";
diff --git a/nshell.asd b/nshell.asd
index e02a241..2775636 100644
--- a/nshell.asd
+++ b/nshell.asd
@@ -1,3 +1,11 @@
+;;; 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
@@ -37,7 +45,6 @@
(: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"
@@ -55,11 +62,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")
@@ -74,18 +81,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"
@@ -111,27 +118,23 @@
(: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")
@@ -156,7 +159,6 @@
(: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")
@@ -164,9 +166,6 @@
(: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")
@@ -185,20 +184,23 @@
(: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/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/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-execution-context")
(:file "presentation/repl-execution-command")
(:file "presentation/repl-execution")
@@ -210,10 +212,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,
@@ -274,16 +276,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")
@@ -300,13 +302,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 9d392f6..51df9de 100644
--- a/run-tests.lisp
+++ b/run-tests.lisp
@@ -7,30 +7,38 @@
;;;; 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 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.
+;;;; 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.
(require :asdf)
+(asdf:load-system :cl-host-kit)
-(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))
+(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))))
diff --git a/scripts/asdf-runtime.lisp b/scripts/asdf-runtime.lisp
index 12e462e..d70ff11 100644
--- a/scripts/asdf-runtime.lisp
+++ b/scripts/asdf-runtime.lisp
@@ -16,113 +16,3 @@
(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 02c4091..f5f0ebe 100644
--- a/scripts/benchmark-completion.lisp
+++ b/scripts/benchmark-completion.lisp
@@ -1,43 +1,47 @@
(require :asdf)
+(asdf:load-system :cl-host-kit)
-(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)))))
+(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))))
diff --git a/scripts/coverage.lisp b/scripts/coverage.lisp
index 74ee94d..417d2dc 100644
--- a/scripts/coverage.lisp
+++ b/scripts/coverage.lisp
@@ -4,9 +4,11 @@
;;;;
;;;; 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. 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.
+;;;; 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.
;;;;
;;;; :force :all is required, not :force t: :force t only forces recompiling
;;;; nshell/test itself, leaving the nshell (src/) dependency loaded from
@@ -14,13 +16,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 *nshell-coverage-script-path*)))
+ (uiop:pathname-directory-pathname
+ (or *load-truename* *load-pathname*))))
+(nshell-configure-writable-asdf-output)
+
(require :sb-cover)
(declaim (optimize sb-cover:store-coverage-data))
@@ -28,11 +30,6 @@
(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)))
@@ -56,22 +53,15 @@
(search total-marker row :start2 (+ covered-position (length covered-marker))))))
(if (or (null covered-position) (null total-position)) (values nil nil next-row)
(values
- (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))
+ (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))
next-row))))))
(defun %coverage-row-file-name (text start end)
(let* ((row-end (search "
" text :start2 start :end2 end))
@@ -140,26 +130,12 @@
(let ((raw (uiop:getenv name)))
(if (null raw) default
(let ((*read-eval* nil)
- (value (nth-value 0 (%coverage-call #'read-from-string raw))))
+ (value (ignore-errors (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
@@ -189,14 +165,17 @@
(%json-boolean tests-passed)
(%json-boolean (and (plusp total) (>= percentage minimum)))
(%json-boolean (and (plusp total) (>= percentage target))))))
- (let* ((root (uiop:pathname-parent-directory-pathname
- (uiop:pathname-directory-pathname
- *nshell-coverage-script-path*)))
+ (let* ((root (truename #P"./"))
+ (parent (uiop:pathname-parent-directory-pathname root))
+ (tmpdir (uiop:getenv "TMPDIR"))
(coverage-dir
(uiop:ensure-directory-pathname
(or
(uiop:getenv "NSHELL_COVERAGE_DIR")
- (%default-coverage-directory root))))
+ (if tmpdir (merge-pathnames
+ #P"nshell-coverage/"
+ (uiop:ensure-directory-pathname tmpdir))
+ (merge-pathnames #P"coverage/" 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))))
@@ -205,7 +184,15 @@
(tests-passed nil)
(report-passed nil)
(coverage-passed nil))
- (nshell-configure-runtime root)
+ (asdf:initialize-source-registry
+ (if (uiop:getenv "CL_SOURCE_REGISTRY")
+ `(:source-registry
+ (:directory ,root)
+ :inherit-configuration)
+ `(:source-registry
+ (:directory ,root)
+ (:tree ,parent)
+ :inherit-configuration)))
(ensure-directories-exist coverage-dir)
(sb-cover:enable-coverage-logging)
(unwind-protect (setf tests-passed (handler-case
@@ -265,7 +252,7 @@
(unless coverage-passed
(format
*error-output*
- "~&src executable expression coverage did not meet the required minimum (~,2F%%).~%"
+ "~&src executable expression coverage did not meet the configured minimum (~,2F%%).~%"
minimum))))
(sb-ext:exit
:code
diff --git a/scripts/weave.lisp b/scripts/weave.lisp
index e9a9984..05da621 100644
--- a/scripts/weave.lisp
+++ b/scripts/weave.lisp
@@ -3,18 +3,35 @@
;;;; Usage: sbcl --script scripts/weave.lisp
;;;;
;;;; Beyond cl-weave and cl-prolog-kit, this suite also depends on cl-prolog-kit/weave.
-;;;; The ASDF source and output configuration is shared with run-tests.lisp and
-;;;; the coverage and benchmark entry points.
+;;;; 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.
(require :asdf)
+(asdf:load-system :cl-host-kit)
-(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)
+(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 ((passed-p
(handler-case
(progn
diff --git a/src/application/builtin-commands.lisp b/src/application/builtin-commands.lisp
index 94ab051..3296967 100644
--- a/src/application/builtin-commands.lisp
+++ b/src/application/builtin-commands.lisp
@@ -1,8 +1,320 @@
(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))
@@ -46,16 +358,16 @@
(namestring old-cwd)
(if (nshell.domain.environment:env-defined-p environment "OLDPWD")
(nshell.domain.environment:env-exported-p environment "OLDPWD")
- t)))
- (setf environment
+ t))
+ 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)))
- (setf (shell-context-environment context) environment))
+ t))
+ (shell-context-environment context) environment))
(values (when (and args (string= (first args) "-"))
(format nil "~a~%" (namestring new-cwd)))
0))))
@@ -65,8 +377,8 @@
(defun %parse-exit-status (argument)
(handler-case
(values (mod (parse-integer argument :junk-allowed nil) 256) t)
- (error (condition)
- (values nil nil condition))))
+ (error ()
+ (values nil nil))))
(define-builtin %builtin-exit (context args) ()
(cond
@@ -104,13 +416,7 @@
(%execute-command-by-name-in-context context command command-args)
(values output (%invert-status-code code))))))
-(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 %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 %contains-usage ()
(%builtin-usage
@@ -157,7 +463,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 6c76862..1f0958b 100644
--- a/src/application/builtin-jobs.lisp
+++ b/src/application/builtin-jobs.lisp
@@ -29,8 +29,7 @@
(shell-context-dispatcher context)
(shell-context-process-registry context)
(shell-context-terminal-fns context)
- job-monitor
- (shell-context-process-fns context))))
+ job-monitor)))
(if job
(values nil 0)
(values (%missing-job-output "fg" (%job-spec-label args)) 1))))
@@ -40,8 +39,7 @@
(job-id (%resolve-job-id job-monitor args :active-only-p t))
(job (bg job-id
(shell-context-dispatcher context)
- job-monitor
- (shell-context-process-fns context))))
+ job-monitor)))
(if job
(values nil 0)
(values (%missing-job-output "bg" (%job-spec-label args)) 1))))
@@ -99,8 +97,7 @@
(type-error () nil))))
(defun %parse-positive-integer (text)
(let ((value (%parse-integer-designator text)))
- (when (and value (plusp value))
- value)))
+ (and value (plusp value) value)))
(defun %find-job-id-by-pid (job-monitor pid)
(let ((found nil))
(nshell.domain.job-control:monitor-map-jobs
@@ -149,10 +146,7 @@
(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
- (shell-context-process-fns context))
+ (wait-for-job job-id process-registry job-monitor)
(values nil nil))
(if job
(setf last-code exit-code)
@@ -259,18 +253,14 @@
(string= target "-")))
(nshell.domain.job-control:monitor-resolve-job-spec
job-monitor target)))
-(defun %kill-one-target (context job-monitor target signal)
+(defun %kill-one-target (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
- (shell-context-process-fns context)))
+ ((and job-id (signal-job job-id signal job-monitor))
t)
((let ((pid (%parse-integer-designator target)))
(when pid
- (funcall (%process-fn context :kill-process) pid signal)
+ (nshell.infrastructure.acl:kill-process pid signal)
t)))
(t nil))))
(defun %kill-list-output ()
@@ -296,7 +286,6 @@
(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
deleted file mode 100644
index 248ba09..0000000
--- a/src/application/builtin-macros.lisp
+++ /dev/null
@@ -1,8 +0,0 @@
-(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
deleted file mode 100644
index 62661cb..0000000
--- a/src/application/builtin-printf-format.lisp
+++ /dev/null
@@ -1,208 +0,0 @@
-(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
deleted file mode 100644
index 105891a..0000000
--- a/src/application/builtin-printf-parser.lisp
+++ /dev/null
@@ -1,113 +0,0 @@
-(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
deleted file mode 100644
index 2e1782f..0000000
--- a/src/application/builtin-printf.lisp
+++ /dev/null
@@ -1,25 +0,0 @@
-(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 77f00ae..1580d26 100644
--- a/src/application/builtin-runtime.lisp
+++ b/src/application/builtin-runtime.lisp
@@ -94,10 +94,7 @@
:empty-directory ""))
(defun %stat-path (context path)
- (handler-case
- (values (funcall (%filesystem-fn context :stat) path) nil)
- (error (condition)
- (values nil condition))))
+ (ignore-errors (funcall (%filesystem-fn context :stat) path)))
(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 8a58434..3f86477 100644
--- a/src/application/builtin-type-helpers.lisp
+++ b/src/application/builtin-type-helpers.lisp
@@ -18,18 +18,14 @@
(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")
- (%type-option-prefix-p "--color=" option))
+ (and (>= (length option) 8)
+ (string= option "--color=" :end1 8 :end2 8)))
:color)
((%builtin-option-p option '("-q" "--query" "--quiet")) :query)
((%builtin-option-p option '("-p" "--path")) :path)
@@ -40,7 +36,8 @@
(defun %type-color-enabled-p (option)
(or (string= option "--color")
- (and (%type-option-prefix-p "--color=" option)
+ (and (>= (length option) 8)
+ (string= option "--color=" :end1 8 :end2 8)
(let ((value (subseq option 8)))
(or (string= value "always")
(string= value "auto"))))))
@@ -56,8 +53,8 @@
(with-output-to-string (out)
(dolist (line (%string-lines text))
(write-string
- (nshell.highlight:highlight->ansi
- (nshell.highlight:highlight-line line)
+ (nshell.presentation:highlight->ansi
+ (nshell.presentation: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 fe2044a..994e91a 100644
--- a/src/application/execute-pipeline-expansion.lisp
+++ b/src/application/execute-pipeline-expansion.lisp
@@ -22,15 +22,14 @@ 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 (process-fns)
+(defun %make-pipeline-shell-context ()
(make-shell-context
:environment (nshell.domain.environment:inject-os-environment
- (nshell.domain.environment:make-default-environment))
- :process-fns process-fns))
+ (nshell.domain.environment:make-default-environment))))
(defun execute-command-line (line history dispatcher)
(nshell.domain.parsing:with-complete-command-line (result ast line)
@@ -141,7 +140,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)))
@@ -207,7 +206,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 3e95fab..43f574d 100644
--- a/src/application/execute-pipeline-stage-background.lisp
+++ b/src/application/execute-pipeline-stage-background.lisp
@@ -2,25 +2,16 @@
;;; Background pipeline stage helpers.
-(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)
+(defun %background-process-pid (process)
"Return the OS PID of a background PROCESS object, or NIL if unavailable."
- (%background-call-process-operation (%process-fn context :process-pid) process))
+ (ignore-errors (sb-ext: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 (lambda (process)
- (%background-process-pid context process))
- proc-list))))
+ (pids (delete nil (mapcar #'%background-process-pid proc-list))))
(when pids
(let ((job-id (nshell.domain.job-control:monitor-add-background-job
(shell-context-job-monitor context)
@@ -44,10 +35,10 @@ PROCESSES is a single process object (command) or a list (pipeline).
(nshell.domain.parsing:pipeline-node-commands command))
(cond
(error
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values error 127))
(resources
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values
(%process-substitution-error
"is not supported in background jobs")
@@ -62,8 +53,8 @@ PROCESSES is a single process object (command) or a list (pipeline).
redirect-split))
(clean-pipeline (nshell.domain.parsing:make-pipeline-node
clean-commands))
- (processes (funcall (%process-fn context :spawn-pipeline-async)
- clean-commands :redirects redirects))
+ (processes (nshell.infrastructure.acl:spawn-pipeline-async
+ clean-commands :redirects redirects))
(command-line (nshell.domain.parsing:ast-node->command-line
clean-pipeline)))
(when processes
@@ -75,10 +66,10 @@ PROCESSES is a single process object (command) or a list (pipeline).
(%expand-command-node-in-context context command)
(cond
(error
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values error 127))
(resources
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values
(%process-substitution-error
"is not supported in background jobs")
@@ -95,8 +86,8 @@ PROCESSES is a single process object (command) or a list (pipeline).
(args (nshell.domain.parsing:command-node-arg-values clean-command))
(command-line (nshell.domain.parsing:ast-node->command-line
clean-command))
- (process (funcall (%process-fn context :spawn-async)
- cmd args :redirects redirects)))
+ (process (nshell.infrastructure.acl: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 e9b6343..a51db71 100644
--- a/src/application/execute-pipeline-stage-external.lisp
+++ b/src/application/execute-pipeline-stage-external.lisp
@@ -1,10 +1,8 @@
(in-package #:nshell.application)
-(defun %wait-external-process-for-cleanup (context process)
- (handler-case
- (values (funcall (%process-fn context :process-wait) process) nil)
- (error (condition)
- (values nil condition))))
+;; 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*))
;;; External process execution helpers for pipeline stages.
@@ -71,71 +69,17 @@
(t *standard-input*))
opened-input)))
-(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)
+(defun %start-external-process-copiers (process stdout-buffer stderr-buffer)
(let ((stdout-thread
- (funcall (%process-fn context :start-stream-copier)
- (funcall (%process-fn context :process-output) process)
+ (nshell.infrastructure.acl::%start-stream-copier
+ (sb-ext:process-output process)
stdout-buffer
"nshell process stdout copier"))
(stderr-thread nil))
(when stderr-buffer
(setf stderr-thread
- (funcall (%process-fn context :start-stream-copier)
- (funcall (%process-fn context :process-error) process)
+ (nshell.infrastructure.acl::%start-stream-copier
+ (sb-ext:process-error process)
stderr-buffer
"nshell process stderr copier")))
(remove nil (list stdout-thread stderr-thread))))
@@ -198,115 +142,109 @@
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
- (context command-node input redirects &optional process-substitution-resources)
+ (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))
- (stage-plan
- (%external-process-stage-plan-from
- context
- command-node
- redirects
- process-substitution-resources)))
+ (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))
(handler-case
(multiple-value-bind (stdin opened-input)
- (%external-process-input-stream
- (%external-process-stage-plan-input-target stage-plan)
- input)
+ (%external-process-input-stream input-target input)
(unwind-protect
- (%execute-external-process
- context
- stage-plan
- stdin
- command
- process-substitution-resources)
- (when opened-input
- (close opened-input))))
+ (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))))
(error (condition)
- (%abort-process-substitution-resources
- context
- process-substitution-resources)
+ (%abort-process-substitution-resources 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 2f709c5..764f5ad 100644
--- a/src/application/execute-pipeline-stage.lisp
+++ b/src/application/execute-pipeline-stage.lisp
@@ -1,10 +1,9 @@
(in-package #:nshell.application)
-(defun %call-process-cleanup (function &rest arguments)
- (handler-case
- (values (apply function arguments) nil)
- (error (condition)
- (values nil condition))))
+(declaim (notinline nshell.infrastructure.acl:process-substitution-resource-path
+ nshell.infrastructure.acl:process-substitution-resource-fd))
+
+(declaim (special nshell.infrastructure.acl:*external-command-timeout*))
;;; Pipeline stage execution and command expansion.
;;; execute-ast-in-context (defined in execute-pipeline-control.lisp) is
@@ -36,31 +35,25 @@
(t
nil)))
-(defun %release-process-substitution-resources (context resources)
+(defun %release-process-substitution-resources (resources)
(dolist (resource resources)
- (%call-process-cleanup
- (%process-fn context :release-process-substitution-fd)
- resource)))
+ (ignore-errors
+ (nshell.infrastructure.acl:release-process-substitution-fd resource))))
-(defun %finish-process-substitution-resources (context resources)
+(defun %finish-process-substitution-resources (resources)
(dolist (resource resources)
- (%call-process-cleanup
- (%process-fn context :wait-process-substitution)
- resource)
- (%call-process-cleanup
- (%process-fn context :release-process-substitution-fd)
- resource)))
+ (ignore-errors
+ (nshell.infrastructure.acl:wait-process-substitution resource))
+ (ignore-errors
+ (nshell.infrastructure.acl:release-process-substitution-fd resource))))
-(defun %abort-process-substitution-resources (context resources)
+(defun %abort-process-substitution-resources (resources)
(dolist (resource resources)
- (%call-process-cleanup
- (%process-fn context :close-process-substitution)
- resource)))
+ (ignore-errors
+ (nshell.infrastructure.acl:close-process-substitution resource))))
-(defun %process-substitution-resource-fds (context resources)
- (mapcar (lambda (resource)
- (funcall (%process-fn context :process-substitution-resource-fd)
- resource))
+(defun %process-substitution-resource-fds (resources)
+ (mapcar #'nshell.infrastructure.acl:process-substitution-resource-fd
resources))
(defun %materialize-process-substitution-in-context (context value)
@@ -89,7 +82,7 @@
context
commands)
(when nested-resources
- (%abort-process-substitution-resources context nested-resources)
+ (%abort-process-substitution-resources nested-resources)
(return-from
%materialize-process-substitution-in-context
(values
@@ -116,18 +109,13 @@
(nshell.domain.parsing:command-list-redirect-split-result-redirects
redirect-split)))
(handler-case (let ((resource
- (funcall (%process-fn
- context
- :spawn-process-substitution)
- direction
- clean-commands
- :redirects
- redirects)))
+ (nshell.infrastructure.acl:spawn-process-substitution
+ direction
+ clean-commands
+ :redirects
+ redirects)))
(values
- (funcall
- (%process-fn
- context
- :process-substitution-resource-path)
+ (nshell.infrastructure.acl:process-substitution-resource-path
resource)
resource
nil))
@@ -157,7 +145,7 @@
(multiple-value-bind (path resource error)
(%materialize-process-substitution-in-context context value)
(when error
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(return-from %expand-command-args-in-context
(values nil nil error)))
(setf args
@@ -175,7 +163,7 @@
(not (null (member value '("<<" "<<-") :test #'string=))))))
(values args (nreverse resources) nil))
(nshell.domain.expansion:parameter-expansion-error (condition)
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values nil nil
(format nil "nshell: ~a~%" condition))))))
@@ -215,7 +203,7 @@ command name expands to zero or multiple fields (ambiguous)."
(%expand-command-node-in-context context command)
(if error
(progn
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(return-from %expand-command-nodes-in-context
(values nil error nil)))
(progn
@@ -255,7 +243,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 context command-node input redirects)))
+ (%execute-external-pipeline-stage command-node input redirects)))
(defun %execute-source-pipeline-in-context (context commands redirects)
(let ((input nil)
@@ -302,7 +290,7 @@ command name expands to zero or multiple fields (ambiguous)."
(%restore-context-redirects context)))))
(defun %execute-os-pipeline-with-process-substitutions
- (context clean-commands redirects resources &optional (pipefail-p nil))
+ (clean-commands redirects resources &optional (pipefail-p nil))
(let ((spawned-p nil))
(unwind-protect
(handler-case
@@ -311,17 +299,16 @@ command name expands to zero or multiple fields (ambiguous)."
(values
(with-output-to-string (*standard-output*)
(multiple-value-bind (status statuses)
- (funcall (%process-fn context :spawn-pipeline)
+ (nshell.infrastructure.acl:spawn-pipeline
clean-commands
:redirects redirects
:pipefail-p pipefail-p
:preserve-fds
- (%process-substitution-resource-fds context resources)
+ (%process-substitution-resource-fds resources)
:after-spawn
(lambda ()
(setf spawned-p t)
(%release-process-substitution-resources
- context
resources)))
(setf exit-code (or status 0)
pipeline-statuses (or statuses
@@ -331,14 +318,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 context resources)
- (%abort-process-substitution-resources context resources)))))
+ (%finish-process-substitution-resources resources)
+ (%abort-process-substitution-resources 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 context resources)
+ (%abort-process-substitution-resources resources)
(return-from execute-command-node-in-context (values error 127)))
(let* ((redirect-split (%extract-command-redirects expanded))
(clean-command
@@ -350,25 +337,18 @@ command name expands to zero or multiple fields (ambiguous)."
(if resources
(if (%shell-internal-command-p context clean-command)
(progn
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(values
(%process-substitution-error
"requires an external command")
127))
(%execute-external-pipeline-stage
- context
- clean-command
- nil
- redirects
- resources))
+ 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
- context
- clean-command
- nil
- redirects)
+ clean-command nil redirects)
(%execute-clean-command-node-in-context
context clean-command redirects))))))
@@ -379,7 +359,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 context resources)
+ (%abort-process-substitution-resources resources)
(return-from execute-pipeline-node-in-context (values error 127)))
(let* ((redirect-split (%extract-pipeline-redirects expanded-commands))
(clean-commands
@@ -393,15 +373,14 @@ 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 context resources)
+ (%abort-process-substitution-resources 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
- context
- clean-commands redirects resources
+ (%execute-os-pipeline-with-process-substitutions
+ clean-commands redirects resources
(shell-context-pipefail-p context))
(%record-pipeline-statuses context statuses)
(values output exit-code)))
@@ -417,7 +396,7 @@ command name expands to zero or multiple fields (ambiguous)."
(setf output
(with-output-to-string (*standard-output*)
(multiple-value-bind (status statuses)
- (funcall (%process-fn context :spawn-pipeline)
+ (nshell.infrastructure.acl:spawn-pipeline
clean-commands
:redirects redirects
:pipefail-p
@@ -430,16 +409,16 @@ command name expands to zero or multiple fields (ambiguous)."
;; -- Public pipeline API (OS-level) -------------------------------------------
-(defun execute-pipeline (pipeline-ast process-fns)
+(defun execute-pipeline (pipeline-ast)
"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 process-fns)))
+ (let ((context (%make-pipeline-shell-context)))
(multiple-value-bind (expanded-commands error resources)
(%expand-command-nodes-in-context context commands)
(when error
- (%abort-process-substitution-resources context resources)
+ (%abort-process-substitution-resources resources)
(write-string error *error-output*)
(return-from execute-pipeline 127))
(let* ((redirect-split (%extract-pipeline-redirects expanded-commands))
@@ -453,7 +432,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 context resources)
+ (%abort-process-substitution-resources resources)
(write-string
(%process-substitution-error
"is not supported for internal commands")
@@ -462,20 +441,19 @@ command name expands to zero or multiple fields (ambiguous)."
(if resources
(nth-value
1
- (%execute-os-pipeline-with-process-substitutions
- context
- clean-commands redirects resources
+ (%execute-os-pipeline-with-process-substitutions
+ clean-commands redirects resources
(shell-context-pipefail-p context)))
- (funcall (%process-fn context :spawn-pipeline)
+ (nshell.infrastructure.acl:spawn-pipeline
clean-commands
:redirects redirects
:pipefail-p (shell-context-pipefail-p context)))))))))
-(defun execute-pipeline-use-case (pipeline dispatcher process-fns)
+(defun execute-pipeline-use-case (pipeline dispatcher)
(when dispatcher
(publish-event dispatcher
(nshell.domain.events:make-pipeline-started-event pipeline nil)))
- (let ((exit-code (or (execute-pipeline pipeline process-fns) 0)))
+ (let ((exit-code (or (execute-pipeline pipeline) 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 ea71de0..ddbe45c 100644
--- a/src/application/manage-job.lisp
+++ b/src/application/manage-job.lisp
@@ -1,8 +1,10 @@
(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 *job-process-fns* nil)
-(defvar *shell-pgid* 0)
+(defvar *shell-pgid* (sb-posix:getpid))
(defvar *foreground-job-pgid* nil)
(define-value-struct job-listing
@@ -25,95 +27,51 @@
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 ((fn (%optional-job-process-fn :set-foreground-pgid-state)))
- (when fn
- (funcall fn pgid)))
+ (let ((symbol (find-symbol "*FOREGROUND-PGID*" "NSHELL.INFRASTRUCTURE.ACL")))
+ (when symbol
+ (setf (symbol-value symbol) (or pgid 0))))
(values))
(defun %continue-process-group (pgid)
- (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))
+ (sb-posix:kill (- pgid) sb-unix:sigcont))
(defun fg (job-id &optional dispatcher process-registry terminal-fns
- (job-monitor *job-monitor*) process-fns)
+ (job-monitor *job-monitor*))
"Move JOB-ID to the foreground, wait for it, then restore the shell PGID."
(declare (ignore process-registry terminal-fns))
- (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)))))
+ (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*) process-fns)
+(defun bg (job-id &optional dispatcher (job-monitor *job-monitor*))
"Continue JOB-ID in the background."
- (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)))))
+ (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."
@@ -140,10 +98,10 @@ without aborting job-control cleanup."
(defun %foreground-signal-target-pgid ()
(let ((pgid (or *foreground-job-pgid*
- (%get-foreground-pgroup))))
+ (ignore-errors (nshell.infrastructure.acl:get-foreground-pgroup)))))
(when (and pgid
(nshell.domain.execution:valid-process-group-id-p pgid)
- (/= pgid (%shell-process-group-id)))
+ (/= pgid *shell-pgid*))
pgid)))
(defun %job-command-string (job)
@@ -159,12 +117,13 @@ without aborting job-control cleanup."
(otherwise "Unknown")))
(defun %with-terminal-foreground-pgroup (pgid thunk)
- (let ((previous (%get-foreground-pgroup)))
+ (let ((previous (ignore-errors (nshell.infrastructure.acl:get-foreground-pgroup))))
(unwind-protect
(progn
- (%set-foreground-pgroup pgid)
+ (ignore-errors (nshell.infrastructure.acl:set-foreground-pgroup pgid))
(funcall thunk))
- (%set-foreground-pgroup (or previous (%shell-process-group-id))))))
+ (ignore-errors
+ (nshell.infrastructure.acl:set-foreground-pgroup (or previous *shell-pgid*))))))
(defun %classify-job-wait-status (pid status
&key stopped-p exited-p exit-status
@@ -182,22 +141,30 @@ without aborting job-control cleanup."
(defun %classify-job-wait-error (errno)
(cond
- ((member errno '(:echild :no-child))
+ ((= errno sb-posix:echild)
(%make-job-wait-event nil :no-child nil))
- ((member errno '(:eintr :interrupted))
+ ((= errno sb-posix:eintr)
(%make-job-wait-event nil :interrupted nil))
(t nil)))
(defun %wait-job-pgid-event (pgid)
- (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)))))
+ (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))))))
(defun %wait-job-pgid (job job-id job-monitor)
(let* ((pgid (nshell.domain.execution:job-control-pgid job))
@@ -245,77 +212,79 @@ without aborting job-control cleanup."
(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*) process-fns)
+(defun signal-job (job-id signal &optional (job-monitor *job-monitor*))
"Send SIGNAL to JOB-ID and synchronize the monitor after a successful signal."
- (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))))))
+ (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)))))
(defun wait-for-job (job-id process-registry
- &optional (job-monitor *job-monitor*) process-fns)
+ &optional (job-monitor *job-monitor*))
"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-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))))))))))
+ (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)
- (let ((fn (%optional-job-process-fn :process-exit-status-code)))
- (and fn (funcall fn process))))
+ (nshell.infrastructure.acl:process-exit-status-code process))
(remove nil processes))))
(if (nshell.domain.execution:job-pipefail-p job)
(or (find-if (lambda (status)
@@ -326,10 +295,9 @@ exit status when the reaper has already completed the domain job."
(nshell.domain.execution:job-exit-code job)
0))))
(defun %wait-job-processes (processes)
- (let ((fn (%optional-job-process-fn :process-wait)))
- (dolist (process processes)
- (when (and fn process)
- (funcall fn process))))
+ (dolist (process processes)
+ (when process
+ (sb-ext:process-wait process)))
processes)
(defun %job-process-list (entry)
(cond
diff --git a/src/domain/expansion/fields.lisp b/src/domain/expansion/fields.lisp
index 63d65ae..395dc21 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 (character)
- (member character '(#\Space #\Tab #\Newline) :test #'char=))
+(defun whitespace-field-separator-p (char)
+ (member char '(#\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 d89c65d..661768d 100644
--- a/src/domain/parsing/tokenizer-data.lisp
+++ b/src/domain/parsing/tokenizer-data.lisp
@@ -184,10 +184,7 @@
fragments)
(setf (tokenizer-state-pos state) (%token-extent-end extent))))
-(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."
+(defun %balanced-substitution-end (input start)
(let ((depth 0)
(quote nil)
(escaped nil))
@@ -211,4 +208,4 @@ Quotes and escaped characters do not affect the parenthesis depth."
(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/infrastructure/acl/process-capabilities.lisp b/src/infrastructure/acl/process-capabilities.lisp
deleted file mode 100644
index 3e256c0..0000000
--- a/src/infrastructure/acl/process-capabilities.lisp
+++ /dev/null
@@ -1,104 +0,0 @@
-(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 64a7e37..13dea03 100644
--- a/src/infrastructure/acl/syscall-foreign.lisp
+++ b/src/infrastructure/acl/syscall-foreign.lisp
@@ -12,6 +12,11 @@
(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 76aed2f..18da492 100644
--- a/src/infrastructure/acl/syscall-process.lisp
+++ b/src/infrastructure/acl/syscall-process.lisp
@@ -4,12 +4,6 @@
(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)))
@@ -32,24 +26,26 @@ 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)
- (%process-operation #'finish-output output))))
+ (ignore-errors
+ (finish-output output)))))
-(defun start-stream-copier (input output name)
- "Copy INPUT to OUTPUT asynchronously and return the copier thread."
+(defun %start-stream-copier (input output name)
(when input
(sb-thread:make-thread
(lambda ()
- (%process-operation #'%copy-process-output input output))
+ (ignore-errors
+ (%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
- (%process-operation #'sb-thread:join-thread thread)))
+ (ignore-errors
+ (sb-thread:join-thread thread))))
(defun %join-process-output-copiers (copiers)
(dolist (copier copiers)
@@ -66,7 +62,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)
- (%process-operation #'sb-ext:process-wait proc)
+ (ignore-errors (sb-ext:process-wait proc))
t)))
(defun %terminate-process (proc)
@@ -77,23 +73,21 @@ 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)
- (nth-value 0 (%process-operation #'sb-posix:getpgid pid))))
+ (ignore-errors (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
- (%process-operation #'%send-process-group-signal pid signal)
+ (ignore-errors (%send-process-group-signal pid signal))
(when (sb-ext:process-alive-p proc)
- (%process-operation #'sb-ext:process-kill proc signal)))))
+ (ignore-errors (sb-ext:process-kill proc signal))))))
(terminate sb-unix:sigterm)
(%wait-process-exit-with-timeout proc 0.5)
(terminate sb-unix:sigkill)
- (%process-operation #'sb-ext:process-wait proc)))))
+ (ignore-errors (sb-ext:process-wait proc))))))
-(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."
+(defun %wait-process-with-copiers (proc copiers timeout-seconds success-fn timeout-fn)
(unwind-protect
(if (or (null timeout-seconds)
(%wait-process-exit-with-timeout proc timeout-seconds))
@@ -109,7 +103,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
@@ -133,11 +127,9 @@ exit code, or 128+signal when it was terminated by a signal."
return (subseq entry (length prefix)))))
(defun %executable-file-p (path)
- (handler-case
- (not (zerop (logand (sb-posix:stat-mode (sb-posix:stat path))
- #o111)))
- (error (condition)
- (values nil condition))))
+ (ignore-errors
+ (not (zerop (logand (sb-posix:stat-mode (sb-posix:stat path))
+ #o111)))))
(defun %resolve-external-command (command &optional (environment (%get-environment)))
(nshell.domain.completion::%first-command-path-candidate
@@ -156,19 +148,6 @@ 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
@@ -177,8 +156,7 @@ redirection the process inherits *STANDARD-INPUT*."
(nshell.domain.parsing:redirect-input-spec redirects)
(flet ((track (stream) (funcall register stream) stream))
(case kind
- (:< (%open-and-register-process-stream
- target register :direction :input :if-does-not-exist :error))
+ (:< (track (open target :direction :input :if-does-not-exist :error)))
(:<<< (track (%here-string-stream target)))
((:<< :<<-) (track (%here-document-stream target)))
(t *standard-input*)))))
@@ -189,9 +167,10 @@ 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
- (%open-and-register-process-stream
- target register
- :direction :output :if-exists mode :if-does-not-exist :create)
+ (let ((stream (open target :direction :output
+ :if-exists mode :if-does-not-exist :create)))
+ (funcall register stream)
+ stream)
t)))
(defun %spawn-in-own-process-group (resolved-cmd args environment input output &key (error nil error-supplied-p))
@@ -204,7 +183,7 @@ process's own stdout, calling REGISTER on any stream opened here."
(when proc
(let ((pid (sb-ext:process-pid proc)))
(when (plusp pid)
- (%process-operation #'set-process-group pid pid)))
+ (ignore-errors (set-process-group pid pid))))
proc)))
(defun spawn-async (cmd args &key redirects)
@@ -224,7 +203,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)
- (%process-operation #'close stream))))))
+ (ignore-errors (close stream)))))))
(defun %foreground-external-command-timeout ()
"Return the timeout to apply to a foreground external command's wait: NIL
@@ -276,7 +255,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)
@@ -285,8 +264,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 f45354f..4a4cab9 100644
--- a/src/infrastructure/acl/syscall-redirection.lisp
+++ b/src/infrastructure/acl/syscall-redirection.lisp
@@ -28,23 +28,7 @@
(defun %close-owned-redirect-stream (stream)
(when (and stream (streamp 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))))))
+ (ignore-errors (close stream))))
(defun %release-owned-stdout ()
(let ((stream *redirected-stdout-owned*))
@@ -52,47 +36,51 @@
(%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 `>>`."
- (%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))
+ (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)))
(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>>`."
- (%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))
+ (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)))
(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."
- (%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))
+ (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)))
(defun redirect-output-to-error ()
(%remember-redirected-stdout)
@@ -112,14 +100,10 @@ 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."
- (%install-redirect-stream
- filename
- (lambda (stream)
- (%remember-redirected-stdin)
- (setf *redirected-stdin-owned* stream
- *standard-input* stream))
- :direction :input
- :if-does-not-exist :error))
+ (let ((stream (open filename :direction :input :if-does-not-exist :error)))
+ (%remember-redirected-stdin)
+ (setf *redirected-stdin-owned* stream
+ *standard-input* stream)))
(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 fc9faa6..585fe8c 100644
--- a/src/package-domain.lisp
+++ b/src/package-domain.lisp
@@ -104,8 +104,7 @@ 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 #:balanced-substitution-end
- #:shell-assignment-word-p #:parse-command-line
+ (:export #:tokenize #: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
@@ -215,7 +214,6 @@ 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
deleted file mode 100644
index 400d5b4..0000000
--- a/src/package-highlight.lisp
+++ /dev/null
@@ -1,12 +0,0 @@
-;;; 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 7cb2310..8411c60 100644
--- a/src/package-infrastructure.lisp
+++ b/src/package-infrastructure.lisp
@@ -12,7 +12,6 @@ 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
@@ -37,9 +36,8 @@ 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*
- #:start-stream-copier #:wait-process-with-copiers
- #:run-external #:run-external-capture #:run-external-exec
+ #:*external-command-timeout*
+ #: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 6026b23..c6c3667 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 autosuggestion, prompt drawing, and the REPL itself in its interactive,
-batch, and script forms.")
+-- plus syntax highlighting, 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,6 +36,9 @@ batch, and script forms.")
#:run-repl #:run-repl-batch #:run-repl-script
#:trampoline #:render-prompt
#:compute-suggestion #:accept-suggestion
- #:render-completions #:apply-completion
- #:segment-kind->role))
+ #:render-completions #:apply-completion
+ #:highlight-line
+ #:highlight-span-start #:highlight-span-end
+ #:highlight-span-role
+ #:highlight->ansi #:theme-color->ansi #:segment-kind->role))
)
diff --git a/src/highlight.lisp b/src/presentation/highlight.lisp
similarity index 80%
rename from src/highlight.lisp
rename to src/presentation/highlight.lisp
index 05f2e9d..5edd6fc 100644
--- a/src/highlight.lisp
+++ b/src/presentation/highlight.lisp
@@ -1,15 +1,23 @@
-(in-package #:nshell.highlight)
+(in-package #:nshell.presentation)
+;; 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 +highlight-builtin-names+ :test #'string=))
+ (find name *builtin-commands* :test #'string=))
(defun classify-token-role (token-type token-value is-first-word)
- "Map a token to its syntax-highlight role."
+ "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)"
(case token-type
(:word
(cond
@@ -56,12 +64,14 @@
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."
+ "Convert a highlight ROLE to ANSI escape using THEME colors.
+ Falls back to known ANSI 16-color codes when theme lookup fails."
(let ((color (nshell.domain.configuration:theme-color theme role)))
(if color
(let ((code (nshell.infrastructure.terminal:ansi-color-code color)))
@@ -73,13 +83,16 @@
(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/presentation/prompt-display.lisp b/src/presentation/prompt-display.lisp
index c2a488b..3f32f5b 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 (character)
- "Terminal column width of CHARACTER, delegating to cl-tty-kit's Unicode-aware
+(defun %char-visible-width (char)
+ "Terminal column width of CHAR, delegating to cl-tty-kit's Unicode-aware
classifier (control/combining -> 0, wide/emoji -> 2, otherwise 1)."
- (cl-tty-kit:char-width character))
+ (cl-tty-kit:char-width char))
(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,8 +65,7 @@ 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 (condition)
- (values 80 condition))))
+ (error () 80)))
(defun segment-kind->role (kind)
"Map prompt segment kind to highlight role for theme lookup."
@@ -96,7 +95,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"
- (nshell.highlight:theme-color->ansi theme (segment-kind->role kind))
+ (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 290fac8..e916a5e 100644
--- a/src/presentation/repl-execution-context.lisp
+++ b/src/presentation/repl-execution-context.lisp
@@ -13,7 +13,12 @@
(not (null (host-kit:directory-exists-p path))))))
(defparameter +repl-process-fns+
- (nshell.infrastructure.acl:make-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))))
(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 c43d839..5b51a36 100644
--- a/src/presentation/repl-output-completion-help.lisp
+++ b/src/presentation/repl-output-completion-help.lisp
@@ -59,6 +59,9 @@
(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))
@@ -94,8 +97,8 @@
(multiple-value-bind (output exit-code)
(funcall *completion-help-fetcher* command)
(%completion-help-cache-help-text command output exit-code))
- (error (condition)
- (values :missing condition))))
+ (error ()
+ :missing)))
(progn
(defun %warm-command-completion-help (command)
diff --git a/src/presentation/repl-rendering.lisp b/src/presentation/repl-rendering.lisp
index 7625799..32ce750 100644
--- a/src/presentation/repl-rendering.lisp
+++ b/src/presentation/repl-rendering.lisp
@@ -33,12 +33,9 @@
(format t "~C[7m~a~C[27m" #\Esc segment #\Esc)
(handler-case
(format t "~a"
- (nshell.highlight:highlight->ansi
- (nshell.highlight:highlight-line segment)
- segment theme))
- (error (condition)
- (format t "~a" segment)
- (values nil condition))))
+ (highlight->ansi (highlight-line segment) segment theme))
+ (error ()
+ (format t "~a" segment))))
(setf local-start local-end))))
(defun render-edit-buffer (text theme &key selection-start selection-end)
@@ -84,8 +81,7 @@
(setf *prompt-rendered-origin-row* row
*prompt-rendered-origin-column* column))
(setf *prompt-rendered-origin-known-p* t))
- (error (condition)
- (values nil condition))))
+ (error () nil)))
(unless *prompt-rendered-origin-known-p*
(setf *prompt-rendered-origin-row* 1
*prompt-rendered-origin-column* 1
@@ -118,7 +114,7 @@
(let* ((terminal-width
(multiple-value-bind (rows cols)
(handler-case (nshell.infrastructure.acl:get-terminal-size)
- (error (condition) (values 24 80 condition)))
+ (error () (values 24 80)))
(declare (ignore rows))
cols))
(prompt-width
@@ -164,5 +160,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 5846fd2..4aee6e1 100644
--- a/t/integration/test-file-config.lisp
+++ b/t/integration/test-file-config.lisp
@@ -3,62 +3,63 @@
(describe "file-config-tests"
(it "file-config-missing-file"
"Loading a missing config file returns NIL."
- (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))))))
+ (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)))))
(it "file-config-roundtrip"
"Saving and loading config preserves the stored lines."
- (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))))))
+ (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)))))
(it "interactive-startup-sources-config"
"Interactive initialization applies .nshellrc through the normal source boundary."
- (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))))))
+ (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)))))
(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 e2dd88d..8aa4464 100644
--- a/t/integration/test-file-history.lisp
+++ b/t/integration/test-file-history.lisp
@@ -3,65 +3,64 @@
(describe "file-history-tests"
(it "file-history-append"
"Appending to file history works"
- (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))))))
+ (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)))))
(it "file-history-multiline-round-trip"
"Multiline command history survives persistence."
- (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))))))
+ (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)))))
(it "file-history-unframed-lines"
"Unframed history records are not loaded."
- (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))))))
+ (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)))))
(it "file-history-missing-file"
"Loading a missing history file returns NIL."
- (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)))))))
+ (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))))))
diff --git a/t/integration/test-terminal-presentation.lisp b/t/integration/test-terminal-presentation.lisp
index fa8738f..d986f4f 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,48 +24,50 @@
(it "terminal-execute-on-structural-incomplete-input-indents-continuation"
"REPL execution promotes structural incomplete input to an indented continuation."
(with-repl-test-state
- (dolist (line '("echo hi |" "echo hi &&" "if true"))
- (let ((expected (concatenate 'string line (string #\Newline) " ")))
+ (dolist (case '(("echo hi |" . "echo hi |~% ")
+ ("echo hi &&" . "echo hi &&~% ")
+ ("if true" . "if true~% ")))
+ (destructuring-bind (line . expected-format) case
(setf nshell.presentation::*input-state*
(nshell.presentation::make-repl-input-state :buffer line))
(capture-process-output-event :execute)
- (expect expected :to-equal (nshell.presentation:input-state-buffer
- nshell.presentation::*input-state*))
+ (expect (format nil expected-format) :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.highlight:highlight-line "| echo nope"))
+ (let* ((spans (nshell.presentation:highlight-line "| echo nope"))
(first-span (first spans)))
(expect (null first-span) :to-be-falsy)
- (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))))
+ (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))))
(it "terminal-highlight-span-constructor-is-internal-boundary"
"Highlight spans are produced by highlight-line rather than public raw construction."
- (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))
+ (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))
(it "terminal-highlight-span-type-is-internal-boundary"
"Highlight spans are opaque presentation values with public projections only."
- (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)))
+ (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)))
(it "terminal-highlight-span-raw-accessors-stay-internal"
"Highlight span projections stay behind explicit public accessors."
- (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))))
+ (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))))
(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 e2c941b..9b62460 100644
--- a/t/support/builtins.lisp
+++ b/t/support/builtins.lisp
@@ -29,18 +29,14 @@
:cwd (lambda () #p"/tmp/")
:chdir (lambda (path) (declare (ignore path)) t))
:process-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))
+ (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))
:redirect-fns
(list :redirect-output #'nshell.infrastructure.acl:redirect-output
:redirect-error #'nshell.infrastructure.acl:redirect-error
@@ -98,13 +94,13 @@
output-empty contains)
(append
(when (not (null code))
- `((expect ,actual-code :to-equal ,code)))
+ `((expect ,code :to-equal ,actual-code)))
(when output
- `((expect ,actual-output :to-equal ,output)))
+ `((expect ,output :to-equal ,actual-output)))
(when output-null
`((expect ,actual-output :to-be-null)))
(when output-empty
- `((expect ,actual-output :to-equal "")))
+ `((expect "" :to-equal ,actual-output)))
(when contains
`((expect (%builtin-output-contains-all-p ,actual-output ,contains) :to-be-truthy)))
`((values ,actual-output ,actual-code))))
@@ -143,8 +139,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 ,code :to-equal 0)
- (expect ,output :to-equal ,expected-output)
+ (expect 0 :to-equal ,code)
+ (expect ,expected-output :to-equal ,output)
,@extra-assertions))
(defmacro with-stubbed-command-executor ((&rest cases) &body body)
@@ -197,23 +193,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 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)
+ (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))))
,@(when body-contains
`((multiple-value-bind (output code)
(call-builtin ,context ,name (list ,key))
- (expect code :to-equal 0)
+ (expect 0 :to-equal code)
,@(mapcar (lambda (needle)
`(expect (search ,needle output) :to-be-truthy))
body-contains))))
(multiple-value-bind (output code)
(call-builtin ,context ,name nil)
- (expect code :to-equal 0)
+ (expect 0 :to-equal code)
(expect (search ,list-fragment output) :to-be-truthy))
(assert-builtin-call (,context ,name '("-e"))
:code 2
:output ,erase-error-output)
- (expect (nth-value 1 (call-builtin ,context ,name ,erase-args)) :to-equal 0)
+ (expect 0 :to-equal (nth-value 1 (call-builtin ,context ,name ,erase-args)))
(expect (gethash ,key ,table-form) :to-be-null)))
diff --git a/t/support/pbt-shell.lisp b/t/support/pbt-shell.lisp
index 21d9193..61434d7 100644
--- a/t/support/pbt-shell.lisp
+++ b/t/support/pbt-shell.lisp
@@ -20,23 +20,21 @@
t)))
(defun %default-test-process-fns ()
- (append
- (list :spawn (lambda (&rest args)
- (declare (ignore args))
- :spawned)
- :wait (lambda (&rest args)
+ (list :spawn (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)))
+ :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))))
(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 f5dccd6..a368719 100644
--- a/t/unit/test-builtins-core-io.lisp
+++ b/t/unit/test-builtins-core-io.lisp
@@ -30,113 +30,6 @@
: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 7e344ca..dde857e 100644
--- a/t/unit/test-builtins-source.lisp
+++ b/t/unit/test-builtins-source.lisp
@@ -130,8 +130,7 @@
process))
(with-temporary-function
('nshell.application::%background-process-pid
- (lambda (ignored-context proc)
- (declare (ignore ignored-context))
+ (lambda (proc)
(when (eq proc process)
4321)))
(with-called-source (output code context '("first arg & second"))
@@ -171,8 +170,7 @@
processes))
(with-temporary-function
('nshell.application::%background-process-pid
- (lambda (ignored-context proc)
- (declare (ignore ignored-context))
+ (lambda (proc)
(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 034c3b0..2c27b35 100644
--- a/t/unit/test-execute-pipeline.lisp
+++ b/t/unit/test-execute-pipeline.lisp
@@ -54,9 +54,7 @@
:process-exited
:pipeline-completed)
(nshell.domain.events:domain-event-type event)
- (expect 0 :to-equal
- (nshell.application:execute-pipeline-use-case
- ast dispatcher (%default-test-process-fns)))
+ (expect 0 :to-equal (nshell.application:execute-pipeline-use-case ast dispatcher))
(expect (nshell.application:drain-events dispatcher) :to-be-null)
(let ((delivered (nreverse events)))
(expect (member :pipeline-started delivered) :to-be-truthy)
@@ -71,8 +69,7 @@
(code nil)
(output (with-output-to-string (*standard-output*)
(setf code
- (nshell.application:execute-pipeline-use-case
- ast nil (%default-test-process-fns))))))
+ (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 0 :to-equal code)
(expect "pipeline-api" :to-equal output))))
@@ -85,8 +82,7 @@
(code nil))
(let ((error-output
(with-output-to-string (*error-output*)
- (setf code (nshell.application:execute-pipeline-use-case
- ast nil (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 127 :to-equal code)
(expect (format nil "nshell: $NSHELL_PIPELINE_CMD: command name expansion produced 2 fields~%") :to-equal error-output)))))
@@ -98,8 +94,7 @@
(code nil))
(let ((error-output
(with-output-to-string (*error-output*)
- (setf code (nshell.application:execute-pipeline-use-case
- ast nil (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 127 :to-equal code)
(expect (format nil "nshell: NSHELL_MISSING_REQUIRED: required value~%") :to-equal error-output))))
@@ -143,16 +138,16 @@
(unwind-protect
(progn
(ensure-directories-exist root)
- (expect 0 :to-equal
- (nshell.application:execute-pipeline-use-case
- ast nil (%default-test-process-fns)))
+ (expect 0 :to-equal (nshell.application:execute-pipeline-use-case ast nil))
(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))))
- (when (probe-file root)
- (host-kit:delete-directory-tree root :validate t)))))
+ (handler-case
+ (when (probe-file root)
+ (host-kit:delete-directory-tree root :validate t))
+ (error ())))))
(it "pipeline-stage-streams-opens-file-and-here-string-inputs"
"Pipeline stage setup materializes file and here-string input redirects."
@@ -250,8 +245,7 @@
(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 (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 0 :to-equal code)
(expect (format nil "3~%") :to-equal output)))
@@ -265,8 +259,7 @@
(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 (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 0 :to-equal code)
(expect (format nil "6~%") :to-equal output)))
@@ -281,8 +274,7 @@
(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 (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 0 :to-equal code)
(expect (format nil "3~%") :to-equal output)
(expect "OUT" :to-equal (host-kit:read-file-string target)))))
@@ -298,8 +290,7 @@
(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 (%default-test-process-fns))))))
+ (setf code (nshell.application:execute-pipeline-use-case ast nil)))))
(expect 0 :to-equal code)
(expect (format nil "0~%") :to-equal output)
(expect "OUTERR" :to-equal (host-kit:read-file-string target)))))
@@ -309,9 +300,7 @@
(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 (%default-test-process-fns)))))
+ (expect 127 :to-equal (nshell.application:execute-pipeline-use-case ast nil))))
(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."
@@ -444,8 +433,7 @@
(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 ((context (make-test-shell-context))
- (released nil))
+ (let ((released nil))
(with-temporary-functions
(((quote nshell.infrastructure.acl:release-process-substitution-fd)
(lambda (resource)
@@ -453,12 +441,10 @@
(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 ((context (make-test-shell-context))
- (waited nil)
+ (let ((waited nil)
(released nil)
(closed nil))
(with-temporary-functions
@@ -473,8 +459,8 @@
((quote nshell.infrastructure.acl:close-process-substitution)
(lambda (resource)
(push resource closed))))
- (nshell.application::%finish-process-substitution-resources context (list :ok :bad))
- (nshell.application::%abort-process-substitution-resources context (list :left :right)))
+ (nshell.application::%finish-process-substitution-resources (list :ok :bad))
+ (nshell.application::%abort-process-substitution-resources (list :left :right)))
(expect (list :bad :ok) :to-equal waited)
(expect (list :bad :ok) :to-equal released)
(expect (list :right :left) :to-equal closed)))
@@ -486,7 +472,6 @@
(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))
@@ -574,8 +559,7 @@
(declare (ignore ignored-context))
(values commands nil (list :nested))))
((quote nshell.application::%abort-process-substitution-resources)
- (lambda (ignored-context resources)
- (declare (ignore ignored-context))
+ (lambda (resources)
(setf aborted resources))))
(multiple-value-bind (path resource error)
(nshell.application::%materialize-process-substitution-in-context
@@ -616,8 +600,8 @@
(declare (ignore ignored-context value))
(values nil nil "substitution failed")))
((quote nshell.application::%abort-process-substitution-resources)
- (lambda (ignored-context resources)
- (declare (ignore ignored-context resources))
+ (lambda (resources)
+ (declare (ignore resources))
(setf abort-called t))))
(multiple-value-bind (args resources error)
(nshell.application::%expand-command-args-in-context context command)
@@ -644,8 +628,7 @@
(values command nil (list :resource))
(values nil "node failed" nil))))
((quote nshell.application::%abort-process-substitution-resources)
- (lambda (ignored-context resources)
- (declare (ignore ignored-context))
+ (lambda (resources)
(setf aborted resources))))
(multiple-value-bind (commands error resources)
(nshell.application::%expand-command-nodes-in-context
@@ -656,8 +639,7 @@
(expect error :to-equal "node failed")
(expect aborted :to-equal (list :resource))))))
(it "os-process-substitution-pipeline-releases-resources-after-spawn"
- (let ((context (make-test-shell-context))
- (captured nil)
+ (let ((captured nil)
(released nil)
(waited nil))
(with-temporary-functions
@@ -679,7 +661,6 @@
(push resource waited))))
(multiple-value-bind (output code)
(nshell.application::%execute-os-pipeline-with-process-substitutions
- context
'(:command)
nil
(list :resource)
@@ -690,8 +671,7 @@
(expect released :to-equal (list :resource :resource))
(expect waited :to-equal (list :resource))))))
(it "os-process-substitution-pipeline-aborts-on-spawn-failure"
- (let ((context (make-test-shell-context))
- (closed nil))
+ (let ((closed nil))
(with-temporary-functions
(((quote nshell.infrastructure.acl:process-substitution-resource-fd)
(lambda (resource)
@@ -706,7 +686,6 @@
(push resource closed))))
(multiple-value-bind (output code)
(nshell.application::%execute-os-pipeline-with-process-substitutions
- context
'(:command)
nil
(list :resource)
@@ -724,8 +703,7 @@
(declare (ignore ignored-context ignored-command))
(values command nil (list :resource))))
((quote nshell.application::%abort-process-substitution-resources)
- (lambda (ignored-context resources)
- (declare (ignore ignored-context))
+ (lambda (resources)
(setf aborted resources))))
(multiple-value-bind (output code)
(nshell.application::execute-command-node-in-context context command)
@@ -745,8 +723,7 @@
nil
(list :resource))))
((quote nshell.application::%abort-process-substitution-resources)
- (lambda (ignored-context resources)
- (declare (ignore ignored-context))
+ (lambda (resources)
(setf aborted resources))))
(multiple-value-bind (output code)
(nshell.application::execute-pipeline-node-in-context context pipeline)
@@ -765,8 +742,8 @@
nil
(list :resource))))
((quote nshell.application::%execute-os-pipeline-with-process-substitutions)
- (lambda (ignored-context commands redirects resources pipefail-p)
- (declare (ignore ignored-context commands redirects resources pipefail-p))
+ (lambda (commands redirects resources pipefail-p)
+ (declare (ignore 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 ec70d6d..1782e4c 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 4ad7dd4..88f744f 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 (list 'setf 'nshell.application:job-listing-command)) :to-be-falsy)
+ (expect (fboundp '(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,17 +79,9 @@
(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.application:*foreground-job-pgid* nil)
+ (nshell.infrastructure.acl::*foreground-pgid* 0))
(with-temporary-functions
(('nshell.application::%continue-process-group
(lambda (pgid)
@@ -100,15 +92,19 @@
(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 foreground-pgid)
+ (expect 4321 :to-equal nshell.infrastructure.acl::*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 process-fns)
+ (nshell.application:fg job-id nil nil nil monitor)
(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 foreground-pgid)
+ (expect 0 :to-equal nshell.infrastructure.acl::*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."
@@ -117,17 +113,9 @@
(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.application:*foreground-job-pgid* nil)
+ (nshell.infrastructure.acl::*foreground-pgid* 0))
(with-event-capture (continued dispatcher :job-continued)
(nshell.domain.events:domain-event-type event)
(with-temporary-functions
@@ -140,11 +128,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 foreground-pgid)
+ (expect 4321 :to-equal nshell.infrastructure.acl::*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 process-fns)))
+ (nshell.application:fg job-id dispatcher nil nil monitor)))
(expect (nshell.application:drain-events dispatcher) :to-be-null)
(expect '(1000 4321) :to-equal set-foreground-calls)
(expect '(:job-continued) :to-equal (nreverse continued)))))
@@ -248,19 +240,19 @@
(let ((nshell.application:*shell-pgid* 1000)
(nshell.application:*foreground-job-pgid* nil))
(with-temporary-function
- ('nshell.application::%get-foreground-pgroup
+ ('nshell.infrastructure.acl: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.application::%get-foreground-pgroup
+ ('nshell.infrastructure.acl: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.application::%get-foreground-pgroup
+ ('nshell.infrastructure.acl:get-foreground-pgroup
(lambda () 2000))
(expect 2000 :to-equal (nshell.application::%foreground-signal-target-pgid)))))
@@ -313,7 +305,7 @@
(calls nil))
(nshell.domain.job-control:background-job monitor job-id)
(with-temporary-function
- ((quote nshell.application::%kill-process)
+ ((quote nshell.infrastructure.acl:kill-process)
(lambda (pid signal)
(push (list pid signal) calls)
0))
@@ -379,14 +371,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 :echild))
+ (nshell.application::%classify-job-wait-error sb-posix:echild))
(interrupted
- (nshell.application::%classify-job-wait-error :eintr))
+ (nshell.application::%classify-job-wait-error sb-posix:eintr))
(unknown-errno
- (nshell.application::%classify-job-wait-error :enoent)))
+ (1+ (max sb-posix:echild sb-posix:eintr))))
(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
- unknown-errno))))
+ (nshell.application::%classify-job-wait-error unknown-errno)))))