Vendor Linux build dependencies
ober
a7fddd21f31502aed3fd000eea5c6c09bea42a2c
--- a/.gitignore +++ b/.gitignore @@ -29,6 +29,8 @@ qt-main.so qt-main.wpo jemacs-qt-all.so vterm_shim.so +pty_shim.so +support/pty_shim.so chez_pty_shim.so chez_scintilla_shim.so libqt_shim.so @@ -39,6 +41,13 @@ qt_chez_shim.so # Vendored repos (cloned, not submodules) vendor/jerboa/ vendor/jerboa-shell/ +vendor/jerboa-pcre2/ +vendor/jerboa-scintilla/ +vendor/jerboa-qt/ +vendor/jerboa-ssl/ +vendor/jerboa-https/ +vendor/jsqlite/ +vendor/jerboa-lsp/ vendor/jerboa-aws/ vendor/chez-pcre2/ vendor/chez-scintilla/ --- a/Makefile +++ b/Makefile @@ -1,19 +1,5 @@ VENDOR ?= $(CURDIR)/vendor -JERBOA_VERSION ?= v0.2.0 -JERBOA_TOOL_DIR ?= $(CURDIR)/.jerboa/bin -JERBUILD_BIN ?= $(shell if [ -x ./jerbuild ] && [ -x ./jerboa ]; then \ - printf '%s\n' "$(CURDIR)/jerbuild"; \ -elif [ -x "$(JERBOA_TOOL_DIR)/jerbuild" ] && [ -x "$(JERBOA_TOOL_DIR)/jerboa" ]; then \ - printf '%s\n' "$(JERBOA_TOOL_DIR)/jerbuild"; \ -elif [ -x ../jerboa/dist/jerbuild ] && [ -x ../jerboa/dist/jerboa ]; then \ - printf '%s\n' "$(abspath ../jerboa/dist/jerbuild)"; \ -elif command -v jerbuild >/dev/null 2>&1 && command -v jerboa >/dev/null 2>&1; then \ - command -v jerbuild; \ -else \ - printf '%s\n' "$(JERBOA_TOOL_DIR)/jerbuild"; \ -fi) - JERBOA_REPO ?= https://git.sr.ht/~lisp/jerboa JERBOA_SHELL_REPO ?= https://git.sr.ht/~lisp/jerboa-shell JERBOA_PCRE2_REPO ?= https://git.sr.ht/~lisp/jerboa-pcre2 @@ -21,6 +7,8 @@ JERBOA_SCINTILLA_REPO ?= https://git.sr.ht/~lisp/jerboa-scintilla JERBOA_QT_REPO ?= https://git.sr.ht/~lisp/jerboa-qt JERBOA_SSL_REPO ?= https://git.sr.ht/~lisp/jerboa-ssl JERBOA_HTTPS_REPO ?= https://git.sr.ht/~lisp/jerboa-https +JSQLITE_REPO_URL ?= https://git.sr.ht/~lisp/jsqlite +JERBOA_LSP_REPO ?= https://git.sr.ht/~lisp/jerboa-lsp JERBOA_AWS_REPO ?= https://git.sr.ht/~lisp/jerboa-aws JEMACS_FEATURES ?= @@ -40,12 +28,14 @@ else endif JEMACS_ENABLE_AWS := $(if $(filter aws,$(JEMACS_ENABLED_FEATURES)),1,0) -VENDOR_REPOS := jerboa jerboa-shell jerboa-pcre2 jerboa-scintilla jerboa-qt jerboa-ssl jerboa-https +VENDOR_REPOS := jerboa jerboa-shell jerboa-pcre2 jerboa-scintilla jerboa-qt jerboa-ssl jerboa-https jsqlite jerboa-lsp ifeq ($(JEMACS_ENABLE_AWS),1) VENDOR_REPOS += jerboa-aws endif JERBOA ?= $(VENDOR)/jerboa +VENDORED_JERBOA ?= $(JERBOA)/dist/jerboa +VENDORED_JERBUILD ?= $(JERBOA)/dist/jerbuild SCHEME ?= $(JERBOA)/.chez/bin/scheme JSH_ROOT ?= $(VENDOR)/jerboa-shell JSH ?= $(JSH_ROOT)/src @@ -57,6 +47,9 @@ JERBOA_SSH ?= $(JSH_VENDOR)/jerboa-ssh/src JERBOA_SQLITE ?= $(JSH_VENDOR)/jerboa-sqlite/src JERBOA_CRYPTO ?= $(JSH_VENDOR)/jerboa-crypto/src JERBOA_FUSE ?= $(JSH_VENDOR)/jerboa-fuse/lib +JSQLITE_ROOT ?= $(VENDOR)/jsqlite +JSQLITE_DIR ?= $(JSQLITE_ROOT)/src +JSQLITE_LIBDIR ?= $(JSH_ROOT)/_jerbuild-stage JAWS_ROOT ?= $(VENDOR)/jerboa-aws JAWS ?= $(JAWS_ROOT)/lib JERBOA_SSL_ROOT ?= $(VENDOR)/jerboa-ssl @@ -72,8 +65,8 @@ AWS_LIBDIRS := ifeq ($(JEMACS_ENABLE_AWS),1) AWS_LIBDIRS := :$(JAWS):$(CSSL):$(CHTTPS) endif -LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(COREUTILS):$(JSH_AWK):$(JSH_SED):$(JERBOA_SSH):$(JERBOA_SQLITE):$(JERBOA_CRYPTO):$(JERBOA_FUSE):$(JERBOA_PCRE2_LIBDIR):$(JERBOA_SCINTILLA_LIBDIR):$(CQT)$(AWS_LIBDIRS) -JERBUILD ?= $(JERBUILD_BIN) transpile +LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(JSQLITE_LIBDIR):$(COREUTILS):$(JSH_AWK):$(JSH_SED):$(JERBOA_SSH):$(JERBOA_SQLITE):$(JERBOA_CRYPTO):$(JERBOA_FUSE):$(JERBOA_PCRE2_LIBDIR):$(JERBOA_SCINTILLA_LIBDIR):$(CQT)$(AWS_LIBDIRS) +JERBUILD ?= $(VENDORED_JERBUILD) transpile # --- Platform detection ------------------------------------------------------- UNAME_S := $(shell uname -s) @@ -127,7 +120,7 @@ SCHEME_CHEZ_DIR = $(shell if [ -n "$(SCHEME_MT)" ]; then ls -d "$(SCHEME_PREFIX) CHEZ_DIR ?= $(SCHEME_CHEZ_DIR) export CHEZ_DIR -.PHONY: all vendor-deps check-pcre2-system-deps deps ensure-jerboa-tools scintilla-vendor-deps scintilla-vendor-clean build rebuild run test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-org test-extra test clean clean-generated \ +.PHONY: all vendor-deps check-pcre2-system-deps check-vterm-system-deps deps ensure-vendor-jerboa-tools scintilla-vendor-deps scintilla-vendor-clean build rebuild run test-tier0 test-tier2 test-tier3 test-tier4 test-tier5 test-org test-extra test clean clean-generated \ test-org-duration test-org-element test-org-fold test-org-footnote \ test-org-lint test-org-num test-org-property test-org-src test-org-tempo \ test-vtscreen test-debug-repl test-qt test-qt-e2e build-qt binary-qt \ @@ -146,8 +139,8 @@ export CHEZ_DIR all: @echo "Available targets:" - @echo " vendor-deps Clone required chez-* and jerboa-* deps into vendor/" - @echo " ensure-jerboa-tools Ensure jerboa/jerbuild are available" + @echo " vendor-deps Clone required dependencies into vendor/" + @echo " ensure-vendor-jerboa-tools Build vendor/jerboa/dist/{jerboa,jerbuild}" @echo " scintilla-vendor-deps Fetch/build Scintilla, Lexilla, and termbox archives" @echo " build Translate src/*.ss → lib/*.sls (incremental)" @echo " rebuild Force full retranslation" @@ -171,7 +164,7 @@ all: @echo " JEMACS_FEATURES=aws make <target> Enable optional AWS EC2 SSH support" vendor-deps: - @echo "=== Vendoring chez-* and jerboa-* dependencies into $(VENDOR) ===" + @echo "=== Vendoring dependencies into $(VENDOR) ===" @mkdir -p $(VENDOR) @for repo in $(VENDOR_REPOS); do \ case "$$repo" in \ @@ -182,6 +175,8 @@ vendor-deps: jerboa-qt) url="$(JERBOA_QT_REPO)" ;; \ jerboa-ssl) url="$(JERBOA_SSL_REPO)" ;; \ jerboa-https) url="$(JERBOA_HTTPS_REPO)" ;; \ + jsqlite) url="$(JSQLITE_REPO_URL)" ;; \ + jerboa-lsp) url="$(JERBOA_LSP_REPO)" ;; \ jerboa-aws) url="$(JERBOA_AWS_REPO)" ;; \ esac; \ dest="$(VENDOR)/$$repo"; \ @@ -204,6 +199,7 @@ vendor-deps: git clone --depth 1 "$$url" "$$dest"; \ fi; \ done + @sh scripts/patch-jerboa-shell-compat.sh "$(CURDIR)" @scripts/patch-jerboa-aws-compat.sh "$(CURDIR)" @echo "=== Vendor complete ===" @@ -224,36 +220,30 @@ check-pcre2-system-deps: fi; \ rm -f "$$tmp.c" "$$tmp" -deps: check-pcre2-system-deps vendor-deps - $(MAKE) -C $(JSH_ROOT) vendor-deps +deps: check-pcre2-system-deps vendor-deps ensure-vendor-jerboa-tools + $(MAKE) -C $(JSH_ROOT) JERBUILD="$(VENDORED_JERBUILD)" JSQLITE_REPO="$(abspath $(JSQLITE_ROOT))" JSQLITE_DIR="$(abspath $(JSQLITE_DIR))" vendor-deps + sh scripts/patch-jerboa-shell-compat.sh "$(CURDIR)" + $(MAKE) -C $(JSH_ROOT) JERBUILD="$(VENDORED_JERBUILD)" JSQLITE_REPO="$(abspath $(JSQLITE_ROOT))" JSQLITE_DIR="$(abspath $(JSQLITE_DIR))" stage-jsqlite + $(MAKE) -C $(JSH_ROOT) JERBUILD="$(VENDORED_JERBUILD)" JSQLITE_REPO="$(abspath $(JSQLITE_ROOT))" JSQLITE_DIR="$(abspath $(JSQLITE_DIR))" jerboa + $(MAKE) -C $(JSH_ROOT) JERBUILD="$(VENDORED_JERBUILD)" JSQLITE_REPO="$(abspath $(JSQLITE_ROOT))" JSQLITE_DIR="$(abspath $(JSQLITE_DIR))" gen-embed </dev/null $(MAKE) -C $(JERBOA) build - $(MAKE) -C $(JERBOA_PCRE2_ROOT) SCHEME=$(SCHEME) JERBOA_HOME=$(JERBOA) JERBUILD=$(JERBUILD_BIN) - $(MAKE) -C $(JERBOA_SCINTILLA_ROOT) JERBOA_HOME=$(JERBOA) JERBUILD=$(JERBUILD_BIN) transpile - -ensure-jerboa-tools: - @if [ -x ./jerbuild ] && [ -x ./jerboa ]; then \ - echo "=== Using project-local ./jerbuild ==="; \ - elif [ -x "$(JERBOA_TOOL_DIR)/jerbuild" ] && [ -x "$(JERBOA_TOOL_DIR)/jerboa" ]; then \ - echo "=== Using downloaded Jerboa toolchain: $(JERBOA_TOOL_DIR) ==="; \ - elif [ -x ../jerboa/dist/jerbuild ] && [ -x ../jerboa/dist/jerboa ]; then \ - echo "=== Using sibling Jerboa build: ../jerboa/dist/jerbuild ==="; \ - elif command -v jerbuild >/dev/null 2>&1 && command -v jerboa >/dev/null 2>&1; then \ - echo "=== Using Jerboa toolchain from PATH: $$(command -v jerbuild) ==="; \ + $(MAKE) -C $(JERBOA_PCRE2_ROOT) SCHEME=$(SCHEME) JERBOA_HOME=$(JERBOA) JERBUILD=$(VENDORED_JERBUILD) + $(MAKE) -C $(JERBOA_SCINTILLA_ROOT) JERBOA_HOME=$(JERBOA) JERBUILD=$(VENDORED_JERBUILD) transpile + +ensure-vendor-jerboa-tools: vendor-deps + @if [ -x "$(VENDORED_JERBUILD)" ] && [ -x "$(VENDORED_JERBOA)" ]; then \ + echo "=== Using vendored Jerboa toolchain: $(VENDORED_JERBUILD) ==="; \ else \ - echo "=== Fetching Jerboa $(JERBOA_VERSION) release tools into $(JERBOA_TOOL_DIR) ==="; \ - sh support/ensure-jerboa.sh "$(JERBOA_VERSION)" "$(JERBOA_TOOL_DIR)"; \ + echo "=== Building vendored Jerboa toolchain in $(JERBOA)/dist ==="; \ + $(MAKE) -C $(JERBOA) jerboa; \ fi - @"$(JERBUILD_BIN)" --jerboa-home >/dev/null || { \ - echo "ERROR: Jerboa toolchain is unavailable; set JERBUILD_BIN=/path/to/jerbuild or JERBOA_VERSION=<tag>"; \ - exit 1; \ - } # Generate lib/jerboa-emacs/*.sls from src/jerboa-emacs/*.ss (incremental) -build: ensure-jerboa-tools deps +build: deps $(JERBUILD) src/ lib/ # Force regenerate all -rebuild: ensure-jerboa-tools deps +rebuild: deps $(JERBUILD) src/ lib/ --force check-generated: @@ -269,9 +259,26 @@ repl_shim.$(SHLIB_EXT): support/repl_shim.c VTERM_CFLAGS := $(shell pkg-config --cflags vterm 2>/dev/null) VTERM_LIBS := $(shell pkg-config --libs vterm 2>/dev/null || echo -lvterm) +check-vterm-system-deps: + @tmp="$${TMPDIR:-/tmp}/jemacs-vterm-check-$$$$"; \ + printf '%s\n' '#include <vterm.h>' 'int main(void) { return 0; }' > "$$tmp.c"; \ + if ! $(CC) $(VTERM_CFLAGS) "$$tmp.c" -o "$$tmp" $(VTERM_LIBS) >/dev/null 2>&1; then \ + rm -f "$$tmp.c" "$$tmp"; \ + echo "ERROR: libvterm development headers/libraries are required for make binary." >&2; \ + echo "Install them first, then rerun make binary." >&2; \ + echo " Debian/Ubuntu: sudo apt-get install libvterm-dev" >&2; \ + echo " Fedora: sudo dnf install libvterm-devel" >&2; \ + echo " macOS: brew install libvterm" >&2; \ + exit 1; \ + fi; \ + rm -f "$$tmp.c" "$$tmp" + vterm_shim.$(SHLIB_EXT): support/vterm_shim.c gcc $(SHLIB_FLAGS) -O2 $(VTERM_CFLAGS) -o vterm_shim.$(SHLIB_EXT) support/vterm_shim.c $(VTERM_LIBS) -Wall +pty_shim.$(SHLIB_EXT): support/pty_shim.c + gcc $(SHLIB_FLAGS) -O2 -o pty_shim.$(SHLIB_EXT) support/pty_shim.c $(PTY_LINK) -Wall + support/pty_shim.$(SHLIB_EXT): support/pty_shim.c gcc $(SHLIB_FLAGS) -O2 -o support/pty_shim.$(SHLIB_EXT) support/pty_shim.c $(PTY_LINK) -Wall @@ -363,7 +370,7 @@ $(NATIVE_LIB): $(MAKE) -C $(JERBOA) native $(SSL_SHIM): $(JERBOA_SSL_ROOT)/jerboa_ssl_shim.c - $(MAKE) -C $(JERBOA_SSL_ROOT) JERBOA_HOME=$(JERBOA) SCHEME=$(SCHEME) JERBUILD=$(JERBUILD_BIN) + $(MAKE) -C $(JERBOA_SSL_ROOT) JERBOA_HOME=$(JERBOA) SCHEME=$(SCHEME) JERBUILD=$(VENDORED_JERBUILD) # macOS native binary — compile all modules + link jemacs-qt binary macos: build libqt_shim.$(SHLIB_EXT) jerboa_qt_shim.$(SHLIB_EXT) repl_shim.$(SHLIB_EXT) vterm_shim.$(SHLIB_EXT) @@ -608,10 +615,10 @@ $(SCI_VENDOR_TERMBOX_H): $(SCI_VENDOR_TB_H) git clone --depth 1 $(TERMBOX_URL) $(SCI_VENDOR_TERMBOX_DIR) $(SCI_VENDOR_TERMBOX_A): $(SCI_VENDOR_TERMBOX_H) - $(MAKE) -C $(SCI_VENDOR_TERMBOX_DIR) FLAGS+="-fPIC" + $(MAKE) -C $(SCI_VENDOR_TERMBOX_DIR) FLAGS="-std=c99 -pedantic -Wall -Werror -g -fPIC -D_POSIX_C_SOURCE=200809L -D_XOPEN_SOURCE=700" $(SCI_VENDOR_SCINTILLA_A): $(SCI_VENDOR_SCINTILLA_H) $(SCI_VENDOR_TB_H) $(SCI_VENDOR_TERMBOX_A) - $(MAKE) -C $(SCI_VENDOR_TB_DIR) EXTRA_FLAGS="-fPIC" + $(MAKE) -C $(SCI_VENDOR_TB_DIR) EXTRA_FLAGS="-fPIC -include cstdint" $(SCI_VENDOR_LEXILLA_A): $(SCI_VENDOR_LEXILLA_H) $(SCI_VENDOR_SCINTILLA_H) $(MAKE) -C $(SCI_VENDOR_LEXILLA_DIR)/src @@ -643,7 +650,7 @@ pcre2_shim.$(SHLIB_EXT): jerboa_pcre2_shim.$(SHLIB_EXT) # TUI binary: embeds all Scheme code, links dynamically against system libs. # Shims must be in the same directory as the binary (jemacs-main.c sets JERBOA_SCINTILLA_LIB # and JERBOA_PCRE2_LIB to dirname(binary) when not already set in environment). -binary: build vterm_shim.$(SHLIB_EXT) jerboa_scintilla_shim.$(SHLIB_EXT) jerboa_pcre2_shim.$(SHLIB_EXT) +binary: check-vterm-system-deps build pty_shim.$(SHLIB_EXT) vterm_shim.$(SHLIB_EXT) jerboa_scintilla_shim.$(SHLIB_EXT) jerboa_pcre2_shim.$(SHLIB_EXT) find vendor/jerboa-shell -name '*.wpo' -delete 2>/dev/null; true JERBOA_PCRE2_DIR=$(JERBOA_PCRE2_LIBDIR) JERBOA_PCRE2_ROOT=$(JERBOA_PCRE2_ROOT) \ JERBOA_SCINTILLA_DIR=$(JERBOA_SCINTILLA_LIBDIR) SCI_VENDOR_DIR=$(SCINTILLA_VENDOR) \ --- a/README.md +++ b/README.md @@ -21,14 +21,17 @@ The TUI backend runs in a terminal using Scintilla's text model. The Qt backend | Chez Scheme ≥ 9.6 | Scheme runtime | system | | jerboa | Gerbil-compat stdlib | `vendor/jerboa` | | jerboa-shell (jsh) | Shell interpreter | `vendor/jerboa-shell` | +| jsqlite | SQLite bindings used by jsh | `vendor/jsqlite` | +| jerboa-lsp | Optional Jerboa language server | `vendor/jerboa-lsp` | | jerboa-scintilla | Scintilla editor FFI | `vendor/jerboa-scintilla` | | jerboa-pcre2 | PCRE2 regex FFI | `vendor/jerboa-pcre2` | | PCRE2 development headers | Native regex library | system | +| libvterm development headers | Terminal emulation shim for `make binary` | system | On Debian/Ubuntu, install the native build prerequisites with: ```bash -sudo apt-get install build-essential pkg-config libpcre2-dev +sudo apt-get install build-essential pkg-config libpcre2-dev libvterm-dev ``` ### Additional (Qt backend) @@ -45,9 +48,8 @@ All commands run from the project root. ### Jerboa build tools -`make build` and `make binary` use project-local `./jerbuild` first, then -`.jerboa/bin`, then `../jerboa/dist`, then `PATH`, and download the matching -Jerboa release artifact if none are available. The editor still vendors and +`make build` and `make binary` build and use the vendored Jerboa multicall +toolchain at `vendor/jerboa/dist/{jerboa,jerbuild}`. The editor vendors and builds its native Scheme/FFI dependencies under `vendor/`. ### Vendor dependencies @@ -56,7 +58,8 @@ builds its native Scheme/FFI dependencies under `vendor/`. make vendor-deps ``` -This clones required `chez-*` and `jerboa-*` repositories into `vendor/` from their SourceHut remotes. The default `make build` target runs this first. +This clones required dependencies into `vendor/` from their SourceHut remotes. +The default `make build` target runs this first. ### Build library modules --- a/build-binary.ss +++ b/build-binary.ss @@ -294,6 +294,13 @@ (display "Error: jsh_coreutils_stubs.c compilation failed\n") (exit 1))) + ;; jerboa native Rust crypto stubs. The TUI binary does not ship + ;; libjerboa_native, but some vendored modules bind these symbols at load. + (let* ((cmd "gcc -c -O2 -o jemacs-jerboa-native-stubs.o support/jerboa_native_stubs.c -Wall 2>&1")) + (unless (= 0 (system cmd)) + (display "Error: jerboa_native_stubs.c compilation failed\n") + (exit 1))) + ;; embed-crypto. Older jsh trees had embed-crypto.c; newer ones use ;; libjerboa_native. If neither is available, compile explicit failing stubs ;; so non-embed editor features still link and encrypted embed calls fail. @@ -350,7 +357,7 @@ ;; Compiled against the static scintilla headers from sci-vendor-dir (let* ((sci-include (format "-I~a/scintilla/include -I~a/scintilla/src -I~a/scintilla/termbox -I~a/scintilla/termbox/termbox_next/src -I~a/lexilla/include" sci-vendor-dir sci-vendor-dir sci-vendor-dir sci-vendor-dir sci-vendor-dir)) - (sci-shim-c (format "~a/../jerboa_scintilla_shim.c" sci-dir)) + (sci-shim-c (repo-path "jerboa_scintilla_shim.c")) (cmd (format "gcc -c -O2 -o jemacs-sci-shim.o ~a ~a -Wall 2>&1" sci-shim-c sci-include))) (unless (= 0 (system cmd)) @@ -454,6 +461,11 @@ echo OK" (unless (= 0 (system cmd)) (display "Error: jsh_coreutils_stubs.c (dynamic) compilation failed\n") (exit 1))) + ;; jerboa native Rust crypto stubs + (let* ((cmd "gcc -c -O2 -o jemacs-jerboa-native-stubs.o support/jerboa_native_stubs.c -Wall 2>&1")) + (unless (= 0 (system cmd)) + (display "Error: jerboa_native_stubs.c (dynamic) compilation failed\n") + (exit 1))) ;; TLS rustls stubs (jerboa_tls_* Rust FFI symbols — jemacs TUI doesn't use HTTPS) (let ((stub-file "jemacs-tls-stubs.c")) (call-with-output-file stub-file @@ -473,7 +485,7 @@ echo OK" (fprintf out "void jerboa_tls_close(uint64_t s) {}~n") (fprintf out "int jerboa_tls_set_nonblock(uint64_t s, int nb) { return -1; }~n") (fprintf out "int jerboa_tls_get_fd(uint64_t s) { return -1; }~n") - (fprintf out "size_t jerboa_last_error(uint8_t *buf, size_t len) { return 0; }~n")) + (fprintf out "/* jerboa_last_error is provided by jerboa_native_stubs.c. */~n")) 'replace) (let ((cmd "gcc -c -O2 -o jemacs-tls-stubs.o jemacs-tls-stubs.c -Wall 2>&1")) (unless (= 0 (system cmd)) @@ -502,7 +514,7 @@ echo OK" (cmd (format "g++ -static -Wl,--export-dynamic -o jemacs \ jemacs-main.o jemacs-pcre2-shim.o jemacs-jsh-ffi.o \ jemacs-libcoreutils.o jemacs-jsh-coreutils-stubs.o \ -jemacs-embed-crypto.o jemacs-ssh-agent-stub.o \ +jemacs-jerboa-native-stubs.o jemacs-embed-crypto.o jemacs-ssh-agent-stub.o \ jemacs-pty-shim.o jemacs-vterm-shim.o jemacs-repl-shim.o \ jemacs-jerboa-landlock.o jemacs-sci-shim.o \ tui_static_symbols.o \ @@ -529,7 +541,7 @@ tui_static_symbols.o \ jemacs-main.o jemacs-pcre2-shim.o jemacs-repl-shim.o \ jemacs-jsh-ffi.o jemacs-libcoreutils.o jemacs-embed-crypto.o \ jemacs-ssh-agent-stub.o jemacs-jsh-coreutils-stubs.o \ -jemacs-tls-stubs.o \ +jemacs-jerboa-native-stubs.o jemacs-tls-stubs.o \ -L~a -lkernel -llz4 -lz \ ~a ~a \ -lm -ldl -lpthread ~a 2>&1" --- a/jemacs-main.c +++ b/jemacs-main.c @@ -104,6 +104,10 @@ int main(int argc, char *argv[]) { setenv("JERBOA_SCINTILLA_LIB", dir, 0); if (!getenv("JERBOA_PCRE2_LIB")) setenv("JERBOA_PCRE2_LIB", dir, 0); + if (!getenv("JERBOA_EMACS_SUPPORT")) + setenv("JERBOA_EMACS_SUPPORT", dir, 0); + if (!getenv("JEMACS_BINARY_DIR")) + setenv("JEMACS_BINARY_DIR", dir, 0); } /* Create a file for the embedded program .so. Linux can avoid touching deleted file mode 100644 --- a/lib/jerboa-emacs/pty.sls +++ /dev/null @@ -1,161 +0,0 @@ -#!chezscheme -;;; pty.sls — PTY (pseudo-terminal) subprocess support -;;; -;;; Ported from chez-emacs/pty.ss -;;; UPGRADE: Uses C shim .so + foreign-procedure instead of begin-ffi/c-lambda. - -(library (jerboa-emacs pty) - (export pty-spawn - pty-openpty - pty-read - pty-last-errno - pty-write - pty-close! - pty-kill! - pty-resize! - pty-waitpid - pty-child-alive?) - (import (except (chezscheme) - make-hash-table hash-table? iota 1+ 1- - getenv path-extension path-absolute? thread? - make-mutex mutex? mutex-name) - (jerboa core) - (jerboa runtime) - (std sugar) - (std string)) - - ;;; ======================================================================== - ;;; Load the C shim shared library - ;;; ======================================================================== - - (define static-build? - (let ((v (getenv "JEMACS_STATIC"))) - (and v (not (string=? v "")) (not (string=? v "0"))))) - - (define shlib-ext - (if (string-contains (symbol->string (machine-type)) "osx") "dylib" "so")) - - (define pty-shim-loaded - (if static-build? - #f ; symbols already linked in via Sforeign_symbol registration - (load-shared-object - (let ((dir (or (getenv "JERBOA_EMACS_SUPPORT") - (string-append (or (getenv "HOME") ".") "/mine/jerboa-emacs/support")))) - (string-append dir "/pty_shim." shlib-ext))))) - - ;;; ======================================================================== - ;;; FFI bindings - ;;; ======================================================================== - - (define ffi-pty-spawn - (foreign-procedure "pty_spawn" (string string int int) int)) - (define ffi-pty-get-master-fd - (foreign-procedure "pty_get_master_fd" () int)) - (define ffi-pty-get-child-pid - (foreign-procedure "pty_get_child_pid" () int)) - (define ffi-pty-read - (foreign-procedure "pty_read" (int u8* int) int)) - (define ffi-pty-write - (foreign-procedure "pty_write" (int string int) int)) - (define ffi-pty-close - (foreign-procedure "pty_close" (int) void)) - (define ffi-pty-kill - (foreign-procedure "pty_kill" (int int) int)) - (define ffi-pty-resize - (foreign-procedure "pty_resize" (int int int) int)) - (define ffi-pty-waitpid - (foreign-procedure "pty_waitpid" (int int) int)) - (define ffi-pty-waitpid-status - (foreign-procedure "pty_get_wait_status" () int)) - (define ffi-pty-last-errno - (foreign-procedure "pty_last_errno" () int)) - (define ffi-pty-openpty - (foreign-procedure "pty_openpty" (int int) int)) - (define ffi-pty-get-open-slave-fd - (foreign-procedure "pty_get_open_slave_fd" () int)) - - ;;; ======================================================================== - ;;; Scheme-level API - ;;; ======================================================================== - - (def (pty-openpty rows cols) - "Create a PTY pair without spawning a child process. - Returns (values master-fd slave-fd) on success, (values #f #f) on failure." - (let ((master-fd (ffi-pty-openpty rows cols))) - (if (>= master-fd 0) - (values master-fd (ffi-pty-get-open-slave-fd)) - (values #f #f)))) - - (def (pty-spawn cmd env-alist rows cols) - (let* ((env-str (env-alist->string env-alist)) - (result (ffi-pty-spawn cmd env-str rows cols))) - (if (> result 0) - (values (ffi-pty-get-master-fd) result) - (values #f #f)))) - - (def (pty-read master-fd) - "Read from PTY master fd. - Returns: string (data), #f (EAGAIN/retry), 'eof (true EOF), or 'error (fatal)." - (let* ((buf (make-bytevector 4096 0)) - (n (ffi-pty-read master-fd buf 4095))) - (cond - ((> n 0) - (let ((sub (make-bytevector n))) - (bytevector-copy! buf 0 sub 0 n) - (utf8->string sub))) - ((= n 0) #f) ; EAGAIN/EIO/ENXIO — retry - ((= n -1) 'eof) ; true EOF (read returned 0) - (else 'error)))) ; fatal error — check pty-last-errno - - (def (pty-last-errno) - "Return the errno from the last pty_read call." - (ffi-pty-last-errno)) - - (def (pty-write master-fd str) - (ffi-pty-write master-fd str (string-length str))) - - (def (pty-close! master-fd child-pid) - (ffi-pty-close master-fd) - (when (and child-pid (> child-pid 0)) - (with-catch (lambda (e) (void)) - (lambda () - (ffi-pty-kill child-pid 15) - (ffi-pty-waitpid child-pid 1))))) - - (def (pty-kill! child-pid signal) - (when (and child-pid (> child-pid 0)) - (ffi-pty-kill child-pid signal))) - - (def (pty-resize! master-fd rows cols) - (when (and master-fd (>= master-fd 0)) - (ffi-pty-resize master-fd rows cols))) - - (def (pty-waitpid child-pid nohang?) - (let ((result (ffi-pty-waitpid child-pid (if nohang? 1 0)))) - (cond - ((> result 0) (values (ffi-pty-waitpid-status) #t)) - ((= result 0) (values 0 #f)) - (else (values -1 #t))))) - - (def (pty-child-alive? child-pid) - (let-values (((status exited?) (pty-waitpid child-pid #t))) - (not exited?))) - - ;;; ======================================================================== - ;;; Helpers - ;;; ======================================================================== - - (def (env-alist->string alist) - (if (or (not alist) (null? alist)) - "" - (let loop ((entries alist) (acc '())) - (if (null? entries) - (string-join (reverse acc) "\n") - (let ((e (car entries))) - (loop (cdr entries) - (cons (if (pair? e) - (string-append (car e) "=" (cdr e)) - e) - acc))))))) - - ) ;; end library deleted file mode 100644 --- a/lib/jerboa-litehtml/html.sls +++ /dev/null @@ -1,29 +0,0 @@ -;;; Stub library for jerboa-litehtml/html -;;; Provides no-op implementations when litehtml is not installed. -;;; EWW browser will report errors at runtime instead of crashing at load time. - -(library (jerboa-litehtml html) - (export html-context-create - html-container-create - html-container-set-callbacks! - html-container-set-viewport! - html-container-set-media-type! - html-container-set-media-color! - html-document-create - html-document-render! - html-document-draw! - html-document-destroy! - html-container-destroy!) - (import (chezscheme)) - - (define (html-context-create . args) #f) - (define (html-container-create . args) #f) - (define (html-container-set-callbacks! . args) (void)) - (define (html-container-set-viewport! . args) (void)) - (define (html-container-set-media-type! . args) (void)) - (define (html-container-set-media-color! . args) (void)) - (define (html-document-create . args) #f) - (define (html-document-render! . args) (void)) - (define (html-document-draw! . args) (void)) - (define (html-document-destroy! . args) (void)) - (define (html-container-destroy! . args) (void))) deleted file mode 100644 --- a/lib/jerboa/repl-socket.sls +++ /dev/null @@ -1,347 +0,0 @@ -#!chezscheme -;;; Non-blocking socket primitives for the debug REPL. -;;; -;;; Provides raw fd-level non-blocking I/O that never blocks a Chez thread -;;; in a foreign call. Used by the debug REPL's timer-based polling loop -;;; to avoid GC deadlocks (Chez stop-the-world GC cannot proceed when a -;;; thread is blocked in accept/read/poll foreign calls). - -(library (jerboa repl-socket) - (export - repl-socket-listen ;; (address port) → (values listen-fd actual-port) - repl-socket-accept ;; (listen-fd) → client-fd or #f - repl-socket-read ;; (fd) → string or #f (EAGAIN) or 'eof - repl-socket-write ;; (fd string) → #t or #f - repl-socket-close ;; (fd) → void - repl-socket-poll ;; (fd timeout-ms) → 'ready, #f (timeout), or 'error - repl-socket-nanosleep ;; (milliseconds) → void - repl-deactivate-thread! ;; () → void — deactivate for GC - repl-activate-thread! ;; () → void — reactivate after foreign call - ;; GC-safe subprocess/file I/O — deactivates thread during blocking calls - repl-capture-command ;; (cmd-string) → output-string - repl-read-file ;; (path) → content-string (empty on error) - repl-write-file) ;; (path content) → #t or #f - - (import (chezscheme)) - - ;; ========== FFI ========== - - ;; load-shared-object #f → dlopen(NULL) → gives access to all symbols - ;; in the main binary, whether dynamically or statically linked. - ;; Must always be called (even for static builds) so poll/nanosleep/etc. - ;; are found by foreign-procedure. - ;; Helper: find directory containing the running binary via /proc/self/exe - (define (_exe-dir) - (guard (e [#t #f]) - (let* ([c-readlink (foreign-procedure "readlink" - (string u8* size_t) ssize_t)] - [buf (make-bytevector 4096 0)] - [n (c-readlink "/proc/self/exe" buf 4096)]) - (if (<= n 0) #f - (let* ([sub (make-bytevector n)]) - (bytevector-copy! buf 0 sub 0 n) - (let* ([exe (utf8->string sub)] - [slash (let lp ([i (- (string-length exe) 1)]) - (cond [(< i 0) #f] - [(char=? (string-ref exe i) #\/) i] - [else (lp (- i 1))]))]) - (if slash (substring exe 0 (+ slash 1)) #f))))))) - - (define _libc-loaded - (let ((v (getenv "JEMACS_STATIC"))) - (if (and v (not (string=? v "")) (not (string=? v "0"))) - #f ; static build: symbols registered via Sforeign_symbol - (begin - (load-shared-object #f) - ;; Load repl_shim.so/.dylib for GC-safe subprocess/file I/O helpers. - ;; Try CWD paths, then next to the binary via /proc/self/exe. - (let* ([mt (symbol->string (machine-type))] - [ext (if (and (>= (string-length mt) 3) - (string=? (substring mt (- (string-length mt) 3) (string-length mt)) "osx")) - "dylib" "so")] - [exe-dir (_exe-dir)] - [paths (append - (list (string-append "repl_shim." ext) - (string-append "./repl_shim." ext) - (string-append "support/repl_shim." ext)) - (if exe-dir - (list (string-append exe-dir "repl_shim." ext)) - '()))]) - (let try ((ps paths)) - (if (null? ps) - (void) - (guard (e (#t (try (cdr ps)))) - (load-shared-object (car ps)))))))))) - - (define c-socket (foreign-procedure "socket" (int int int) int)) - (define c-bind (foreign-procedure "bind" (int void* int) int)) - (define c-listen (foreign-procedure "listen" (int int) int)) - (define c-accept (foreign-procedure "accept" (int void* void*) int)) - (define c-close (foreign-procedure "close" (int) int)) - (define c-setsockopt (foreign-procedure "setsockopt" (int int int void* int) int)) - (define c-read (foreign-procedure "read" (int u8* size_t) ssize_t)) - (define c-write (foreign-procedure "write" (int u8* size_t) ssize_t)) - (define c-htons (foreign-procedure "htons" (unsigned-short) unsigned-short)) - (define c-inet-pton (foreign-procedure "inet_pton" (int string void*) int)) - (define c-getsockname (foreign-procedure "getsockname" (int void* void*) int)) - (define c-fcntl (foreign-procedure "fcntl" (int int int) int)) - ;; ioctl() — used on macOS/BSD as a workaround for Chez's variadic-fcntl ABI - ;; bug on arm64 (the third arg of fcntl(F_SETFL,...) is read as garbage). - ;; ioctl(FIONBIO) is the BSD-blessed way to set non-blocking and works - ;; correctly through Chez's foreign-procedure layer. - (define c-ioctl (foreign-procedure "ioctl" (int unsigned-long void*) int)) - ;; poll/nanosleep/thread activation use wrapper names from repl_shim.c - ;; because musl static binaries don't export libc symbols to dlsym. - (define c-poll (foreign-procedure "repl_poll" (void* unsigned-int int) int)) - (define c-nanosleep (foreign-procedure "repl_nanosleep" (void* void*) int)) - - ;; Chez SMP thread activation — allows GC to proceed while this thread - ;; is blocked in foreign calls. Must bracket foreign blocking calls: - ;; (repl-deactivate-thread!) ; tell GC we're not using Scheme heap - ;; ... foreign blocking call (poll, nanosleep) ... - ;; (repl-activate-thread!) ; re-enter Scheme safely - (define c-deactivate (foreign-procedure "repl_deactivate_thread" () void)) - (define c-activate (foreign-procedure "repl_activate_thread" () int)) - - ;; errno — use __error on macOS/FreeBSD, __errno_location on Linux - (define c-errno-location - (let ((mt (symbol->string (machine-type)))) - (if (or (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb)) - (and (>= (string-length mt) 3) - (string=? (substring mt (- (string-length mt) 3) (string-length mt)) "osx"))) - (foreign-procedure "__error" () void*) - (foreign-procedure "__errno_location" () void*)))) - (define (get-errno) (foreign-ref 'int (c-errno-location) 0)) - (define EAGAIN (if (memq (machine-type) '(tarm64osx ta6osx a6osx arm64osx)) 35 11)) - (define EINTR 4) - - ;; Constants - (define AF_INET 2) - (define SOCK_STREAM 1) - (define SOL_SOCKET 1) - (define SO_REUSEADDR 2) - (define SOCKADDR_IN_SIZE 16) - (define F_GETFL 3) - (define F_SETFL 4) - ;; O_NONBLOCK differs by OS: Linux=0x800, macOS/BSD=0x0004 - (define O_NONBLOCK - (let ([mt (symbol->string (machine-type))]) - (let loop ([i 0]) - (cond - [(> (+ i 3) (string-length mt)) #x800] ;; default Linux - [(string=? (substring mt i (+ i 3)) "osx") #x0004] - [(string=? (substring mt i (+ i 3)) "bsd") #x0004] - [else (loop (+ i 1))])))) - (define POLLIN #x001) - (define POLLFD_SIZE 8) ;; struct pollfd: int fd, short events, short revents - - ;; FIONBIO ioctl: differs by OS (encodes direction/size/group/num). - ;; Linux: FIONBIO = 0x5421 - ;; macOS: FIONBIO = 0x8004667E (_IOW('f',126,int)) - ;; FreeBSD: FIONBIO = 0x8004667E (same encoding) - (define FIONBIO - (let ([mt (symbol->string (machine-type))]) - (let loop ([i 0]) - (cond - [(> (+ i 3) (string-length mt)) #x5421] ;; default Linux - [(string=? (substring mt i (+ i 3)) "osx") #x8004667E] - [(string=? (substring mt i (+ i 3)) "bsd") #x8004667E] - [else (loop (+ i 1))])))) - - ;; ========== Helpers ========== - - (define (set-nonblocking! fd) - ;; Use ioctl(FIONBIO) — works on both Linux and macOS without the - ;; variadic-fcntl ABI mismatch that breaks Chez on arm64 macOS. - (let ([one (foreign-alloc 4)]) - (foreign-set! 'int one 0 1) - (let ([rc (c-ioctl fd FIONBIO one)]) - (foreign-free one) - rc))) - - (define (make-sockaddr-in address port) - (let ([buf (foreign-alloc SOCKADDR_IN_SIZE)]) - (let lp ([i 0]) - (when (< i SOCKADDR_IN_SIZE) - (foreign-set! 'unsigned-8 buf i 0) - (lp (+ i 1)))) - (foreign-set! 'unsigned-short buf 0 AF_INET) - (foreign-set! 'unsigned-short buf 2 (c-htons port)) - (let ([addr-ptr (+ buf 4)]) - (when (= (c-inet-pton AF_INET address addr-ptr) 0) - (foreign-free buf) - (error 'make-sockaddr-in "invalid address" address))) - buf)) - - (define (sockaddr-in-port buf) - (let ([hi (foreign-ref 'unsigned-8 buf 2)] - [lo (foreign-ref 'unsigned-8 buf 3)]) - (+ (* hi 256) lo))) - - ;; ========== Public API ========== - - (define (repl-socket-listen address port) - ;; Create a non-blocking TCP listen socket. - ;; Returns (values listen-fd actual-port). - (let ([fd (c-socket AF_INET SOCK_STREAM 0)]) - (when (< fd 0) - (error 'repl-socket-listen "socket() failed")) - ;; SO_REUSEADDR - (let ([one (foreign-alloc 4)]) - (foreign-set! 'int one 0 1) - (c-setsockopt fd SOL_SOCKET SO_REUSEADDR one 4) - (foreign-free one)) - ;; Bind - (let ([addr (make-sockaddr-in address port)]) - (let ([rc (c-bind fd addr SOCKADDR_IN_SIZE)]) - (foreign-free addr) - (when (< rc 0) - (c-close fd) - (error 'repl-socket-listen "bind() failed" address port)))) - ;; Listen - (when (< (c-listen fd 4) 0) - (c-close fd) - (error 'repl-socket-listen "listen() failed")) - ;; Non-blocking - (set-nonblocking! fd) - ;; Get actual port - (let ([actual-port - (let ([buf (foreign-alloc SOCKADDR_IN_SIZE)] - [len (foreign-alloc 4)]) - (foreign-set! 'int len 0 SOCKADDR_IN_SIZE) - (c-getsockname fd buf len) - (let ([p (sockaddr-in-port buf)]) - (foreign-free buf) - (foreign-free len) - p))]) - (values fd actual-port)))) - - (define (repl-socket-accept listen-fd) - ;; Non-blocking accept. Returns client-fd or #f if no connection pending. - (let ([cfd (c-accept listen-fd 0 0)]) - (cond - [(>= cfd 0) - (set-nonblocking! cfd) - cfd] - [else #f]))) - - (define (repl-socket-read fd) - ;; Non-blocking read. Returns: - ;; string — data read - ;; #f — EAGAIN (no data available) - ;; 'eof — client disconnected or error - (let ([buf (make-bytevector 1024)]) - (let ([n (c-read fd buf 1024)]) - (cond - [(> n 0) - (utf8->string (repl-bytevector-slice buf 0 n))] - [(= n 0) 'eof] ;; TCP EOF - [else - (let ([e (get-errno)]) - (if (or (= e EAGAIN) (= e EINTR)) - #f ;; no data yet - 'eof))])))) ;; real error → treat as disconnect - - (define (repl-socket-write fd str) - ;; Write a string to fd. The fd is non-blocking; if the peer stops - ;; reading, fail instead of spinning in the UI/master-timer path. - ;; Returns #t on success, #f on error. - (let* ([bv (string->utf8 str)] - [len (bytevector-length bv)]) - (let lp ([written 0]) - (if (= written len) - #t - (let ([n (c-write fd - (if (= written 0) - bv - ;; Offset: copy remaining bytes - (let ([tmp (make-bytevector (- len written))]) - (bytevector-copy! bv written tmp 0 (- len written)) - tmp)) - (- len written))]) - (cond - [(> n 0) (lp (+ written n))] - [(and (< n 0) - (= (get-errno) EINTR)) - (lp written)] - [(and (< n 0) - (= (get-errno) EAGAIN)) - #f] - [else #f])))))) - - (define (repl-socket-close fd) - (c-close fd) - (void)) - - (define (repl-bytevector-slice bv start end) - (let* ([len (- end start)] - [result (make-bytevector len)]) - (bytevector-copy! bv start result 0 len) - result)) - - (define (repl-socket-poll fd timeout-ms) - ;; Use poll() to wait for data on fd with a timeout. - ;; Returns 'ready if data available, #f on timeout, 'error on error. - ;; This is a pure C call — it does NOT interact with Chez GC. - (let ([pfd (foreign-alloc POLLFD_SIZE)]) - (foreign-set! 'int pfd 0 fd) ;; .fd - (foreign-set! 'short pfd 4 POLLIN) ;; .events - (foreign-set! 'short pfd 6 0) ;; .revents - (let ([rc (c-poll pfd 1 timeout-ms)]) - (let ([result (cond - [(> rc 0) 'ready] - [(= rc 0) #f] ;; timeout - [else 'error])]) - (foreign-free pfd) - result)))) - - (define (repl-socket-nanosleep ms) - ;; Sleep for ms milliseconds using raw nanosleep(). - ;; This is a pure C call — does NOT use Chez sleep/condition-wait, - ;; so it doesn't participate in GC rendezvous. - (let ([ts (foreign-alloc 16)]) ;; struct timespec: long tv_sec, long tv_nsec - (foreign-set! 'long ts 0 (quotient ms 1000)) - (foreign-set! 'long ts 8 (* (remainder ms 1000) 1000000)) - (c-nanosleep ts 0) - (foreign-free ts))) - - (define (repl-deactivate-thread!) - ;; Deactivate this Chez thread for GC purposes. - ;; After this call, GC will NOT wait for this thread at rendezvous. - ;; The thread must NOT touch any Scheme heap objects until reactivated. - (c-deactivate)) - - (define (repl-activate-thread!) - ;; Reactivate this Chez thread. Must be called before accessing any - ;; Scheme objects. Will block if a GC is currently in progress (safe). - (c-activate)) - - ;; ========== GC-safe subprocess/file I/O ========== - ;; - ;; These functions deactivate the Chez thread during the blocking C call - ;; (popen+fread, fopen+fread, fopen+fwrite) and reactivate before returning. - ;; The Chez FFI converts the C string return to a Scheme string AFTER - ;; reactivation, so heap allocation is safe. - - (define c-capture-command - (foreign-procedure "repl_capture_command" (string) string)) - (define c-read-file - (foreign-procedure "repl_read_file" (string) string)) - (define c-write-file - (foreign-procedure "repl_write_file" (string string size_t) int)) - - (define (repl-capture-command cmd) - ;; Run a shell command in a GC-safe way. The thread is deactivated - ;; during the blocking popen/fread so GC can proceed. - ;; Returns the command's stdout as a string (empty string on error). - (c-capture-command cmd)) - - (define (repl-read-file path) - ;; Read a file in a GC-safe way. Returns content string (empty on error). - (c-read-file path)) - - (define (repl-write-file path content) - ;; Write content to a file in a GC-safe way. Returns #t/#f. - (= 0 (c-write-file path content (string-length content)))) - -) ;; end library deleted file mode 100644 --- a/lib/test/atom.sls +++ /dev/null @@ -1,6 +0,0 @@ -#!chezscheme -(library (test atom) - (export test-it) - (import (chezscheme) - (std misc atom)) - (define (test-it) (atom? (atom 42)))) --- a/scripts/jemacs-rc.sh +++ b/scripts/jemacs-rc.sh @@ -78,7 +78,7 @@ jemacs-start() { else # Interpreted mode: use offscreen platform (dynamically loaded) QT_QPA_PLATFORM=offscreen LD_PRELOAD=./jerboa_qt_shim.so \ - vendor/jerboa/.chez/bin/scheme --libdirs "lib:vendor/jerboa/lib:vendor/jerboa-shell/src:vendor/gherkin-runtime:vendor/jerboa-pcre2:vendor/jerboa-scintilla/src:vendor/jerboa-qt" \ + vendor/jerboa/.chez/bin/scheme --libdirs "lib:vendor/jerboa/lib:vendor/jerboa-shell/src:vendor/jerboa-shell/_jerbuild-stage:vendor/jerboa-pcre2/lib:vendor/jerboa-scintilla/lib:vendor/jerboa-qt" \ --script qt-main.ss --repl 0 & _JEMACS_PID=$! fi new file mode 100644 --- /dev/null +++ b/scripts/patch-jerboa-shell-compat.sh @@ -0,0 +1,75 @@ +#!/bin/sh +set -eu + +root="${1:-$(cd "$(dirname "$0")/.." && pwd)}" +jsh="$root/vendor/jerboa-shell" + +patch_util() { + file="$1" + if [ ! -f "$file" ] || grep -q "(def (validate-file-path" "$file"; then + return 0 + fi + + tmp="$file.tmp.$$" + awk ' + /;; Search PATH for a regular file/ && !done { + print ";; Validate a file path before passing it to C-level file operations." + print "(def (validate-file-path path who)" + print " (let loop ((i 0))" + print " (when (< i (string-length path))" + print " (when (char=? (string-ref path i) #\\nul)" + print " (error who (string-append path \": path contains null byte\")))" + print " (loop (+ i 1))))" + print " path)" + print "" + done=1 + } + { print } + ' "$file" > "$tmp" + mv "$tmp" "$file" +} + +patch_redirect() { + file="$1" + if [ ! -f "$file" ] || grep -q "validate-file-path filename" "$file"; then + return 0 + fi + + tmp="$file.tmp.$$" + awk ' + { + print + if ($0 == "(def (redirect-fd-to-file! fd filename flags mode)") { + getline + if ($0 == " (let ((raw-fd (ffi-open-raw filename flags mode)))") { + print " (validate-file-path filename (quote redirect))" + } + print + } + } + ' "$file" > "$tmp" + mv "$tmp" "$file" +} + +patch_main() { + file="$1" + if [ ! -f "$file" ] || grep -q "validate-file-path (car args)" "$file"; then + return 0 + fi + + tmp="$file.tmp.$$" + sed 's/\[filename (car args)\]/[filename (validate-file-path (car args) (quote source))]/' "$file" > "$tmp" + mv "$tmp" "$file" +} + +patch_util "$jsh/util.ss" +patch_util "$jsh/jerboa-shell/util.ss" +patch_util "$jsh/jsh-src/jsh/util.ss" + +patch_redirect "$jsh/redirect.ss" +patch_redirect "$jsh/jerboa-shell/redirect.ss" +patch_redirect "$jsh/jsh-src/jsh/redirect.ss"