Initial import

private/extended.rkt

@@ -0,0 +1,541 @@
+#lang racket/base
+
+(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)
+
+(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)))
+
+(define (read-lines-from-arguments args)
+  (if (null? args)
+      (port->lines (current-input-port))
+      (append-map
+       (λ (arg)
+         (call-with-input-file* (arg->path arg) port->lines))
+       args)))
+
+(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 (coreutils-head . args)
+  (define-values (n files) (parse-n-option 'head args 10))
+  (define lines (read-lines-from-arguments files))
+  (for ([line (in-list (take lines (min n (length lines))))])
+    (displayln line)))
+
+(define (coreutils-tail . args)
+  (define-values (n files) (parse-n-option 'tail args 10))
+  (define lines (read-lines-from-arguments files))
+  (define count (length lines))
+  (for ([line (in-list (drop lines (max 0 (- count n))))])
+    (displayln line)))
+
+(define (bytes-for-arguments args)
+  (if (null? args)
+      (port->bytes (current-input-port))
+      (apply bytes-append
+             (for/list ([arg (in-list args)])
+               (file->bytes (arg->path arg))))))
+
+(define (coreutils-wc . args)
+  (define lines? #f)
+  (define words? #f)
+  (define bytes? #f)
+  (define 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! files (append files (list arg)))]))
+  (when (not (or lines? words? bytes?))
+    (set! lines? #t)
+    (set! words? #t)
+    (set! bytes? #t))
+  (define bs (bytes-for-arguments files))
+  (define text (bytes->string/utf-8 bs #\?))
+  (define results
+    (filter (λ (x) x)
+            (list (if lines? (number->string (length (regexp-match* #rx"\n" text))) #f)
+                  (if words? (number->string (length (regexp-match* #px"\\S+" text))) #f)
+                  (if bytes? (number->string (bytes-length bs)) #f))))
+  (displayln (string-join results " ")))
+
+(define (coreutils-sort . args)
+  (define reverse? #f)
+  (define numeric? #f)
+  (define 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! files (append files (list arg)))]))
+  (define (less? a b)
+    (if numeric?
+        (< (or (string->number a) +inf.0)
+           (or (string->number b) +inf.0))
+        (string<? a b)))
+  (define sorted (sort (read-lines-from-arguments files) less?))
+  (for ([line (in-list (if reverse? (reverse sorted) sorted))])
+    (displayln line)))
+
+(define (run-lengths lines)
+  (let loop ([rest lines] [current #f] [count 0] [result '()])
+    (cond
+      [(null? rest)
+       (reverse (if current (cons (cons current count) result) result))]
+      [(and current (string=? current (car rest)))
+       (loop (cdr rest) current (add1 count) result)]
+      [else
+       (loop (cdr rest)
+             (car rest)
+             1
+             (if current (cons (cons current count) result) result))])))
+
+(define (coreutils-uniq . args)
+  (define count? #f)
+  (define 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! files (append files (list arg)))]))
+  (for ([entry (in-list (run-lengths (read-lines-from-arguments files)))])
+    (if count?
+        (printf "~a ~a\n" (~a (cdr entry) #:min-width 7 #:align 'right) (car entry))
+        (displayln (car entry)))))
+
+(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)
+
+(define (coreutils-cut . args)
+  (define delimiter "\t")
+  (define field #f)
+  (define 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! files (append files (list (car rest))))
+       (loop (cdr rest))]))
+  (unless field
+    (raise-arguments-error 'cut "expected -f FIELD" "arguments" args))
+  (for ([line (in-list (read-lines-from-arguments files))])
+    (define parts (string-split line delimiter #:trim? #f #:repeat? #f))
+    (when (<= field (length parts))
+      (displayln (list-ref parts (sub1 field))))))
+
+(define (coreutils-tee . args)
+  (define append? #f)
+  (define 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! files (append files (list (arg->path arg))))]))
+  (define outputs
+    (for/list ([path (in-list files)])
+      (open-output-file path #:exists (if append? 'append 'truncate/replace))))
+  (dynamic-wind
+    void
+    (λ ()
+      (let loop ()
+        (define bs (read-bytes 4096 (current-input-port)))
+        (unless (eof-object? bs)
+          (write-bytes bs (current-output-port))
+          (for ([out (in-list outputs)]) (write-bytes bs out))
+          (loop))))
+    (λ ()
+      (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
+         (for/list ([code (in-range start (add1 end))])
+           (integer->char code)))
+       (loop (cdddr rest) (append (reverse expanded) result))]
+      [else
+       (loop (cdr rest) (cons (car rest) result))])))
+
+(define (squeeze-characters text chars)
+  (define squeeze? (list->seteq chars))
+  (list->string
+   (let loop ([rest (string->list text)] [previous #f] [result '()])
+     (cond
+       [(null? rest) (reverse result)]
+       [else
+        (define ch (car rest))
+        (if (and previous
+                 (char=? ch previous)
+                 (set-member? squeeze? ch))
+            (loop (cdr rest) previous result)
+            (loop (cdr rest) ch (cons ch result)))]))))
+
+(define (translate-characters text from to)
+  (when (null? to)
+    (raise-arguments-error 'tr "SET2 must not be empty" "SET2" to))
+  (define last-to (last to))
+  (define mapping
+    (for/hash ([ch (in-list from)] [i (in-naturals)])
+      (values ch (if (< i (length to)) (list-ref to i) last-to))))
+  (list->string
+   (for/list ([ch (in-string text)])
+     (hash-ref mapping ch ch))))
+
+(define (delete-characters text chars)
+  (define delete-set (list->seteq chars))
+  (list->string
+   (for/list ([ch (in-string text)]
+              #:unless (set-member? delete-set ch))
+     ch)))
+
+(define (coreutils-tr . args)
+  (define delete? #f)
+  (define squeeze? #f)
+  (define 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! sets (append sets (list text)))]))
+  (define text (port->string (current-input-port)))
+  (cond
+    [(and delete? squeeze?)
+     (unless (= (length sets) 2)
+       (raise-arguments-error 'tr "expected SET1 SET2 with -ds" "arguments" args))
+     (define deleted
+       (delete-characters text (expand-character-set (first sets))))
+     (display
+      (squeeze-characters deleted (expand-character-set (second sets))))]
+    [delete?
+     (unless (= (length sets) 1)
+       (raise-arguments-error 'tr "expected one character set with -d" "arguments" args))
+     (display
+      (delete-characters text (expand-character-set (first sets))))]
+    [(and squeeze? (= (length sets) 1))
+     (display
+      (squeeze-characters text (expand-character-set (first sets))))]
+    [else
+     (unless (= (length sets) 2)
+       (raise-arguments-error 'tr "expected SET1 SET2" "arguments" args))
+     (define to (expand-character-set (second sets)))
+     (define translated
+       (translate-characters text
+                             (expand-character-set (first sets))
+                             to))
+     (display
+      (if squeeze?
+          (squeeze-characters translated to)
+          translated))]))
+
+(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) "")))
+
+(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)))])))
+
+(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))))
+
+(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))))
+
+(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)
+  (cond
+    [(file-exists? path) (file-size path)]
+    [(directory-exists? path)
+     (for/sum ([entry (in-list (directory-list path #:build? #t))])
+       (path-size entry))]
+    [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)]))
+
+(define (coreutils-du . args)
+  (define human? #f)
+  (define 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! paths (append paths (list (arg->path arg))))]))
+  (when (null? paths) (set! paths (list (current-directory))))
+  (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))))
+
+(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))))
+
+(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)))))
+
+(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))))
+
+(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 (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")])))