Fix top command: direct coreutils import, static build support
ober
7de0fe110d49df1e38f6f0257ee5a973b1d24f92
--- a/Makefile +++ b/Makefile @@ -225,6 +225,7 @@ PCRE2_SRC ?= $(HOME)/mine/chez-pcre2 SCI_SRC ?= $(HOME)/mine/chez-scintilla QT_SRC ?= $(HOME)/mine/chez-qt QTSHIM_SRC ?= $(HOME)/mine/gerbil-qt +COREUTILS_SRC ?= $(HOME)/mine/jerboa-coreutils DEPS_IMAGE := jemacs-deps:$(ARCH) @@ -318,9 +319,10 @@ build-jemacs-qt-static: check-root CHEZ_SCINTILLA_DIR=/deps/chez-scintilla/src \ CHEZ_QT_DIR=/deps/chez-qt \ CHEZ_QT_SHIM_DIR=/deps/gerbil-qt/vendor \ + COREUTILS_DIR=/deps/coreutils \ PKG_CONFIG_PATH=/opt/qt6-static/lib/pkgconfig \ /opt/chez/bin/scheme \ - --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/deps/gherkin/src:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt \ + --libdirs lib:/deps/jerboa/lib:/deps/jsh/src:/deps/coreutils:/deps/gherkin/src:/deps/chez-pcre2:/deps/chez-scintilla/src:/deps/chez-qt \ --script build-binary-qt.ss linux-static-qt-docker: @@ -330,14 +332,18 @@ linux-static-qt-docker: --ulimit nofile=8192:8192 \ -v $(CURDIR):/src:z \ -v $(JERBOA)/lib/std:/host-jerboa-std:ro \ + -v $(COREUTILS_SRC)/lib:/host-coreutils:ro \ $(DEPS_IMAGE) \ sh -c "apk add --no-cache libvterm-dev libvterm-static >/dev/null 2>&1; \ + cp -a /host-coreutils/. /deps/coreutils/; \ + find /deps/coreutils -name '*.sls' -exec sed -i 's/(load-shared-object #f)/(void)/g' {} +; \ for f in \ misc/atom.sls misc/channel.sls misc/completion.sls misc/list.sls \ misc/memo.sls misc/number.sls misc/ports.sls misc/process.sls \ - misc/rwlock.sls misc/shuffle.sls misc/string.sls \ + misc/rwlock.sls misc/shuffle.sls misc/string.sls misc/terminal.sls \ + cli/getopt.sls \ net/request.sls net/uri.sls \ - os/fdio.sls os/signal.sls \ + os/fdio.sls os/signal.sls os/tty.sls \ text/base64.sls text/diff.sls text/glob.sls text/hex.sls text/json.sls \ crypto/digest.sls \ format.sls iter.sls pregexp.sls sort.sls sugar.sls \ --- a/build-binary-qt.ss +++ b/build-binary-qt.ss @@ -83,6 +83,10 @@ (or (getenv "CHEZ_QT_SHIM_DIR") (format "~a/mine/gerbil-qt/vendor" home))) +(define coreutils-dir + (or (getenv "COREUTILS_DIR") + "/deps/coreutils")) + ;; Static build detection (needed before dep checks) (define jemacs-static? (let ((v (getenv "JEMACS_STATIC"))) @@ -372,7 +376,7 @@ ;; define-foreign name "c-name" — jsh macro (C name is the second string) (gen-cmd (format - "{ { cat ~a ~a; find ~a ~a ~a lib/jerboa-emacs lib/jerboa vendor -name '*.sls' -o -name '*.ss' | xargs cat 2>/dev/null; } | \ + "{ { cat ~a ~a; find ~a ~a ~a lib/jerboa-emacs lib/jerboa vendor -name '*.sls' -o -name '*.ss' | xargs cat 2>/dev/null; cat ~a/jerboa-coreutils/top.sls 2>/dev/null; } | \ sed 's/;;.*//' | grep -oE '(foreign-procedure|foreign-entry\\?) \"[^\"]*\"' | sed 's/.* \"//;s/\"//'; \ { cat ~a ~a; } | sed 's/;;.*//' | grep -o 'define-optional-ffi [^ ]* \"[^\"]*\"' | sed 's/.*define-optional-ffi [^ ]* \"//;s/\"//'; \ find ~a -name '*.sls' -o -name '*.ss' | \ @@ -391,7 +395,7 @@ echo \"}\" >> qt_static_symbols.c && \ rm /tmp/ffi_syms.txt && \ echo OK" ffi-path pcre2-ffi-path - jsh-dir jerboa-dir sci-dir + jsh-dir jerboa-dir sci-dir coreutils-dir ffi-path pcre2-ffi-path jsh-dir)) (result (shell-output gen-cmd ""))) --- a/lib/jerboa-emacs/qt/commands-shell.sls +++ b/lib/jerboa-emacs/qt/commands-shell.sls @@ -68,9 +68,8 @@ *abbrevs-path* abbrevs-save! abbrevs-load! cmd-abbrev-mode cmd-define-abbrev cmd-delete-horizontal-space cmd-consult-line cmd-consult-grep cmd-consult-buffer - cmd-consult-outline *top-buffer-name* *coreutils-registered* - *top-active* ensure-coreutils! top-capture-output - top-refresh! cmd-top cmd-top-quit) + cmd-consult-outline *top-buffer-name* *top-active* + top-capture-output top-refresh! cmd-top cmd-top-quit) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -83,6 +82,7 @@ schedule-periodic! cancel-periodic!) (only (jsh registry) builtin-lookup) + (rename (jerboa-coreutils top) (main cu-top-main)) (only (jerboa-emacs persist) theme-settings-save! theme-settings-load! mx-history-save! mx-history-load! *auto-fill-mode* *fill-column* *abbrev-table* @@ -2153,32 +2153,23 @@ (qt-plain-text-edit-ensure-cursor-visible! ed)))))))))) (define *top-buffer-name*--cell (vector "*top*")) - (define *coreutils-registered*--cell (vector #f)) (define *top-active*--cell (vector #f)) - (def (ensure-coreutils!) - "Lazily register coreutils builtins on first use.\n Uses eval to avoid a compile-time dependency on (jsh coreutils)\n which requires jerboa-coreutils (not available in Docker builds)." - (unless *coreutils-registered* - (with-catch - (lambda (e) #f) - (lambda () - (eval - '(begin - (import (only (jsh coreutils) register-coreutils!)) - (register-coreutils!))) - (set! *coreutils-registered* #t))))) (def (top-capture-output) - "Run coreutils top in batch mode (-b -n 1) and capture output as a string.\n Uses builtin-lookup to get the jsh-registered handler." - (ensure-coreutils!) - (let ([handler (builtin-lookup "top")]) - (if handler - (let ([output (with-output-to-string - (lambda () - (with-catch - (lambda (e) (display "top: error\n")) - (lambda () - (handler '("-b" "-n" "1") #f)))))]) - output) - "top: command not available (coreutils not installed)\n"))) + "Run coreutils top in batch mode (-b -n 1) and capture output as a string.\n Calls cu-top-main directly (imported from jerboa-coreutils/top)." + (with-output-to-string + (lambda () + (with-catch + (lambda (e) + (display "top: error: ") + (display + (with-output-to-string (lambda () (display-condition e)))) + (newline)) + (lambda () + (call/cc + (lambda (k) + (parameterize ([exit-handler + (lambda (code) (k (void)))]) + (cu-top-main "-b" "-n" "1"))))))))) (def (top-refresh! app) "Refresh the *top* buffer with current coreutils top output." (let* ([ed (current-qt-editor app)] @@ -2364,13 +2355,6 @@ *top-buffer-name*--cell 0 val)])) - (define-syntax *coreutils-registered* - (identifier-syntax - [id (vector-ref *coreutils-registered*--cell 0)] - [(set! id val) (vector-set! - *coreutils-registered*--cell - 0 - val)])) (define-syntax *top-active* (identifier-syntax [id (vector-ref *top-active*--cell 0)] --- a/src/jerboa-emacs/qt/commands-shell.ss +++ b/src/jerboa-emacs/qt/commands-shell.ss @@ -13,6 +13,7 @@ :jerboa-emacs/core (only-in :jerboa-emacs/async schedule-periodic! cancel-periodic!) (only-in :jsh/registry builtin-lookup) + (rename-in :jerboa-coreutils/top (main cu-top-main)) (only-in :jerboa-emacs/persist theme-settings-save! theme-settings-load! mx-history-save! mx-history-load! *auto-fill-mode* *fill-column* @@ -1849,35 +1850,23 @@ SPC = page down, DEL = page up, q = quit view-mode." ;;;============================================================================ (def *top-buffer-name* "*top*") -(def *coreutils-registered* #f) (def *top-active* #f) ;; the app when top is running, or #f -(def (ensure-coreutils!) - "Lazily register coreutils builtins on first use. - Uses eval to avoid a compile-time dependency on (jsh coreutils) - which requires jerboa-coreutils (not available in Docker builds)." - (unless *coreutils-registered* - (with-catch - (lambda (e) #f) ;; silently fail if coreutils not available - (lambda () - (eval '(begin - (import (only (jsh coreutils) register-coreutils!)) - (register-coreutils!))) - (set! *coreutils-registered* #t))))) - (def (top-capture-output) "Run coreutils top in batch mode (-b -n 1) and capture output as a string. - Uses builtin-lookup to get the jsh-registered handler." - (ensure-coreutils!) - (let ((handler (builtin-lookup "top"))) - (if handler - (let ((output (with-output-to-string - (lambda () - (with-catch - (lambda (e) (display "top: error\n")) - (lambda () (handler '("-b" "-n" "1") #f))))))) - output) - "top: command not available (coreutils not installed)\n"))) + Calls cu-top-main directly (imported from jerboa-coreutils/top)." + (with-output-to-string + (lambda () + (with-catch + (lambda (e) + (display "top: error: ") + (display (with-output-to-string (lambda () (display-condition e)))) + (newline)) + (lambda () + (call/cc + (lambda (k) + (parameterize ((exit-handler (lambda (code) (k (void))))) + (cu-top-main "-b" "-n" "1"))))))))) (def (top-refresh! app) "Refresh the *top* buffer with current coreutils top output." --- a/tests/test-functional.ss +++ b/tests/test-functional.ss @@ -29,7 +29,8 @@ *mx-history* mx-history-add! mx-history-ordered-candidates) (only (jerboa-emacs helm-commands) register-helm-commands!) (jerboa-emacs helm) - (only (std srfi srfi-13) string-contains string-prefix?)) + (only (std srfi srfi-13) string-contains string-prefix?) + (rename (jerboa-coreutils top) (main cu-top-main))) (define pass-count 0) (define fail-count 0) @@ -1578,6 +1579,112 @@ (check (repeat-mode?) => #f) (repeat-mode-set! #f)) +;;;============================================================================ +;;; Key Chord Tests +;;;============================================================================ + +(display "\n--- key-chord: case-insensitive registration ---\n") +;; Clear chord state +(set! *chord-map* (make-hash-table)) +(set! *chord-first-chars* (make-hash-table)) + +;; Define a chord with uppercase letters +(key-chord-define-global "EE" 'eshell) + +;; Test: all case combinations should resolve to the same command +(check (chord-lookup #\E #\E) => 'eshell) +(check (chord-lookup #\e #\e) => 'eshell) +(check (chord-lookup #\E #\e) => 'eshell) +(check (chord-lookup #\e #\E) => 'eshell) + +(display "--- key-chord: both orderings registered ---\n") +(set! *chord-map* (make-hash-table)) +(set! *chord-first-chars* (make-hash-table)) +(key-chord-define-global "MT" 'vterm) + +;; Both orderings: M→T and T→M +(check (chord-lookup #\m #\t) => 'vterm) +(check (chord-lookup #\t #\m) => 'vterm) +(check (chord-lookup #\M #\T) => 'vterm) +(check (chord-lookup #\T #\M) => 'vterm) + +(display "--- key-chord: start-char detects both chars ---\n") +(check (chord-start-char? #\m) => #t) +(check (chord-start-char? #\t) => #t) +(check (chord-start-char? #\M) => #t) +(check (chord-start-char? #\T) => #t) +(check (chord-start-char? #\z) => #f) + +(display "--- key-chord: same-char chord ---\n") +(set! *chord-map* (make-hash-table)) +(set! *chord-first-chars* (make-hash-table)) +(key-chord-define-global "GG" 'keyboard-quit) +(check (chord-lookup #\g #\g) => 'keyboard-quit) +(check (chord-lookup #\G #\G) => 'keyboard-quit) + +(display "--- key-chord: non-alpha chars ---\n") +(set! *chord-map* (make-hash-table)) +(set! *chord-first-chars* (make-hash-table)) +(key-chord-define-global ";;" 'comment) +(check (chord-lookup #\; #\;) => 'comment) +(check (chord-start-char? #\;) => #t) + +(display "--- key-chord: multiple chords don't interfere ---\n") +(set! *chord-map* (make-hash-table)) +(set! *chord-first-chars* (make-hash-table)) +(key-chord-define-global "EE" 'eshell) +(key-chord-define-global "MT" 'vterm) +(key-chord-define-global "GG" 'keyboard-quit) +(check (chord-lookup #\e #\e) => 'eshell) +(check (chord-lookup #\m #\t) => 'vterm) +(check (chord-lookup #\g #\g) => 'keyboard-quit) +;; Non-chord pairs should return #f +(check (chord-lookup #\e #\m) => #f) +(check (chord-lookup #\g #\t) => #f) + +;;;============================================================================ +;;; Coreutils Top Tests +;;;============================================================================ + +(display "\n--- coreutils-top: cu-top-main is a procedure ---\n") +(check (procedure? cu-top-main) => #t) + +(display "--- coreutils-top: batch mode produces output ---\n") +(let ((output (with-output-to-string + (lambda () + (call/cc + (lambda (k) + (parameterize ([exit-handler (lambda (code) (k (void)))]) + (cu-top-main "-b" "-n" "1")))))))) + ;; Output should be non-empty + (check (> (string-length output) 100) => #t) + ;; Should contain standard top header fields (string-contains returns index, not #t) + (check (and (string-contains output "load average") #t) => #t) + (check (and (string-contains output "Tasks:") #t) => #t) + (check (and (string-contains output "Cpu") #t) => #t) + (check (and (string-contains output "Mem") #t) => #t) + ;; Should contain PID column header + (check (and (string-contains output "PID") #t) => #t)) + +(display "--- coreutils-top: output is multi-line ---\n") +(let* ((output (with-output-to-string + (lambda () + (call/cc + (lambda (k) + (parameterize ([exit-handler (lambda (code) (k (void)))]) + (cu-top-main "-b" "-n" "1"))))))) + (lines (let loop ((s output) (acc '())) + (let ((nl (let find ((i 0)) + (if (>= i (string-length s)) #f + (if (char=? (string-ref s i) #\newline) i + (find (+ i 1))))))) + (if nl + (loop (substring s (+ nl 1) (string-length s)) + (cons (substring s 0 nl) acc)) + (reverse (cons s acc))))))) + ;; Should have many lines (header + processes) + (check (> (length lines) 10) => #t)) + ;; Summary (newline) (display "========================================\n")