Fix with-catch arity warning, --help exit code, and getopt combined flags
ober
466fccf7e2e6f6e5f0dac2e84b7e30329ad37736
--- a/lib/std/cli/getopt.sls +++ b/lib/std/cli/getopt.sls @@ -168,6 +168,26 @@ (lp (cddr args) (cons (cons (opt-name o) (cadr args)) result) positionals pos-idx)))))) + ;; Combined short options: -la -> -l -a, -n3 -> -n with value "3" + ((and (> (string-length arg) 2) + (char=? (string-ref arg 0) #\-) + (not (char=? (string-ref arg 1) #\-))) + (let* ((short-key (substring arg 0 2)) + (rest-str (substring arg 2 (string-length arg))) + (matched (find-opt opts short-key))) + (if matched + (case (opt-kind matched) + ((option) + (lp (cdr args) + (cons (cons (opt-name matched) rest-str) result) + positionals pos-idx)) + ((flag) + (lp (cons (string-append "-" rest-str) (cdr args)) + (cons (cons (opt-name matched) #t) result) + positionals pos-idx)) + (else + (error 'getopt-parse (string-append "unknown option: " arg)))) + (error 'getopt-parse (string-append "unknown option: " arg))))) (else (error 'getopt-parse (string-append "unknown option: " arg)))))) ;; Check for command @@ -248,6 +268,11 @@ ;; Gerbil convention: (proc cmd opt-hash) ;; cmd = command name symbol, opt-hash = hash table of options (let ((gopt (apply getopt specs))) + ;; Handle --help before parsing (exit 0) + ;; Only intercept --help, not -h (which many utilities use for their own options) + (when (member "--help" args) + (getopt-display-help gopt (current-output-port)) + (exit 0)) (guard (exn (#t (fprintf (current-error-port) "Error: ~a~n" exn) (getopt-display-help gopt (current-error-port)) (exit 1))) --- a/lib/std/crypto/digest.sls +++ b/lib/std/crypto/digest.sls @@ -3,7 +3,7 @@ (library (std crypto digest) (export - md5 sha1 sha256 sha384 sha512 + md5 sha1 sha224 sha256 sha384 sha512 digest->hex-string digest->u8vector) (import (chezscheme)) @@ -14,6 +14,7 @@ (algo-name (case algo ((md5) "md5") ((sha1) "sha1") + ((sha224) "sha224") ((sha256) "sha256") ((sha384) "sha384") ((sha512) "sha512") @@ -77,6 +78,7 @@ ;; Public API: returns hex string (define (md5 data) (compute-digest 'md5 data)) (define (sha1 data) (compute-digest 'sha1 data)) + (define (sha224 data) (compute-digest 'sha224 data)) (define (sha256 data) (compute-digest 'sha256 data)) (define (sha384 data) (compute-digest 'sha384 data)) (define (sha512 data) (compute-digest 'sha512 data)) --- a/lib/std/misc/string.sls +++ b/lib/std/misc/string.sls @@ -14,7 +14,7 @@ (export string-split string-join string-trim string-prefix? string-suffix? string-contains string-index - string-empty?) + string-empty? string-trim-eol) (import (chezscheme)) (define string-split @@ -108,4 +108,19 @@ (define (string-empty? str) (zero? (string-length str))) + (define (string-trim-eol str) + ;; Trim trailing CR, LF, or CRLF from string. + ;; Tries CRLF first (longer suffix), then LF, then CR. + (let* ([len (string-length str)] + [try-suffix + (lambda (suffix) + (let ([slen (string-length suffix)]) + (and (<= slen len) + (string=? suffix (substring str (- len slen) len)) + (substring str 0 (- len slen)))))]) + (or (try-suffix "\r\n") + (try-suffix "\n") + (try-suffix "\r") + str))) + ) ;; end library --- a/lib/std/net/tcp.sls +++ b/lib/std/net/tcp.sls @@ -22,7 +22,11 @@ ;; ========== FFI ========== ;; Load libc for POSIX socket functions - (define load-libc (load-shared-object #f)) + (define _libc-loaded + (let ((v (getenv "JEMACS_STATIC"))) + (if (and v (not (string=? v "")) (not (string=? v "0"))) + #f ; symbols already in static binary + (load-shared-object #f)))) (define c-socket (foreign-procedure "socket" (int int int) int)) (define c-bind (foreign-procedure "bind" (int void* int) int)) --- a/lib/std/os/temporaries.sls +++ b/lib/std/os/temporaries.sls @@ -6,7 +6,11 @@ (import (chezscheme)) - (define libc (load-shared-object "libc.so.6")) + (define _libc-loaded + (let ((v (getenv "JEMACS_STATIC"))) + (if (and v (not (string=? v "")) (not (string=? v "0"))) + #f ; symbols already in static binary + (load-shared-object "libc.so.6")))) (define getpid (foreign-procedure "getpid" () int)) (define *temp-counter* 0) --- a/lib/std/sugar.sls +++ b/lib/std/sugar.sls @@ -121,9 +121,15 @@ ;; (with-catch handler thunk) ;; handler: (lambda (exn) fallback-value) ;; thunk: (lambda () guarded-expression) + ;; with-catch — Gerbil exception handler shorthand. + ;; %apply1 indirection prevents Chez arity-check warnings on (handler e). + (define (%apply1 f x) (apply f (list x))) (define (with-catch handler thunk) - (guard (e [#t (handler e)]) - (thunk))) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) (k (%apply1 handler e))) + thunk)))) ;; cut / cute — SRFI-26 partial application ;; (cut f <> y) → (lambda (x) (f x y))