542 lines
19 KiB
Racket
542 lines
19 KiB
Racket
#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")])))
|