missing file
ober
61d75743c68b1ce9786211929d6b72305c5c12b0
new file mode 100644 --- /dev/null +++ b/lib/sed/main.sls @@ -0,0 +1,380 @@ +#!chezscheme +;;; (sed main) — Library wrapper for sed entry point +;;; +;;; Provides main and run-sed as library exports so sed can be +;;; loaded as a builtin command in jsh without being a standalone script. + +(library (sed main) + (export main run-sed) + (import (except (chezscheme) compile-program) (sed ast) (sed parser) (sed engine)) + + (define (main . args) + (guard (e [else + (display "sed: " (current-error-port)) + (display-condition e (current-error-port)) + (newline (current-error-port)) + (exit 1)]) + (run-sed args))) + + (define (run-sed args) + (let-values ([(scripts files suppress? extended? in-place-suffix + sandbox? null-data? separate?) + (parse-args args)]) + (when (null? scripts) + (display "sed: no script\nTry 'sed --help' for more information.\n" + (current-error-port)) + (exit 1)) + (let* ([full-script (string-join-sep scripts "\n")] + [parsed-cmds (parse-sed-script full-script extended?)] + [prog (compile-program parsed-cmds)] + [state (make-initial-sed-state suppress? extended? + sandbox? null-data? separate?)]) + (if in-place-suffix + (process-in-place state prog files in-place-suffix) + (process-files state prog files (current-output-port)))))) + + ;;; Argument parsing + + (define (parse-args args) + (let loop ([args args] + [scripts '()] + [files '()] + [suppress? #f] + [extended? #f] + [in-place #f] + [sandbox? #f] + [null-data? #f] + [separate? #f]) + (if (null? args) + (values (reverse scripts) (reverse files) + suppress? extended? in-place sandbox? null-data? separate?) + (let ([arg (car args)] [rest (cdr args)]) + (cond + [(string=? arg "--") + (loop '() scripts (append (reverse rest) files) + suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--quiet") + (loop rest scripts files #t extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--silent") + (loop rest scripts files #t extended? in-place sandbox? null-data? separate?)] + [(or (string=? arg "--regexp-extended") (string=? arg "-E") (string=? arg "-r")) + (loop rest scripts files suppress? #t in-place sandbox? null-data? separate?)] + [(string=? arg "--sandbox") + (loop rest scripts files suppress? extended? in-place #t null-data? separate?)] + [(or (string=? arg "--null-data") (string=? arg "-z")) + (loop rest scripts files suppress? extended? in-place sandbox? #t separate?)] + [(or (string=? arg "--separate") (string=? arg "-s")) + (loop rest scripts files suppress? extended? in-place sandbox? null-data? #t)] + [(or (string=? arg "--posix") (string=? arg "--follow-symlinks")) + (loop rest scripts files suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--in-place") + (loop rest scripts files suppress? extended? "" sandbox? null-data? separate?)] + [(string-prefix? "--in-place=" arg) + (loop rest scripts files suppress? extended? + (substring arg 11 (string-length arg)) + sandbox? null-data? separate?)] + [(string-prefix? "--expression=" arg) + (loop rest (cons (substring arg 13 (string-length arg)) scripts) + files suppress? extended? in-place sandbox? null-data? separate?)] + [(string-prefix? "--file=" arg) + (loop rest (cons (read-script-file (substring arg 7 (string-length arg))) scripts) + files suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--help") + (display-help) + (exit 0)] + [(string=? arg "--version") + (display "sed (jerboa-sed) 0.1.0\n") + (exit 0)] + [(and (fx> (string-length arg) 1) (char=? (string-ref arg 0) #\-)) + (parse-short rest scripts files suppress? extended? in-place + sandbox? null-data? separate? + (substring arg 1 (string-length arg)))] + [(null? scripts) + (loop rest (list arg) files suppress? extended? in-place sandbox? null-data? separate?)] + [else + (loop rest scripts (cons arg files) + suppress? extended? in-place sandbox? null-data? separate?)]))))) + + (define (parse-short rest scripts files suppress? extended? in-place + sandbox? null-data? separate? opts) + (if (string=? opts "") + (re-parse rest scripts files suppress? extended? in-place sandbox? null-data? separate? "") + (let ([c (string-ref opts 0)] + [tail (substring opts 1 (string-length opts))]) + (case c + [(#\n) + (re-parse rest scripts files #t extended? in-place sandbox? null-data? separate? tail)] + [(#\E #\r) + (re-parse rest scripts files suppress? #t in-place sandbox? null-data? separate? tail)] + [(#\s) + (re-parse rest scripts files suppress? extended? in-place sandbox? null-data? #t tail)] + [(#\z) + (re-parse rest scripts files suppress? extended? in-place sandbox? #t separate? tail)] + [(#\e) + (if (string=? tail "") + (if (null? rest) + (begin + (display "sed: option requires an argument -- 'e'\n" (current-error-port)) + (exit 1)) + (re-parse (cdr rest) (cons (car rest) scripts) files suppress? extended? in-place + sandbox? null-data? separate? "")) + (re-parse rest (cons tail scripts) files suppress? extended? in-place + sandbox? null-data? separate? ""))] + [(#\f) + (if (string=? tail "") + (if (null? rest) + (begin + (display "sed: option requires an argument -- 'f'\n" (current-error-port)) + (exit 1)) + (re-parse (cdr rest) (cons (read-script-file (car rest)) scripts) files + suppress? extended? in-place sandbox? null-data? separate? "")) + (re-parse rest (cons (read-script-file tail) scripts) files + suppress? extended? in-place sandbox? null-data? separate? ""))] + [(#\i) + (re-parse rest scripts files suppress? extended? tail + sandbox? null-data? separate? "")] + [else + (display (string-append "sed: invalid option -- '" (string c) "'\n") + (current-error-port)) + (exit 1)])))) + + (define (re-parse rest scripts files suppress? extended? in-place + sandbox? null-data? separate? remaining-opts) + (if (string=? remaining-opts "") + (parse-args-continue rest scripts files suppress? extended? in-place + sandbox? null-data? separate?) + (parse-short rest scripts files suppress? extended? in-place + sandbox? null-data? separate? remaining-opts))) + + (define (parse-args-continue rest scripts files suppress? extended? in-place + sandbox? null-data? separate?) + (let loop ([args rest] + [scripts scripts] + [files files] + [suppress? suppress?] + [extended? extended?] + [in-place in-place] + [sandbox? sandbox?] + [null-data? null-data?] + [separate? separate?]) + (if (null? args) + (values (reverse scripts) (reverse files) + suppress? extended? in-place sandbox? null-data? separate?) + (let ([arg (car args)] [rest (cdr args)]) + (cond + [(string=? arg "--") + (loop '() scripts (append (reverse rest) files) + suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--quiet") + (loop rest scripts files #t extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--silent") + (loop rest scripts files #t extended? in-place sandbox? null-data? separate?)] + [(or (string=? arg "--regexp-extended") (string=? arg "-E") (string=? arg "-r")) + (loop rest scripts files suppress? #t in-place sandbox? null-data? separate?)] + [(string=? arg "--sandbox") + (loop rest scripts files suppress? extended? in-place #t null-data? separate?)] + [(or (string=? arg "--null-data") (string=? arg "-z")) + (loop rest scripts files suppress? extended? in-place sandbox? #t separate?)] + [(or (string=? arg "--separate") (string=? arg "-s")) + (loop rest scripts files suppress? extended? in-place sandbox? null-data? #t)] + [(or (string=? arg "--posix") (string=? arg "--follow-symlinks")) + (loop rest scripts files suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--in-place") + (loop rest scripts files suppress? extended? "" sandbox? null-data? separate?)] + [(string-prefix? "--in-place=" arg) + (loop rest scripts files suppress? extended? + (substring arg 11 (string-length arg)) sandbox? null-data? separate?)] + [(string-prefix? "--expression=" arg) + (loop rest (cons (substring arg 13 (string-length arg)) scripts) + files suppress? extended? in-place sandbox? null-data? separate?)] + [(string-prefix? "--file=" arg) + (loop rest (cons (read-script-file (substring arg 7 (string-length arg))) scripts) + files suppress? extended? in-place sandbox? null-data? separate?)] + [(string=? arg "--help") (display-help) (exit 0)] + [(string=? arg "--version") (display "sed (jerboa-sed) 0.1.0\n") (exit 0)] + [(and (fx> (string-length arg) 1) (char=? (string-ref arg 0) #\-)) + (parse-short rest scripts files suppress? extended? in-place + sandbox? null-data? separate? + (substring arg 1 (string-length arg)))] + [(null? scripts) + (loop rest (list arg) files suppress? extended? in-place sandbox? null-data? separate?)] + [else + (loop rest scripts (cons arg files) + suppress? extended? in-place sandbox? null-data? separate?)]))))) + + (define (read-script-file filename) + (guard (e [else + (display (string-append "sed: can't read " filename "\n") + (current-error-port)) + (exit 1)]) + (call-with-input-file filename + (lambda (port) + (let loop ([lines '()]) + (let ([line (get-line port)]) + (if (eof-object? line) + (string-join-sep (reverse lines) "\n") + (loop (cons line lines))))))))) + + (define (display-help) + (display "Usage: sed [OPTION]... {script-only-if-no-other-script} [input-file]... + + -n, --quiet, --silent + suppress automatic printing of pattern space + -e script, --expression=script + add the script to the commands to be executed + -f script-file, --file=script-file + add the contents of script-file to the commands to be executed + -E, -r, --regexp-extended + use extended regular expressions in the script + -i[SUFFIX], --in-place[=SUFFIX] + edit files in-place (makes backup if SUFFIX supplied) + -s, --separate + consider files as separate rather than as a single continuous stream + -z, --null-data + separate lines by NUL characters + --sandbox operate in sandbox mode + --help display this help and exit + --version output version information and exit + +")) + + ;;; File processing + + (define (read-line-or-eof port) + (let ([line (get-line port)]) + (if (eof-object? line) 'eof line))) + + (define (open-file-or-stdin filename) + (if (string=? filename "-") + (current-input-port) + (guard (e [else + (display (string-append "sed: " filename ": ") + (current-error-port)) + (display-condition e (current-error-port)) + (newline (current-error-port)) + #f]) + (open-input-file filename)))) + + (define (process-files state prog files out-port) + (let* ([file-list (if (null? files) '("-") files)] + [n (length file-list)]) + (if (sed-state-separate? state) + (let loop ([lst file-list]) + (unless (null? lst) + (sed-state-line-num-set! state 0) + (sed-state-sub-succeeded?-set! state #f) + (process-one-file! state prog (car lst) #t out-port) + (loop (cdr lst)))) + (let loop ([lst file-list] [i 0]) + (unless (null? lst) + (process-one-file! state prog (car lst) (fx= i (fx- n 1)) out-port) + (loop (cdr lst) (fx+ i 1))))))) + + (define (process-one-file! state prog filename is-last-file? out-port) + (sed-state-filename-set! state filename) + (let ([port (open-file-or-stdin filename)]) + (when port + (let ([first (read-line-or-eof port)]) + (unless (eq? first 'eof) + (let ([nxt (box (read-line-or-eof port))]) + (let main-loop ([cur first]) + (unless (eq? cur 'eof) + (sed-state-line-num-set! state (fx+ (sed-state-line-num state) 1)) + (sed-state-last-line?-set! state + (and (eq? (unbox nxt) 'eof) is-last-file?)) + (sed-state-pattern-space-set! state cur) + (sed-state-sub-succeeded?-set! state #f) + (let cycle-loop ([start-pc 0]) + (let ([sig (run-sed-cycle-from! state prog out-port start-pc)]) + (cond + [(eq? sig 'next) + (let ([new-cur (unbox nxt)]) + (unless (eq? new-cur 'eof) + (set-box! nxt (read-line-or-eof port))) + (main-loop new-cur))] + [(eq? sig 'restart) + (cycle-loop 0)] + [(and (pair? sig) (eq? (car sig) 'append-next)) + (let ([resume-pc (fx+ (cdr sig) 1)] + [next-line (unbox nxt)]) + (if (eq? next-line 'eof) + (begin + (unless (sed-state-suppress? state) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (flush-append-queue! state out-port)) + (begin + (sed-state-line-num-set! state + (fx+ (sed-state-line-num state) 1)) + (set-box! nxt (read-line-or-eof port)) + (sed-state-last-line?-set! state + (and (eq? (unbox nxt) 'eof) is-last-file?)) + (sed-state-pattern-space-set! state + (string-append (sed-state-pattern-space state) + "\n" next-line)) + (cycle-loop resume-pc))))] + [(and (pair? sig) (eq? (car sig) 'read-next)) + (let ([resume-pc (fx+ (cdr sig) 1)] + [next-line (unbox nxt)]) + (unless (eq? next-line 'eof) + (sed-state-line-num-set! state + (fx+ (sed-state-line-num state) 1)) + (set-box! nxt (read-line-or-eof port)) + (sed-state-last-line?-set! state + (and (eq? (unbox nxt) 'eof) is-last-file?)) + (sed-state-pattern-space-set! state next-line) + (sed-state-sub-succeeded?-set! state #f) + (cycle-loop resume-pc)))] + [(and (pair? sig) (eq? (car sig) 'quit)) + (unless (string=? filename "-") + (close-input-port port)) + (exit (cdr sig))] + [else + (let ([new-cur (unbox nxt)]) + (unless (eq? new-cur 'eof) + (set-box! nxt (read-line-or-eof port))) + (main-loop new-cur))])))))))) + (when (and port (not (string=? filename "-"))) + (close-input-port port))))) + + ;;; In-place editing + + (define (process-in-place state prog files suffix) + (when (null? files) + (display "sed: no input files for in-place editing\n" (current-error-port)) + (exit 1)) + (for-each + (lambda (filename) + (unless (string=? filename "-") + (let ([tmp (string-append filename ".jsed-tmp")]) + (guard (e [else + (display (string-append "sed: " filename ": ") + (current-error-port)) + (display-condition e (current-error-port)) + (newline (current-error-port)) + (when (file-exists? tmp) (delete-file tmp))]) + (let ([out-port (open-file-output-port tmp + (file-options no-fail) + (buffer-mode block) + (make-transcoder (utf-8-codec)))]) + (process-one-file! state prog filename #t out-port) + (close-port out-port)) + (when (and suffix (not (string=? suffix ""))) + (rename-file filename (string-append filename suffix))) + (rename-file tmp filename))))) + files)) + + ;;; Utilities + + (define (string-prefix? prefix str) + (let ([plen (string-length prefix)]) + (and (fx<= plen (string-length str)) + (string=? prefix (substring str 0 plen))))) + + (define (string-join-sep strs sep) + (if (null? strs) "" + (let loop ([rest (cdr strs)] [acc (car strs)]) + (if (null? rest) acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + +) ;; end library