rash-coreutils/private/extended.rkt

#lang racket/base

;; rash-coreutils 0.2.14
;; Streaming implementation of the extended core utilities.

(require gregor
         racket/file
         racket/format
         racket/list
         racket/path
         racket/port
         racket/set
         racket/string
         racket/system
         "env-support.rkt"
         "path-output.rkt")

(provide coreutils-head
         coreutils-tail
         coreutils-wc
         coreutils-sort
         coreutils-uniq
         coreutils-cut
         coreutils-tee
         coreutils-tr
         coreutils-basename
         coreutils-dirname
         coreutils-realpath
         coreutils-readlink
         coreutils-stat
         coreutils-du
         coreutils-df
         coreutils-mktemp
         coreutils-printenv
         coreutils-env
         coreutils-date
         coreutils-time)

(define (arg->string arg)
  (cond
    [(path? arg) (path->string arg)]
    [(symbol? arg) (symbol->string arg)]
    [(string? arg) arg]
    [else (~a arg)]))

(define (arg->path arg)
  (string->path (arg->string arg)))

;; Calls proc for each input port. Proc returns #t to continue with the
;; next file and #f to stop processing input early.
(define (for-each-input-port/while args proc)
  (cond
    [(null? args)
     (proc (current-input-port))]
    [else
     (let loop ([rest args])
       (cond
         [(null? rest) #t]
         [else
          (define continue?
            (call-with-input-file* (arg->path (car rest)) proc))
          (and continue?
               (loop (cdr rest)))]))]))

(define (for-each-input-port args proc)
  (for-each-input-port/while
   args
   (λ (in)
     (proc in)
     #t))
  (void))

(define (for-each-input-line/while args proc)
  (for-each-input-port/while
   args
   (λ (in)
     (let loop ()
       (define line (read-line in 'any))
       (cond
         [(eof-object? line) #t]
         [(proc line) (loop)]
         [else #f])))))

(define (for-each-input-line args proc)
  (for-each-input-line/while
   args
   (λ (line)
     (proc line)
     #t))
  (void))

(define (parse-n-option who args default)
  (cond
    [(and (pair? args)
          (member (arg->string (car args)) '("-n" "--lines")))
     (unless (pair? (cdr args))
       (raise-arguments-error who "missing line count" "arguments" args))
     (define n (string->number (arg->string (cadr args))))
     (unless (and (exact-integer? n) (>= n 0))
       (raise-arguments-error who "line count must be a non-negative integer"
                              "count" (cadr args)))
     (values n (cddr args))]
    [else
     (values default args)]))

(define line-stream-buffer-size (* 64 1024))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the first requested number of input lines.
; pre    : args contains an optional -n/--lines non-negative integer and
;          readable file arguments; without files, current-input-port is used.
; post   : File input ports opened by this procedure are closed. Input after
;          the requested number of LF-terminated lines is not read.
; result : (void); at most n lines are written to current-output-port.
; internals:
;          Input is scanned in fixed 64 KiB byte blocks. Bytes are written as
;          soon as they are read and only LF bytes are counted. A complete
;          input line is never materialized, so memory use is independent of
;          both the complete input size and the length of an individual line.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-head . args)
  (define-values (n files) (parse-n-option 'head args 10))
  (unless (zero? n)
    (let ([remaining n])
      (for-each-input-port/while
       files
       (λ (in)
         (define buffer (make-bytes line-stream-buffer-size))
         (let loop ()
           (define count (read-bytes-avail! buffer in))
           (cond
             [(eof-object? count) #t]
             [else
              (define stop-position #f)
              (let scan ([position 0])
                (when (and (< position count)
                           (eq? stop-position #f))
                  (when (= (bytes-ref buffer position) 10)
                    (set! remaining (sub1 remaining))
                    (when (zero? remaining)
                      (set! stop-position (add1 position))))
                  (scan (add1 position))))
              (cond
                [stop-position
                 (write-bytes buffer
                              (current-output-port)
                              0
                              stop-position)
                 #f]
                [else
                 (write-bytes buffer
                              (current-output-port)
                              0
                              count)
                 (loop)])]))))))
  (void))

;; Return the byte position at which the final n lines start. The input port
;; must be a seekable file port positioned anywhere in the file.
(define (tail-start-position in size n)
  (cond
    [(or (zero? n) (zero? size)) size]
    [else
     (file-position in (sub1 size))
     (define ends-with-newline?
       (= (read-byte in) 10))
     (define newlines-needed
       (if ends-with-newline?
           (add1 n)
           n))
     (define buffer (make-bytes line-stream-buffer-size))
     (let block-loop ([block-end size]
                      [remaining newlines-needed])
       (cond
         [(zero? block-end) 0]
         [else
          (define block-start
            (max 0 (- block-end line-stream-buffer-size)))
          (define count (- block-end block-start))
          (file-position in block-start)
          (define read-count (read-bytes! buffer in 0 count))
          (unless (and (exact-integer? read-count)
                       (>= read-count 0)
                       (= read-count count))
            (error 'tail "could not read requested file block"))
          (let scan ([position (sub1 count)]
                     [needed remaining])
            (cond
              [(negative? position)
               (block-loop block-start needed)]
              [(= (bytes-ref buffer position) 10)
               (define next-needed (sub1 needed))
               (if (zero? next-needed)
                   (+ block-start position 1)
                   (scan (sub1 position) next-needed))]
              [else
               (scan (sub1 position) needed)]))]))]))

;; Write the final n lines from a seekable file without reading a complete
;; line into memory.
(define (write-tail-file path n)
  (call-with-input-file*
   path
   (λ (in)
     (define size (file-size path))
     (define start (tail-start-position in size n))
     (file-position in start)
     (copy-port in (current-output-port)))))

;; Tail cannot know which bytes from a non-seekable stream are final until EOF.
;; Spool such input to disk so memory stays bounded.
(define (write-tail-stream in n)
  (define temp-path (make-temporary-file "rash-coreutils-tail-~a"))
  (dynamic-wind
    void
    (λ ()
      (call-with-output-file
       temp-path
       (λ (out)
         (copy-port in out))
       #:exists 'truncate/replace)
      (write-tail-file temp-path n))
    (λ ()
      (when (file-exists? temp-path)
        (delete-file temp-path)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the last requested number of input lines.
; pre    : args contains an optional -n/--lines non-negative integer and
;          readable file arguments; without files, current-input-port is used.
; post   : All required input has been consumed and every temporary file or
;          file input port opened by this procedure is closed and removed.
; result : (void); at most the last n LF-delimited lines are written to
;          current-output-port.
; internals:
;          A single named file is scanned backwards in fixed 64 KiB byte
;          blocks and then copied from the calculated start position. stdin
;          and multiple file arguments are first spooled to one temporary
;          file and handled in the same way. No complete input line is ever
;          materialized, so even an individual line larger than available
;          memory does not cause the tail buffer itself to grow.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-tail . args)
  (define-values (n files) (parse-n-option 'tail args 10))
  (unless (zero? n)
    (cond
      [(null? files)
       (write-tail-stream (current-input-port) n)]
      [(null? (cdr files))
       (write-tail-file (arg->path (car files)) n)]
      [else
       ;; Keep the existing no-header behavior for multiple file arguments.
       ;; Their bytes are concatenated on disk before the backwards scan.
       (define temp-path (make-temporary-file "rash-coreutils-tail-~a"))
       (dynamic-wind
         void
         (λ ()
           (call-with-output-file
            temp-path
            (λ (out)
              (for ([file (in-list files)])
                (call-with-input-file*
                 (arg->path file)
                 (λ (in)
                   (copy-port in out)))))
            #:exists 'truncate/replace)
           (write-tail-file temp-path n))
         (λ ()
           (when (file-exists? temp-path)
             (delete-file temp-path))))]))
  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Count lines, words and/or bytes in input without materializing the
;          complete input.
; pre    : args contains only -l, -w, -c/--bytes and readable file arguments;
;          without files, current-input-port is used.
; post   : All input has been consumed and file input ports opened by this
;          procedure are closed.
; result : (void); the selected counts are written to current-output-port.
;          With no count options, line, word and byte counts are written.
; internals:
;          Input is processed in a fixed 64 KiB byte buffer. Newlines and
;          ASCII whitespace are recognized directly from bytes. Only counters
;          and the current word state are retained; a file boundary ends a
;          word for the combined result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-wc . args)
  (define lines? #f)
  (define words? #f)
  (define bytes? #f)
  (define reversed-files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(string=? text "-l") (set! lines? #t)]
      [(string=? text "-w") (set! words? #t)]
      [(or (string=? text "-c") (string=? text "--bytes")) (set! bytes? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'wc "unsupported option" "option" text)]
      [else
       (set! reversed-files (cons arg reversed-files))]))
  (when (not (or lines? words? bytes?))
    (set! lines? #t)
    (set! words? #t)
    (set! bytes? #t))
  (define files (reverse reversed-files))

  (define line-count 0)
  (define word-count 0)
  (define byte-count 0)
  (define inside-word? #f)

  ;; The previous implementation used #px"\\s" after UTF-8 decoding.
  ;; Pregexp whitespace is ASCII whitespace, so word boundaries can be
  ;; counted directly from bytes. UTF-8 continuation bytes can never equal
  ;; one of these ASCII bytes, which makes this both exact and fast.
  (define (word-whitespace-byte? byte)
    (or (= byte 32)                    ; space
        (= byte 9)                     ; tab
        (= byte 10)                    ; line feed
        (= byte 11)                    ; vertical tab
        (= byte 12)                    ; form feed
        (= byte 13)))                  ; carriage return

  (define (process-port in)
    (define buffer (make-bytes (* 64 1024)))
    (let loop ()
      (define count (read-bytes-avail! buffer in))
      (unless (eof-object? count)
        (when bytes?
          (set! byte-count (+ byte-count count)))
        (when (or lines? words?)
          (for ([i (in-range count)])
            (define byte (bytes-ref buffer i))
            (when (and lines? (= byte 10))
              (set! line-count (add1 line-count)))
            (when words?
              (cond
                [(word-whitespace-byte? byte)
                 (set! inside-word? #f)]
                [(not inside-word?)
                 (set! word-count (add1 word-count))
                 (set! inside-word? #t)]))))
        (loop)))
    ;; A file boundary also ends a word. This prevents the last word of one
    ;; file and the first word of the next file from being counted as one.
    (when words?
      (set! inside-word? #f)))

  (for-each-input-port files process-port)

  (define results
    (filter (λ (x) x)
            (list (if lines? (number->string line-count) #f)
                  (if words? (number->string word-count) #f)
                  (if bytes? (number->string byte-count) #f))))
  (displayln (string-join results " ")))

(define sort-run-memory-limit (* 16 1024 1024))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Sort input lines lexically or numerically without keeping the
;          complete input in memory.
; pre    : args contains only supported sort options (-r/--reverse and
;          -n/--numeric-sort) followed by readable file arguments; when no
;          files are supplied, current-input-port provides the input.
; post   : All temporary run files and ports created by this procedure are
;          closed and removed, including when sorting or merging raises an
;          exception.
; result : (void); sorted lines are written to current-output-port.
; internals:
;          Input is collected in approximately 16 MiB runs. Each run is
;          sorted in memory and written to a temporary file. Runs are then
;          merged pairwise until one run remains. During merging only one
;          current line from each of two runs is kept in memory.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-sort . args)
  (define reverse? #f)
  (define numeric? #f)
  (define reversed-files '())

  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-r") (string=? text "--reverse"))
       (set! reverse? #t)]
      [(or (string=? text "-n") (string=? text "--numeric-sort"))
       (set! numeric? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'sort "unsupported option" "option" text)]
      [else
       (set! reversed-files (cons arg reversed-files))]))

  (define files (reverse reversed-files))
  (define temp-paths '())

  (define (sort-key line)
    (if numeric?
        (let ([value (string->number line)])
          (if (real? value)
              value
              +inf.0))
        line))

  (define (key<? a b)
    (cond
      [numeric?
       (if reverse?
           (> a b)
           (< a b))]
      [else
       (if reverse?
           (string>? a b)
           (string<? a b))]))

  (define (make-sort-temp-file)
    (define path (make-temporary-file "rash-coreutils-sort-~a"))
    (set! temp-paths (cons path temp-paths))
    path)

  (define (delete-sort-temp-file path)
    (with-handlers ([exn:fail:filesystem? (λ (_e) (void))])
      (when (file-exists? path)
        (delete-file path))))

  (define (write-run lines)
    (define path (make-sort-temp-file))
    (define sorted-lines
      (sort (reverse lines)
            key<?
            #:key sort-key
            #:cache-keys? #t))
    (call-with-output-file
     path
     (λ (out)
       (for ([line (in-list sorted-lines)])
         (displayln line out)))
     #:exists 'truncate/replace)
    path)

  (define (merge-two-runs left-path right-path)
    (define output-path (make-sort-temp-file))
    (call-with-input-file
     left-path
     (λ (left-in)
       (call-with-input-file
        right-path
        (λ (right-in)
          (call-with-output-file
           output-path
           (λ (out)
             (define first-left-line (read-line left-in 'any))
             (define first-right-line (read-line right-in 'any))
             (let loop ([left-line first-left-line]
                        [left-key (if (eof-object? first-left-line)
                                      #f
                                      (sort-key first-left-line))]
                        [right-line first-right-line]
                        [right-key (if (eof-object? first-right-line)
                                       #f
                                       (sort-key first-right-line))])
               (cond
                 [(eof-object? left-line)
                  (unless (eof-object? right-line)
                    (displayln right-line out)
                    (copy-port right-in out))]
                 [(eof-object? right-line)
                  (displayln left-line out)
                  (copy-port left-in out)]
                 [(key<? right-key left-key)
                  (displayln right-line out)
                  (let ([next-right-line (read-line right-in 'any)])
                    (loop left-line
                          left-key
                          next-right-line
                          (if (eof-object? next-right-line)
                              #f
                              (sort-key next-right-line))))]
                 [else
                  ;; Equal lines are taken from the left run first. Because
                  ;; runs preserve input order, this keeps the merge stable.
                  (displayln left-line out)
                  (let ([next-left-line (read-line left-in 'any)])
                    (loop next-left-line
                          (if (eof-object? next-left-line)
                              #f
                              (sort-key next-left-line))
                          right-line
                          right-key))])))
           #:exists 'truncate/replace)))))
    (delete-sort-temp-file left-path)
    (delete-sort-temp-file right-path)
    output-path)

  (define (merge-pass runs)
    (let loop ([rest runs] [result '()])
      (cond
        [(null? rest)
         (reverse result)]
        [(null? (cdr rest))
         (reverse (cons (car rest) result))]
        [else
         (define merged
           (merge-two-runs (car rest) (cadr rest)))
         (loop (cddr rest) (cons merged result))])))

  (dynamic-wind
    void
    (λ ()
      (define run-paths '())
      (define run-lines '())
      (define run-size 0)

      (define (flush-run!)
        (unless (null? run-lines)
          (set! run-paths (cons (write-run run-lines) run-paths))
          (set! run-lines '())
          (set! run-size 0)))

      (for-each-input-line
       files
       (λ (line)
         (set! run-lines (cons line run-lines))
         ;; This is an intentionally conservative approximation. Its purpose
         ;; is to bound a run, not to calculate exact Racket object sizes.
         (set! run-size
               (+ run-size
                  64
                  (* 4 (string-length line))))
         (when (>= run-size sort-run-memory-limit)
           (flush-run!))))

      (flush-run!)
      (set! run-paths (reverse run-paths))

      (let reduce ([runs run-paths])
        (cond
          [(null? runs)
           (void)]
          [(null? (cdr runs))
           (call-with-input-file
            (car runs)
            (λ (in)
              (copy-port in (current-output-port))))]
          [else
           (reduce (merge-pass runs))])))
    (λ ()
      (for ([path (in-list temp-paths)])
        (delete-sort-temp-file path)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Remove adjacent duplicate input lines, optionally writing the run
;          count for each distinct line.
; pre    : args contains only -c/--count and readable file arguments; without
;          files, current-input-port is used. Input should already be grouped
;          when duplicates that are not adjacent must also be removed.
; post   : All input has been consumed and file input ports opened by this
;          procedure are closed.
; result : (void); one output line is written for each adjacent run.
; internals:
;          Only the current line and its count are retained. A completed run
;          is written as soon as a different line is read.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-uniq . args)
  (define count? #f)
  (define reversed-files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-c") (string=? text "--count"))
       (set! count? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'uniq "unsupported option" "option" text)]
      [else
       (set! reversed-files (cons arg reversed-files))]))
  (define files (reverse reversed-files))
  (define current-line #f)
  (define current-count 0)

  (define (write-current!)
    (when current-line
      (if count?
          (printf "~a ~a\n"
                  (~a current-count #:min-width 7 #:align 'right)
                  current-line)
          (displayln current-line))))

  (for-each-input-line
   files
   (λ (line)
     (cond
       [(and current-line (string=? current-line line))
        (set! current-count (add1 current-count))]
       [else
        (write-current!)
        (set! current-line line)
        (set! current-count 1)])))
  (write-current!))

(define (parse-field-spec text)
  (define n (string->number text))
  (unless (and (exact-positive-integer? n))
    (raise-arguments-error 'cut "only one positive field number is supported"
                           "field" text))
  n)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write one selected delimited field from every input line.
; pre    : args contains -f/--fields with one positive field number, an
;          optional -d/--delimiter, and readable file arguments; without
;          files, current-input-port is used.
; post   : All input has been consumed and file input ports opened by this
;          procedure are closed. Lines without the selected field produce no
;          output.
; result : (void); selected field values are written to current-output-port.
; internals:
;          Input is read one line at a time. Only the current line is split
;          into fields, so memory use is bounded by the size of one line.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-cut . args)
  (define delimiter "\t")
  (define field #f)
  (define reversed-files '())
  (let loop ([rest args])
    (cond
      [(null? rest) (void)]
      [(member (arg->string (car rest)) '("-d" "--delimiter"))
       (unless (pair? (cdr rest))
         (raise-arguments-error 'cut "missing delimiter" "arguments" args))
       (set! delimiter (arg->string (cadr rest)))
       (loop (cddr rest))]
      [(member (arg->string (car rest)) '("-f" "--fields"))
       (unless (pair? (cdr rest))
         (raise-arguments-error 'cut "missing field" "arguments" args))
       (set! field (parse-field-spec (arg->string (cadr rest))))
       (loop (cddr rest))]
      [(string-prefix? (arg->string (car rest)) "-")
       (raise-arguments-error 'cut "unsupported option" "option" (car rest))]
      [else
       (set! reversed-files (cons (car rest) reversed-files))
       (loop (cdr rest))]))
  (unless field
    (raise-arguments-error 'cut "expected -f FIELD" "arguments" args))
  (define files (reverse reversed-files))
  (for-each-input-line
   files
   (λ (line)
     (define parts (string-split line delimiter #:trim? #f #:repeat? #f))
     (when (<= field (length parts))
       (displayln (list-ref parts (sub1 field)))))))

(define (open-output-files paths append?)
  (let loop ([rest paths] [opened '()])
    (cond
      [(null? rest) (reverse opened)]
      [else
       (with-handlers
           ([exn?
             (λ (e)
               (for ([out (in-list opened)])
                 (close-output-port out))
               (raise e))])
         (loop (cdr rest)
               (cons (open-output-file
                      (car rest)
                      #:exists (if append? 'append 'truncate/replace))
                     opened)))])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Copy standard input to standard output and to each requested file.
; pre    : args contains only -a/--append and writable file paths.
; post   : Every output file opened by this procedure is closed, including
;          when copying raises an exception. Existing files are replaced
;          unless append mode was requested.
; result : (void); the complete input has been copied to every output.
; internals:
;          Racket copy-port performs the streaming copy directly. Files are
;          opened before copying and dynamic-wind guarantees their cleanup.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-tee . args)
  (define append? #f)
  (define reversed-files '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-a") (string=? text "--append"))
       (set! append? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'tee "unsupported option" "option" text)]
      [else
       (set! reversed-files (cons (arg->path arg) reversed-files))]))
  (define outputs (open-output-files (reverse reversed-files) append?))
  (dynamic-wind
    void
    (λ ()
      (apply copy-port
             (current-input-port)
             (current-output-port)
             outputs))
    (λ ()
      (for ([out (in-list outputs)])
        (close-output-port out)))))

(define (expand-character-set text)
  (define chars (string->list text))
  (let loop ([rest chars] [result '()])
    (cond
      [(null? rest)
       (reverse result)]
      [(and (pair? (cdr rest))
            (pair? (cddr rest))
            (char=? (cadr rest) #\-)
            (char<=? (car rest) (caddr rest)))
       (define start (char->integer (car rest)))
       (define end (char->integer (caddr rest)))
       (define expanded-result
         (for/fold ([expanded result]) ([code (in-range start (add1 end))])
           (cons (integer->char code) expanded)))
       (loop (cdddr rest) expanded-result)]
      [else
       (loop (cdr rest) (cons (car rest) result))])))

(define (make-translation-mapping from to)
  (when (null? to)
    (raise-arguments-error 'tr "SET2 must not be empty" "SET2" to))
  (define to-vector (list->vector to))
  (define to-count (vector-length to-vector))
  (define last-to (vector-ref to-vector (sub1 to-count)))
  (for/hash ([ch (in-list from)] [i (in-naturals)])
    (values ch
            (if (< i to-count)
                (vector-ref to-vector i)
                last-to))))

(define (stream-tr delete-set mapping squeeze-set)
  (define previous #f)
  (let loop ()
    (define ch (read-char (current-input-port)))
    (unless (eof-object? ch)
      (unless (and delete-set (set-member? delete-set ch))
        (let ([translated
               (if mapping
                   (hash-ref mapping ch ch)
                   ch)])
          (unless (and previous
                       squeeze-set
                       (char=? previous translated)
                       (set-member? squeeze-set translated))
            (write-char translated)
            (set! previous translated))))
      (loop))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Translate, delete and/or squeeze characters from current input.
; pre    : args contains a supported combination of -d/--delete,
;          -s/--squeeze-repeats and the required one or two character sets.
;          Character ranges use the simple a-z form supported by this module.
; post   : current-input-port has been consumed to end-of-file.
; result : (void); transformed characters are written to current-output-port.
; internals:
;          Character sets are expanded once into sets or a translation hash.
;          stream-tr then reads and writes one character at a time and keeps
;          only the previous emitted character for squeeze processing.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-tr . args)
  (define delete? #f)
  (define squeeze? #f)
  (define reversed-sets '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-d") (string=? text "--delete"))
       (set! delete? #t)]
      [(or (string=? text "-s") (string=? text "--squeeze-repeats"))
       (set! squeeze? #t)]
      [(or (string=? text "-ds") (string=? text "-sd"))
       (set! delete? #t)
       (set! squeeze? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'tr "unsupported option" "option" text)]
      [else
       (set! reversed-sets (cons text reversed-sets))]))
  (define sets (reverse reversed-sets))

  (cond
    [(and delete? squeeze?)
     (unless (= (length sets) 2)
       (raise-arguments-error 'tr "expected SET1 SET2 with -ds" "arguments" args))
     (define delete-set
       (list->seteq (expand-character-set (first sets))))
     (define squeeze-set
       (list->seteq (expand-character-set (second sets))))
     (stream-tr delete-set #f squeeze-set)]
    [delete?
     (unless (= (length sets) 1)
       (raise-arguments-error 'tr "expected one character set with -d" "arguments" args))
     (define delete-set
       (list->seteq (expand-character-set (first sets))))
     (stream-tr delete-set #f #f)]
    [(and squeeze? (= (length sets) 1))
     (define squeeze-set
       (list->seteq (expand-character-set (first sets))))
     (stream-tr #f #f squeeze-set)]
    [else
     (unless (= (length sets) 2)
       (raise-arguments-error 'tr "expected SET1 SET2" "arguments" args))
     (define from (expand-character-set (first sets)))
     (define to (expand-character-set (second sets)))
     (define mapping (make-translation-mapping from to))
     (define squeeze-set (if squeeze? (list->seteq to) #f))
     (stream-tr #f mapping squeeze-set)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the final path component of one path.
; pre    : Exactly one path argument is supplied.
; post   : No filesystem state is changed.
; result : (void); the final path component, or an empty string when there is
;          none, is written to current-output-port.
; internals:
;          file-name-from-path extracts the final component without reading
;          the filesystem.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-basename . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'basename "expected one path" "arguments" args))
  (define name (file-name-from-path (arg->path (car args))))
  (displayln (if name (path->string name) "")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the directory component of one path.
; pre    : Exactly one path argument is supplied.
; post   : No filesystem state is changed.
; result : (void); the directory part is written to current-output-port.
; internals:
;          split-path is used so platform-specific path syntax is handled by
;          Racket; a relative path without a directory is reported as '.'.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-dirname . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'dirname "expected one path" "arguments" args))
  (define-values (base name dir?) (split-path (arg->path (car args))))
  (displayln
   (cond
     [(path? base) (path->rash-string base)]
     [(eq? base 'relative) "."]
     [else (path->rash-string (arg->path (car args)))])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write a simplified absolute path with filesystem links resolved.
; pre    : Exactly one path argument is supplied and path resolution can be
;          performed by the current filesystem.
; post   : No filesystem state is changed.
; result : (void); the resolved path is written to current-output-port.
; internals:
;          path->complete-path makes the path absolute and simplify-path with
;          filesystem resolution enabled resolves path components and links.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-realpath . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'realpath "expected one path" "arguments" args))
  (displayln (path->rash-string (simplify-path (path->complete-path (arg->path (car args))) #t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the target of one symbolic link.
; pre    : Exactly one path argument is supplied and it names a symbolic link.
; post   : No filesystem state is changed.
; result : (void); the resolved link target is written to current-output-port.
; internals:
;          link-exists? validates the path before resolve-path is used.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-readlink . args)
  (unless (= (length args) 1)
    (raise-arguments-error 'readlink "expected one path" "arguments" args))
  (define path (arg->path (car args)))
  (unless (link-exists? path)
    (raise-arguments-error 'readlink "path is not a symbolic link" "path" path))
  (displayln (path->rash-string (resolve-path path))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write basic type, size and modification information for paths.
; pre    : At least one existing file, directory or symbolic-link path is
;          supplied.
; post   : No filesystem state is changed.
; result : (void); one information block per path is written to
;          current-output-port.
; internals:
;          Racket filesystem predicates determine the type; file-size is used
;          only for files and file-or-directory-modify-seconds supplies the
;          modification timestamp.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-stat . args)
  (when (null? args)
    (raise-arguments-error 'stat "expected at least one path" "arguments" args))
  (for ([arg (in-list args)])
    (define path (arg->path arg))
    (unless (or (file-exists? path) (directory-exists? path) (link-exists? path))
      (raise-arguments-error 'stat "path does not exist" "path" path))
    (printf "Path: ~a\n" (path->rash-string (path->complete-path path)))
    (printf "Type: ~a\n"
            (cond [(link-exists? path) "link"]
                  [(directory-exists? path) "directory"]
                  [else "file"]))
    (when (file-exists? path) (printf "Size: ~a\n" (file-size path)))
    (printf "Modified: ~a\n" (file-or-directory-modify-seconds path))))

(define (path-size path)
  (case (file-or-directory-type path #t)
    [(file)
     (file-size path)]
    [(directory)
     ;; Do not follow symbolic links. Apart from avoiding link cycles, this
     ;; also keeps traversal memory proportional to traversal depth instead
     ;; of materializing the complete directory tree.
     (fold-files
      (λ (entry type total)
        (if (eq? type 'file)
            (+ total (file-size entry))
            total))
      0
      path
      #f)]
    [(link directory-link) 0]
    [else 0]))

(define (human-size n)
  (cond
    [(>= n (* 1024 1024 1024)) (format "~aG" (~r (/ n (* 1024.0 1024 1024)) #:precision '(= 1)))]
    [(>= n (* 1024 1024)) (format "~aM" (~r (/ n (* 1024.0 1024)) #:precision '(= 1)))]
    [(>= n 1024) (format "~aK" (~r (/ n 1024.0) #:precision '(= 1)))]
    [else (format "~aB" n)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the accumulated file size for each requested path.
; pre    : args contains only -h/--human-readable and filesystem paths; when
;          no paths are supplied, current-directory is used.
; post   : No filesystem state is changed and symbolic links are not followed.
; result : (void); one size and path line is written for every requested path.
; internals:
;          path-size uses fold-files for directories and adds file sizes while
;          explicitly avoiding link traversal. This prevents link cycles and
;          avoids materializing a complete directory tree.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-du . args)
  (define human? #f)
  (define reversed-paths '())
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-h") (string=? text "--human-readable"))
       (set! human? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'du "unsupported option" "option" text)]
      [else
       (set! reversed-paths (cons (arg->path arg) reversed-paths))]))
  (define paths
    (if (null? reversed-paths)
        (list (current-directory))
        (reverse reversed-paths)))
  (for ([path (in-list paths)])
    (define size (path-size path))
    (printf "~a\t~a\n"
            (if human? (human-size size) size)
            (path->rash-string path))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List filesystem roots visible to Racket.
; pre    : No arguments are supplied.
; post   : No filesystem state is changed.
; result : (void); a header and the filesystem roots are written to
;          current-output-port.
; internals:
;          filesystem-root-list supplies the platform-specific root paths.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-df . args)
  (unless (null? args)
    (raise-arguments-error 'df "this portable implementation does not accept arguments yet"
                           "arguments" args))
  (displayln "Filesystem")
  (for ([root (in-list (filesystem-root-list))])
    (displayln (path->rash-string root))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a unique temporary file or directory and write its path.
; pre    : args contains only -d/--directory and at most a supported temporary
;          filename template.
; post   : One new temporary file or directory exists on success.
; result : (void); the created path is written to current-output-port.
; internals:
;          make-temporary-file performs unique-name creation atomically using
;          Racket's temporary-file facilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-mktemp . args)
  (define directory? #f)
  (define template "tmp~a")
  (for ([arg (in-list args)])
    (define text (arg->string arg))
    (cond
      [(or (string=? text "-d") (string=? text "--directory")) (set! directory? #t)]
      [(string-prefix? text "-")
       (raise-arguments-error 'mktemp "unsupported option" "option" text)]
      [else (set! template text)]))
  (define result (make-temporary-file template (if directory? 'directory #f)))
  (displayln (path->rash-string result)))

(define (environment-name->string name)
  (bytes->string/locale name))

(define (environment-value->string value)
  (bytes->string/locale value))

(define (write-environment env)
  (define names
    (sort (environment-variables-names env)
          string<?
          #:key environment-name->string))
  (for ([name (in-list names)])
    (define value (environment-variables-ref env name))
    (when value
      (printf "~a=~a\n" (environment-name->string name) (environment-value->string value)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the complete current environment or selected variable values.
; pre    : Each optional argument can be converted to an environment-variable
;          name in the current locale.
; post   : The current process environment is not modified. Missing selected
;          variables produce no output.
; result : (void); environment values are written to current-output-port.
; internals:
;          With no names, write-environment sorts and writes all variables;
;          otherwise each requested name is looked up directly.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-printenv . args)
  (define env (current-environment-variables))
  (if (null? args)
      (write-environment env)
      (for ([arg (in-list args)])
        (define name (string->bytes/locale (arg->string arg)))
        (define value (environment-variables-ref env name))
        (when value (displayln (environment-value->string value))))))

(define assignment-rx #px"^([^=]+)=(.*)$")

(define (value->environment-string value)
  (cond
    [(string? value) value]
    [(path? value) (path->string value)]
    [(symbol? value) (symbol->string value)]
    [(bytes? value) (bytes->string/locale value)]
    [else (~a value)]))

(define (split-environment-arguments args)
  (let loop ([rest args] [assignments '()])
    (cond
      [(null? rest)
       (values (reverse assignments) '())]
      [(environment-assignment? (car rest))
       (define assignment (car rest))
       (loop (cdr rest)
             (cons (cons (environment-assignment-name assignment)
                         (environment-assignment-value assignment))
                   assignments))]
      [else
       (define text (arg->string (car rest)))
       (define match (regexp-match assignment-rx text))
       (if match
           (loop (cdr rest)
                 (cons (cons (list-ref match 1)
                             (list-ref match 2))
                       assignments))
           (values (reverse assignments) rest))])))

(define (run-external-environment-command command)
  (define executable
    (find-executable-path (arg->string (car command))))
  (unless executable
    (raise-arguments-error 'env "command was not found on PATH"
                           "command" (car command)))
  (define ok?
    (apply system* executable (map arg->string (cdr command))))
  (unless ok?
    (raise-arguments-error 'env "command returned a non-zero exit status"
                           "command" (car command))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Apply temporary environment assignments and optionally execute a
;          command with that environment.
; pre    : Leading arguments are valid environment assignments; any remaining
;          command is either handled by current-coreutils-command-runner or
;          names an executable available on PATH.
; post   : The caller's current environment is unchanged after the procedure
;          returns. The copied environment is used only for output or command
;          execution.
; result : (void); without a command the modified environment is written; with
;          a command, that command is executed and non-zero external status is
;          reported as an error.
; internals:
;          Environment assignments are applied to a copy. parameterize scopes
;          that copy around command execution, first trying the coreutils
;          runner and then an external executable.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-env . args)
  (define-values (assignments command)
    (split-environment-arguments args))
  (define env
    (environment-variables-copy (current-environment-variables)))
  (for ([assignment (in-list assignments)])
    (environment-variables-set!
     env
     (string->bytes/locale (car assignment))
     (string->bytes/locale
      (value->environment-string (cdr assignment)))))
  (if (null? command)
      (write-environment env)
      (parameterize ([current-environment-variables env])
        (define runner (current-coreutils-command-runner))
        (define handled?
          (and runner (runner command)))
        (unless handled?
          (run-external-environment-command command)))))


(define (run-external-time-command command)
  (define executable
    (find-executable-path (arg->string (car command))))
  (unless executable
    (raise-arguments-error 'time "command was not found on PATH"
                           "command" (car command)))
  (define ok?
    (apply system* executable (map arg->string (cdr command))))
  (unless ok?
    (raise-arguments-error 'time "command returned a non-zero exit status"
                           "command" (car command))))

(define (write-time-result real-ms cpu-ms gc-ms)
  (define err (current-error-port))
  (fprintf err "real\t~as\n" (~r (/ real-ms 1000.0) #:precision '(= 3)))
  (fprintf err "cpu\t~as\n" (~r (/ cpu-ms 1000.0) #:precision '(= 3)))
  (fprintf err "gc\t~as\n" (~r (/ gc-ms 1000.0) #:precision '(= 3))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Execute one command and report its elapsed, CPU, and GC time.
; pre    : At least one command argument is supplied. The command is either a
;          registered rash-coreutils command or an executable available on PATH.
; post   : The command has completed or raised an error. Timing information is
;          written to current-error-port and command output remains untouched.
; result : (void) when the command succeeds; command lookup and execution errors
;          are propagated after timing information has been written.
; internals:
;          Monotonic elapsed time is combined with Racket process CPU time and
;          CPU time accumulated for completed subprocesses. GC time is the part
;          spent by the Racket runtime. This provides portable process timing
;          without pretending that separate user/system CPU values are available.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-time . command)
  (when (null? command)
    (raise-arguments-error 'time "expected a command" "arguments" command))

  (define start-real (current-inexact-monotonic-milliseconds))
  (define start-cpu (current-process-milliseconds))
  (define start-subprocess-cpu (current-process-milliseconds 'subprocesses))
  (define start-gc (current-gc-milliseconds))

  (define (write-result)
    (define real-ms
      (- (current-inexact-monotonic-milliseconds) start-real))
    (define cpu-ms
      (+ (- (current-process-milliseconds) start-cpu)
         (- (current-process-milliseconds 'subprocesses)
            start-subprocess-cpu)))
    (define gc-ms
      (- (current-gc-milliseconds) start-gc))
    (write-time-result real-ms cpu-ms gc-ms))

  (dynamic-wind
    void
    (λ ()
      (define runner (current-coreutils-command-runner))
      (define handled?
        (and runner (runner command)))
      (unless handled?
        (run-external-time-command command)))
    write-result)

  (void))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Write the current date and time in the requested representation.
; pre    : args contains only -u/--utc, -I/--iso/--iso-8601, --tz ZONE and/or
;          --format CLDR-PATTERN with values accepted by gregor.
; post   : No external state is changed.
; result : (void); one formatted current date/time line is written to
;          current-output-port.
; internals:
;          gregor creates the current moment in UTC, a requested timezone or
;          the local timezone; output is then ISO-8601, CLDR formatted or the
;          module's default display format.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (coreutils-date . args)
  (define utc? #f)
  (define iso? #f)
  (define timezone #f)
  (define pattern #f)
  (let loop ([rest args])
    (cond
      [(null? rest) (void)]
      [(member (arg->string (car rest)) '("-u" "--utc"))
       (set! utc? #t)
       (loop (cdr rest))]
      [(member (arg->string (car rest)) '("-I" "--iso" "--iso-8601"))
       (set! iso? #t)
       (loop (cdr rest))]
      [(string=? (arg->string (car rest)) "--tz")
       (unless (pair? (cdr rest))
         (raise-arguments-error 'date "missing time zone" "arguments" args))
       (set! timezone (arg->string (cadr rest)))
       (loop (cddr rest))]
      [(string=? (arg->string (car rest)) "--format")
       (unless (pair? (cdr rest))
         (raise-arguments-error 'date "missing CLDR format" "arguments" args))
       (set! pattern (arg->string (cadr rest)))
       (loop (cddr rest))]
      [else
       (raise-arguments-error 'date "unsupported argument" "argument" (car rest))]))
  (define m
    (cond
      [utc? (now/moment/utc)]
      [timezone (now/moment #:tz timezone)]
      [else (now/moment)]))
  (displayln
   (cond
     [pattern (~t m pattern)]
     [iso? (moment->iso8601 m)]
     [else (~t m "EEE MMM dd HH:mm:ss xxx yyyy")])))