fix(gsub): handle empty matches with awk/gawk advance semantics
ober
19b07ad10cc158b995b5501be5a267ed8c35144e
--- a/Makefile +++ b/Makefile @@ -20,7 +20,7 @@ SBOM_DIR ?= dist/sbom REPRO_DIR ?= dist/reproducibility TARGET_EVIDENCE_DIR ?= dist/target-evidence -.PHONY: all build binary test test-parser test-limits parser-corpus test-cli-policy import-check clean-generated security audit verify sbom reproducibility-report target-evidence release-evidence clean install lint +.PHONY: all build binary test test-parser test-limits test-gsub parser-corpus test-cli-policy import-check clean-generated security audit verify sbom reproducibility-report target-evidence release-evidence clean install lint all: binary @@ -45,6 +45,9 @@ test-parser: test-limits: @$(JEXEC) tests/test-limits.ss +test-gsub: + @$(JEXEC) tests/test-gsub.ss + parser-corpus: @$(JEXEC) support/parser-corpus-evidence.ss @@ -60,7 +63,7 @@ test-cli-policy: binary @echo "--- ENVIRON hidden by default ---"; ./$(JAWK_BIN) 'BEGIN{print ("PATH" in ENVIRON)}' | grep -qx 0 @echo "--- ENVIRON allowlist opt-in ---"; JAWK_EXPOSE_ENVIRON=1 ./$(JAWK_BIN) 'BEGIN{print ("PATH" in ENVIRON)}' | grep -qx 1 -test: test-parser test-limits binary +test: test-parser test-limits test-gsub binary @echo "--- print field ---"; echo "hello world" | ./$(JAWK_BIN) '{print $$1}' @echo "--- -F, ---"; echo "a,b,c" | ./$(JAWK_BIN) -F, '{print $$2}' @echo "--- BEGIN/END ---"; echo "" | ./$(JAWK_BIN) 'BEGIN{print "start"} END{print "end"}' --- a/lib/jerboa-awk/builtins/string.sls +++ b/lib/jerboa-awk/builtins/string.sls @@ -119,21 +119,46 @@ ;; Compile the regex once and stream the gap/replacement pieces into an ;; output port (O(n) assembly) instead of re-consing a piece list and ;; apply-string-appending it at the end. - (let loop ((pos 0)) - (let ((m (pregexp-match-positions re target-str pos))) - (if (not m) - (begin - (put-string out (substring target-str pos tlen)) - (set-target! (make-awk-string (get-output-string out))) - (make-awk-number count)) - (let* ((mpos (car m)) ;; full match (start . end) - (start (car mpos)) - (end (cdr mpos)) - (replacement (build-replacement repl-str mpos target-str))) - (set! count (+ count 1)) - (put-string out (substring target-str pos start)) - (put-string out replacement) - (loop (if (= start end) (+ end 1) end)))))))) + ;; + ;; Empty matches follow awk/gawk semantics so a pattern like /x*/ or /a*/ + ;; cannot loop forever: after a zero-length match the replacement is + ;; emitted and the next character is consumed literally, advancing the + ;; scan by one. A zero-length match sitting immediately after a non-empty + ;; match is suppressed (that character is passed through literally), which + ;; is what makes gsub(/a*/,"b","banana") yield "bbbnbnb" rather than + ;; inserting a separator after every 'a'. + (let loop ((pos 0) (prev-nonempty? #f)) + (cond + ((> pos tlen) + (set-target! (make-awk-string (get-output-string out))) + (make-awk-number count)) + (else + (let ((m (pregexp-match-positions re target-str pos))) + (if (not m) + (begin + (put-string out (substring target-str pos tlen)) + (set-target! (make-awk-string (get-output-string out))) + (make-awk-number count)) + (let* ((mpos (car m)) ;; full match (start . end) + (start (car mpos)) + (end (cdr mpos))) + (cond + ((and prev-nonempty? (= start end)) + (put-string out (substring target-str pos start)) + (when (< start tlen) + (put-string out (substring target-str start (+ start 1)))) + (loop (+ start 1) #f)) + (else + (let ((replacement (build-replacement repl-str mpos target-str))) + (set! count (+ count 1)) + (put-string out (substring target-str pos start)) + (put-string out replacement) + (if (= start end) + (begin + (when (< end tlen) + (put-string out (substring target-str end (+ end 1)))) + (loop (+ end 1) #f)) + (loop end #t))))))))))))) (define (build-replacement repl-str match-pair target-str) "Process replacement string: & = matched text, \\ = literal backslash" new file mode 100644 --- /dev/null +++ b/tests/test-gsub.ss @@ -0,0 +1,90 @@ +#!chezscheme + +(import (scheme) + (jerboa-awk parser) + (jerboa-awk ast) + (jerboa-awk main) + (jerboa-awk value) + (jerboa-awk runtime) + (jerboa-awk builtins string)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + ((_ name expr expected) + (guard (exn (else + (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn)))) + (let ((got expr)) + (if (equal? got expected) + (begin + (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin + (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))))) + +(define (run-on program input) + (let ((input-port (open-input-string input)) + (output-port (open-output-string))) + (dynamic-wind + (lambda () (void)) + (lambda () + (parameterize ((current-input-port input-port) + (current-output-port output-port)) + (run-awk (list program))) + (get-output-string output-port)) + (lambda () + (close-port input-port) + (close-port output-port))))) + +(printf "--- jawk gsub empty-match tests ---~%") + +(test "gsub(/x*/,\"-\",\"abc\") matches gawk" + (run-on "{gsub(/x*/,\"-\"); print}" "abc\n") + "-a-b-c-\n") + +(test "gsub(/a*/,\"b\",\"banana\") matches gawk" + (run-on "{gsub(/a*/,\"b\"); print}" "banana\n") + "bbbnbnb\n") + +(test "gsub(/a*/,\"b\") count on banana" + (run-on "{n=gsub(/a*/,\"b\"); print n, $0}" "banana\n") + "4 bbbnbnb\n") + +(test "gsub(/b*/,\"-\",\"abc\") matches gawk" + (run-on "{gsub(/b*/,\"-\"); print}" "abc\n") + "-a-c-\n") + +(test "gsub(/a?/,\"-\",\"ba\") matches gawk" + (run-on "{gsub(/a?/,\"-\"); print}" "ba\n") + "-b-\n") + +(test "gsub(/x*/,\"-\") on empty record matches gawk" + (run-on "{gsub(/x*/,\"-\"); print}" "\n") + "-\n") + +(test "gsub(/x*/,\"\") empty replacement matches gawk" + (run-on "{gsub(/x*/,\"\"); print}" "abc\n") + "abc\n") + +(test "gsub non-empty pattern still works" + (run-on "{gsub(/foo/,\"FOO\"); print}" "foo bar foo\n") + "FOO bar FOO\n") + +(test "gsub non-empty single char still works" + (run-on "{gsub(/b/,\"X\"); print}" "abc\n") + "aXc\n") + +;; Note: gsub(/^/,...) is not asserted against gawk here. pregexp re-anchors ^ +;; to the moving search offset (a pre-existing characteristic, present before +;; this fix), so ^ matches at every position; gawk anchors ^ to string start. +(test "gsub anchored $ empty match matches gawk" + (run-on "{gsub(/$/,\"-\"); print}" "abc\n") + "abc-\n") + +(printf "~%~a passed, ~a failed~%" pass fail) +(unless (= fail 0) (exit 1))