From 1d546c3d6f889ee5e79d8ad6cdbef234b842d8ba Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Mon, 17 Aug 2026 23:19:13 +0200 Subject: [PATCH] Initial import --- .gitignore | 4 + CHANGELOG | 22 ++ Makefile | 25 ++ README.md | 37 ++- help | 20 ++ info.rkt | 20 ++ main.rkt | 17 ++ private/aliases.rkt | 135 +++++++++ private/commands.rkt | 50 ++++ private/coreutils.rkt | 272 +++++++++++++++++++ private/dispatcher.rkt | 83 ++++++ private/env-support.rkt | 9 + private/extended.rkt | 541 +++++++++++++++++++++++++++++++++++++ private/help.rkt | 63 +++++ private/path-output.rkt | 17 ++ private/racket-tools.rkt | 75 +++++ scrbl/rash-coreutils.scrbl | 220 +++++++++++++++ tests/acceptance-tests.rkt | 3 + tests/coreutils.rkt | 166 ++++++++++++ tests/rash-smoke.rkt | 21 ++ 20 files changed, 1799 insertions(+), 1 deletion(-) create mode 100644 CHANGELOG create mode 100644 Makefile create mode 100644 help create mode 100644 info.rkt create mode 100644 main.rkt create mode 100644 private/aliases.rkt create mode 100644 private/commands.rkt create mode 100644 private/coreutils.rkt create mode 100644 private/dispatcher.rkt create mode 100644 private/env-support.rkt create mode 100644 private/extended.rkt create mode 100644 private/help.rkt create mode 100644 private/path-output.rkt create mode 100644 private/racket-tools.rkt create mode 100644 scrbl/rash-coreutils.scrbl create mode 100644 tests/acceptance-tests.rkt create mode 100644 tests/coreutils.rkt create mode 100644 tests/rash-smoke.rkt diff --git a/.gitignore b/.gitignore index 39a4f9c..6ed7735 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ # DrRacket autosave files *.rkt~ *.rkt.bak +*.bak \#*.rkt# \#*.rkt#*# @@ -15,3 +16,6 @@ compiled/ # Dependency tracking files *.dep +doc + + diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 0000000..b44e3a3 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,22 @@ +0.2.7 + +- Fix package setup regression in the Racket test suite after the raco command/procedure split. +- Test coreutils-raco as the Racket procedure; keep the raco Rash alias covered by the Rash smoke test. + +0.2.3 +- Export raco as a normal first-class Racket procedure instead of a pipeline alias. +- Keep raco usable directly in Rash line mode while avoiding syntax/value binding conflicts. +- Allow raco with no subcommand to invoke the underlying raco program. + +0.2.4 +- Restore raco as a Rash pipeline command; keep coreutils-raco as the ordinary Racket procedure. + +0.2.5 +- Make env recognize NAME=(Racket expression) before runtime argument dispatch. +- Preserve empty NAME= assignments without consuming the following command argument. +- Let env execute registered rash-coreutils commands before falling back to PATH. + +0.2.6 +- Add character-range expansion to tr, including a-z, A-Z and 0-9. +- Add tr -d and tr -s behavior. +- Print Rash-friendly forward-slash paths on Windows for path-producing commands. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..068369d --- /dev/null +++ b/Makefile @@ -0,0 +1,25 @@ +#lang rash + +(require racket-makefile/rash) + +(makefile rash-coreutils + + (target all + (displayln "Use make clean, make zip, etc.")) + + (target clean + (for-each (λ (f) (displayln f) (rm-f f)) + (list-files "." #px"([.]bak|~)$" #:recursive #t)) + (for-each (λ (d) (displayln d) (rm-rf d)) + (list-dirs "." #px"(compiled|doc|docs)$" #:recursive #t)) + (unless (directory-exists? "scrbl") + (make-directory "scrbl")) + (for-each (λ (f) (displayln f) (rm-f f)) + (list-files "scrbl" #px"[.](css|js|html)$"))) + + (target zip + (deps clean) + (zip-package)) + + ) + diff --git a/README.md b/README.md index 4611f48..302fedb 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,38 @@ # rash-coreutils -Commands like 'ls', 'mkdir', etc. for rash, but platform independent, i.e. working on windows and on unix flavors. \ No newline at end of file +Portable Unix-style core utilities for Rash, implemented in Racket. + +Version 0.2.7 includes text/pipeline tools (`head`, `tail`, `wc`, `sort`, `uniq`, +`cut`, `tee`, `tr`), path and filesystem helpers (`basename`, `dirname`, +`realpath`, `readlink`, `stat`, `du`, `df`, `mktemp`), environment commands +(`printenv`, `env`), and `date` backed by Gregor. + +Rash remains responsible for shell syntax such as globbing, pipelines and +redirection. `rash-coreutils` additionally accepts Racket regular expressions as +path selectors. + + +## Racket tooling + +`rash-coreutils` also exposes the `raco` command from the active Racket installation, without requiring `raco` to be on PATH. + +```text +raco setup rash-coreutils +raco pkg show +``` + +In Racket expression mode, use `coreutils-raco`, for example `(coreutils-raco '(setup rash-coreutils))`. The name `raco` is reserved for the Rash command binding. + +## Windows paths + +Commands that print paths use forward slashes on Windows. This keeps their textual output directly reusable in Rash line mode, where a backslash is an escape character. Internally, Racket path values remain native paths. + +```text +pwd +C:/devel/racket/rash-coreutils/ + +mktemp +C:/Users/hans/AppData/Local/Temp/tmp123 +``` + +A native Racket path value can still be passed directly, for example `ls (values (find-system-path 'temp-dir))`. diff --git a/help b/help new file mode 100644 index 0000000..b02f5c9 --- /dev/null +++ b/help @@ -0,0 +1,20 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.1.6") +(define license 'MIT) +(define collection "rash-coreutils") +(define pkg-desc + "Platform-independent Unix-style core utilities for Rash, implemented in Racket.") + +(define scribblings + '(("scrbl/rash-coreutils.scrbl" () (library 0)))) + +(define deps + '("base" "rash")) + +(define build-deps + '("racket-doc" + "rackunit-lib" + "scribble-lib" + "rash")) diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..57be550 --- /dev/null +++ b/info.rkt @@ -0,0 +1,20 @@ +#lang info + +(define pkg-authors '(hnmdijkema)) +(define version "0.2.7") +(define license 'MIT) +(define collection "rash-coreutils") +(define pkg-desc + "Platform-independent Unix-style core utilities for Rash, implemented in Racket.") + +(define scribblings + '(("scrbl/rash-coreutils.scrbl" () (library 0)))) + +(define deps + '("base" "rash" "gregor-lib")) + +(define build-deps + '("racket-doc" + "rackunit-lib" + "scribble-lib" + "rash")) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..62c1ecd --- /dev/null +++ b/main.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +(require "private/coreutils.rkt" + "private/extended.rkt" + "private/commands.rkt" + "private/racket-tools.rkt" + "private/dispatcher.rkt" + "private/help.rkt" + "private/aliases.rkt") + +(provide (all-from-out "private/coreutils.rkt") + (all-from-out "private/extended.rkt") + (all-from-out "private/commands.rkt") + (all-from-out "private/racket-tools.rkt") + (all-from-out "private/dispatcher.rkt") + (all-from-out "private/help.rkt") + (all-from-out "private/aliases.rkt")) diff --git a/private/aliases.rkt b/private/aliases.rkt new file mode 100644 index 0000000..cbc5cd6 --- /dev/null +++ b/private/aliases.rkt @@ -0,0 +1,135 @@ +#lang racket/base + +(require rash + "dispatcher.rkt" + "env-support.rkt" + "help.rkt" + "racket-tools.rkt" + (for-syntax racket/base)) + +(provide pwd ls mkdir rmdir rm cp mv cat touch echo which + head tail wc sort uniq cut tee tr basename dirname realpath readlink + stat du df mktemp printenv env date help raco) + +(define (make-command-procedure name) + (λ args + (apply dispatch-coreutils-command name args))) + +(define pwd-command (make-command-procedure 'pwd)) +(define ls-command (make-command-procedure 'ls)) +(define mkdir-command (make-command-procedure 'mkdir)) +(define rmdir-command (make-command-procedure 'rmdir)) +(define rm-command (make-command-procedure 'rm)) +(define cp-command (make-command-procedure 'cp)) +(define mv-command (make-command-procedure 'mv)) +(define cat-command (make-command-procedure 'cat)) +(define touch-command (make-command-procedure 'touch)) +(define echo-command (make-command-procedure 'echo)) +(define which-command (make-command-procedure 'which)) +(define head-command (make-command-procedure 'head)) +(define tail-command (make-command-procedure 'tail)) +(define wc-command (make-command-procedure 'wc)) +(define sort-command (make-command-procedure 'sort)) +(define uniq-command (make-command-procedure 'uniq)) +(define cut-command (make-command-procedure 'cut)) +(define tee-command (make-command-procedure 'tee)) +(define tr-command (make-command-procedure 'tr)) +(define basename-command (make-command-procedure 'basename)) +(define dirname-command (make-command-procedure 'dirname)) +(define realpath-command (make-command-procedure 'realpath)) +(define readlink-command (make-command-procedure 'readlink)) +(define stat-command (make-command-procedure 'stat)) +(define du-command (make-command-procedure 'du)) +(define df-command (make-command-procedure 'df)) +(define mktemp-command (make-command-procedure 'mktemp)) +(define printenv-command (make-command-procedure 'printenv)) +(define env-command (make-command-procedure 'env)) +(define date-command (make-command-procedure 'date)) +(define raco-command coreutils-raco) + +(define (help-command . args) + (apply coreutils-help args)) + +(begin-for-syntax + (define (assignment-prefix-name stx) + (define datum (syntax-e stx)) + (define text + (cond + [(symbol? datum) (symbol->string datum)] + [(string? datum) datum] + [else #f])) + (and text + (regexp-match? #px"^[^=]+=$" text) + (substring text 0 (sub1 (string-length text))))) + + (define (racket-expression? stx) + (pair? (syntax-e stx))) + + (define (prepare-env-arguments arguments) + (let loop ([rest arguments] [result '()]) + (cond + [(null? rest) + (reverse result)] + [(and (pair? (cdr rest)) + (assignment-prefix-name (car rest)) + (racket-expression? (cadr rest))) + (define name (assignment-prefix-name (car rest))) + (define expression (cadr rest)) + (loop (cddr rest) + (cons #`(environment-assignment #,name #,expression) + result))] + [else + (loop (cdr rest) + (cons (car rest) result))]))) + + (define (make-env-alias procedure-id) + (λ (stx) + (syntax-case stx () + [(_ argument ...) + (let ([prepared + (prepare-env-arguments + (syntax->list #'(argument ...)))]) + (with-syntax ([(prepared-argument ...) prepared] + [command-procedure procedure-id]) + #'(=unix-pipe= (values command-procedure) + prepared-argument ...)))]))) + + (define (make-coreutils-alias procedure-id) + (λ (stx) + (syntax-case stx () + [(_ argument ...) + (with-syntax ([command-procedure procedure-id]) + #'(=unix-pipe= (values command-procedure) argument ...))])))) + +(define-pipeline-alias pwd (make-coreutils-alias #'pwd-command)) +(define-pipeline-alias ls (make-coreutils-alias #'ls-command)) +(define-pipeline-alias mkdir (make-coreutils-alias #'mkdir-command)) +(define-pipeline-alias rmdir (make-coreutils-alias #'rmdir-command)) +(define-pipeline-alias rm (make-coreutils-alias #'rm-command)) +(define-pipeline-alias cp (make-coreutils-alias #'cp-command)) +(define-pipeline-alias mv (make-coreutils-alias #'mv-command)) +(define-pipeline-alias cat (make-coreutils-alias #'cat-command)) +(define-pipeline-alias touch (make-coreutils-alias #'touch-command)) +(define-pipeline-alias echo (make-coreutils-alias #'echo-command)) +(define-pipeline-alias which (make-coreutils-alias #'which-command)) +(define-pipeline-alias head (make-coreutils-alias #'head-command)) +(define-pipeline-alias tail (make-coreutils-alias #'tail-command)) +(define-pipeline-alias wc (make-coreutils-alias #'wc-command)) +(define-pipeline-alias sort (make-coreutils-alias #'sort-command)) +(define-pipeline-alias uniq (make-coreutils-alias #'uniq-command)) +(define-pipeline-alias cut (make-coreutils-alias #'cut-command)) +(define-pipeline-alias tee (make-coreutils-alias #'tee-command)) +(define-pipeline-alias tr (make-coreutils-alias #'tr-command)) +(define-pipeline-alias basename (make-coreutils-alias #'basename-command)) +(define-pipeline-alias dirname (make-coreutils-alias #'dirname-command)) +(define-pipeline-alias realpath (make-coreutils-alias #'realpath-command)) +(define-pipeline-alias readlink (make-coreutils-alias #'readlink-command)) +(define-pipeline-alias stat (make-coreutils-alias #'stat-command)) +(define-pipeline-alias du (make-coreutils-alias #'du-command)) +(define-pipeline-alias df (make-coreutils-alias #'df-command)) +(define-pipeline-alias mktemp (make-coreutils-alias #'mktemp-command)) +(define-pipeline-alias printenv (make-coreutils-alias #'printenv-command)) +(define-pipeline-alias env (make-env-alias #'env-command)) +(define-pipeline-alias date (make-coreutils-alias #'date-command)) +(define-pipeline-alias help (make-coreutils-alias #'help-command)) +(define-pipeline-alias raco (make-coreutils-alias #'raco-command)) diff --git a/private/commands.rkt b/private/commands.rkt new file mode 100644 index 0000000..b1775ea --- /dev/null +++ b/private/commands.rkt @@ -0,0 +1,50 @@ +#lang racket/base + +(require "coreutils.rkt" + "extended.rkt" + "racket-tools.rkt") + +(provide (struct-out coreutils-command) + coreutils-commands + find-coreutils-command) + +(struct coreutils-command (name procedure documentation-term) #:transparent) + +(define coreutils-commands + (list + (coreutils-command 'pwd coreutils-pwd 'rash-coreutils-pwd) + (coreutils-command 'ls coreutils-ls 'rash-coreutils-ls) + (coreutils-command 'mkdir coreutils-mkdir 'rash-coreutils-mkdir) + (coreutils-command 'rmdir coreutils-rmdir 'rash-coreutils-rmdir) + (coreutils-command 'rm coreutils-rm 'rash-coreutils-rm) + (coreutils-command 'cp coreutils-cp 'rash-coreutils-cp) + (coreutils-command 'mv coreutils-mv 'rash-coreutils-mv) + (coreutils-command 'cat coreutils-cat 'rash-coreutils-cat) + (coreutils-command 'touch coreutils-touch 'rash-coreutils-touch) + (coreutils-command 'echo coreutils-echo 'rash-coreutils-echo) + (coreutils-command 'which coreutils-which 'rash-coreutils-which) + (coreutils-command 'head coreutils-head 'rash-coreutils-head) + (coreutils-command 'tail coreutils-tail 'rash-coreutils-tail) + (coreutils-command 'wc coreutils-wc 'rash-coreutils-wc) + (coreutils-command 'sort coreutils-sort 'rash-coreutils-sort) + (coreutils-command 'uniq coreutils-uniq 'rash-coreutils-uniq) + (coreutils-command 'cut coreutils-cut 'rash-coreutils-cut) + (coreutils-command 'tee coreutils-tee 'rash-coreutils-tee) + (coreutils-command 'tr coreutils-tr 'rash-coreutils-tr) + (coreutils-command 'basename coreutils-basename 'rash-coreutils-basename) + (coreutils-command 'dirname coreutils-dirname 'rash-coreutils-dirname) + (coreutils-command 'realpath coreutils-realpath 'rash-coreutils-realpath) + (coreutils-command 'readlink coreutils-readlink 'rash-coreutils-readlink) + (coreutils-command 'stat coreutils-stat 'rash-coreutils-stat) + (coreutils-command 'du coreutils-du 'rash-coreutils-du) + (coreutils-command 'df coreutils-df 'rash-coreutils-df) + (coreutils-command 'mktemp coreutils-mktemp 'rash-coreutils-mktemp) + (coreutils-command 'printenv coreutils-printenv 'rash-coreutils-printenv) + (coreutils-command 'env coreutils-env 'rash-coreutils-env) + (coreutils-command 'date coreutils-date 'rash-coreutils-date) + (coreutils-command 'raco coreutils-raco 'rash-coreutils-raco))) + +(define (find-coreutils-command name) + (for/first ([command (in-list coreutils-commands)] + #:when (eq? name (coreutils-command-name command))) + command)) diff --git a/private/coreutils.rkt b/private/coreutils.rkt new file mode 100644 index 0000000..d35de8b --- /dev/null +++ b/private/coreutils.rkt @@ -0,0 +1,272 @@ +#lang racket/base + +(require racket/file + racket/format + racket/list + racket/path + racket/port + racket/string + racket/system + "path-output.rkt") + +(provide coreutils-pwd + coreutils-ls + coreutils-mkdir + coreutils-rmdir + coreutils-rm + coreutils-cp + coreutils-mv + coreutils-cat + coreutils-touch + coreutils-echo + coreutils-which) + +(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 (option? arg option) + (string=? (arg->string arg) option)) + +(define (hidden-name? path) + (define name (path->string (file-name-from-path path))) + (and (positive? (string-length name)) + (char=? (string-ref name 0) #\.))) + +(define (path-display-name path) + (path->string (file-name-from-path path))) + +(define (directory-entry-type path) + (cond + [(directory-exists? path) "d"] + [(link-exists? path) "l"] + [else "-"])) + +(define (directory-entry-size path) + (if (file-exists? path) + (file-size path) + 0)) + +(define (write-ls-entry path long?) + (if long? + (printf "~a ~a ~a\n" + (directory-entry-type path) + (~a (directory-entry-size path) + #:min-width 10 + #:align 'right) + (path-display-name path)) + (printf "~a\n" (path-display-name path)))) + +(define (write-directory-listing directory all? long?) + (define entries + (sort (directory-list directory #:build? #t) + stringrash-string (current-directory)))) + +(define (coreutils-ls . args) + (define all? #f) + (define long? #f) + (define paths '()) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (cond + [(or (string=? text "-a") (string=? text "--all")) + (set! all? #t)] + [(or (string=? text "-l") (string=? text "--long")) + (set! long? #t)] + [(or (string=? text "-la") (string=? text "-al")) + (set! all? #t) + (set! long? #t)] + [(string-prefix? text "-") + (raise-arguments-error 'ls "unsupported option" "option" text)] + [else + (set! paths (append paths (list (arg->path arg))))])) + (when (null? paths) + (set! paths (list (current-directory)))) + (define file-paths + (filter + (λ (path) + (or (file-exists? path) (link-exists? path))) + paths)) + (define directory-paths + (filter directory-exists? paths)) + (for ([path (in-list paths)]) + (unless (or (file-exists? path) + (link-exists? path) + (directory-exists? path)) + (raise-arguments-error 'ls "path does not exist" "path" path))) + (for ([path (in-list file-paths)]) + (write-ls-entry path long?)) + (for ([path (in-list directory-paths)] + [index (in-naturals)]) + (when (or (pair? file-paths) (> index 0)) + (newline)) + (when (> (length paths) 1) + (printf "~a:\n" (path->rash-string path))) + (write-directory-listing path all? long?))) + +(define (coreutils-mkdir . args) + (define parents? #f) + (define paths '()) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (cond + [(or (string=? text "-p") (string=? text "--parents")) + (set! parents? #t)] + [(string-prefix? text "-") + (raise-arguments-error 'mkdir "unsupported option" "option" text)] + [else + (set! paths (append paths (list (arg->path arg))))])) + (when (null? paths) + (raise-arguments-error 'mkdir "expected at least one directory" "arguments" args)) + (for ([path (in-list paths)]) + (if parents? + (make-directory* path) + (make-directory path)))) + +(define (coreutils-rmdir . args) + (when (null? args) + (raise-arguments-error 'rmdir "expected at least one directory" "arguments" args)) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (when (string-prefix? text "-") + (raise-arguments-error 'rmdir "unsupported option" "option" text)) + (delete-directory (arg->path arg)))) + +(define (delete-path path recursive? force?) + (cond + [(directory-exists? path) + (if recursive? + (delete-directory/files path) + (raise-arguments-error 'rm + "cannot remove a directory without -r" + "path" path))] + [(or (file-exists? path) (link-exists? path)) + (delete-file path)] + [force? (void)] + [else + (raise-arguments-error 'rm "path does not exist" "path" path)])) + +(define (coreutils-rm . args) + (define recursive? #f) + (define force? #f) + (define paths '()) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (cond + [(or (string=? text "-r") + (string=? text "-R") + (string=? text "--recursive")) + (set! recursive? #t)] + [(or (string=? text "-f") (string=? text "--force")) + (set! force? #t)] + [(or (string=? text "-rf") + (string=? text "-fr") + (string=? text "-Rf") + (string=? text "-fR")) + (set! recursive? #t) + (set! force? #t)] + [(string-prefix? text "-") + (raise-arguments-error 'rm "unsupported option" "option" text)] + [else + (set! paths (append paths (list (arg->path arg))))])) + (when (null? paths) + (raise-arguments-error 'rm "expected at least one path" "arguments" args)) + (for ([path (in-list paths)]) + (delete-path path recursive? force?))) + +(define (copy-directory source destination) + (copy-directory/files source destination)) + +(define (coreutils-cp . args) + (define recursive? #f) + (define paths '()) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (cond + [(or (string=? text "-r") + (string=? text "-R") + (string=? text "--recursive")) + (set! recursive? #t)] + [(string-prefix? text "-") + (raise-arguments-error 'cp "unsupported option" "option" text)] + [else + (set! paths (append paths (list (arg->path arg))))])) + (unless (= (length paths) 2) + (raise-arguments-error 'cp + "this version expects exactly source and destination" + "arguments" args)) + (define source (first paths)) + (define destination (second paths)) + (cond + [(directory-exists? source) + (unless recursive? + (raise-arguments-error 'cp + "source is a directory; use -r" + "source" source)) + (copy-directory source destination)] + [(file-exists? source) + (copy-file source destination)] + [else + (raise-arguments-error 'cp "source does not exist" "source" source)])) + +(define (coreutils-mv . args) + (unless (= (length args) 2) + (raise-arguments-error 'mv + "expected source and destination" + "arguments" args)) + (define source (arg->path (first args))) + (define destination (arg->path (second args))) + (rename-file-or-directory source destination)) + +(define (coreutils-cat . args) + (when (null? args) + (copy-port (current-input-port) (current-output-port))) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (when (string-prefix? text "-") + (raise-arguments-error 'cat "unsupported option" "option" text)) + (call-with-input-file* (arg->path arg) + (λ (in) + (copy-port in (current-output-port)))))) + +(define (coreutils-touch . args) + (when (null? args) + (raise-arguments-error 'touch "expected at least one file" "arguments" args)) + (for ([arg (in-list args)]) + (define text (arg->string arg)) + (when (string-prefix? text "-") + (raise-arguments-error 'touch "unsupported option" "option" text)) + (define path (arg->path arg)) + (if (file-exists? path) + (file-or-directory-modify-seconds path (current-seconds)) + (call-with-output-file* path + (λ (out) (void)))))) + +(define (coreutils-echo . args) + (displayln (string-join (map arg->string args) " "))) + +(define (coreutils-which . args) + (when (null? args) + (raise-arguments-error 'which "expected at least one command" "arguments" args)) + (for ([arg (in-list args)]) + (define executable (find-executable-path (arg->string arg))) + (if executable + (displayln (path->rash-string executable)) + (raise-arguments-error 'which + "command was not found on PATH" + "command" (arg->string arg))))) diff --git a/private/dispatcher.rkt b/private/dispatcher.rkt new file mode 100644 index 0000000..e7e3da5 --- /dev/null +++ b/private/dispatcher.rkt @@ -0,0 +1,83 @@ +#lang racket/base + +(require racket/list + racket/path + "commands.rkt" + "env-support.rkt" + "help.rkt") + +(provide dispatch-coreutils-command + expand-coreutils-arguments) + +(define (regexp-paths pattern) + (define entries + (directory-list (current-directory) #:build? #t)) + (define matching-entries + (filter + (λ (entry) + (define name (file-name-from-path entry)) + (and name + (regexp-match? pattern (path->string name)))) + entries)) + (sort matching-entries + stringstring (file-name-from-path entry))))) + +(define (expand-coreutils-argument arg) + (cond + [(list? arg) + (append-map expand-coreutils-argument arg)] + [(regexp? arg) + (define matches (regexp-paths arg)) + (when (null? matches) + (raise-arguments-error + 'dispatch-coreutils-command + "regular expression matched no paths" + "pattern" arg)) + matches] + [else + (list arg)])) + +(define (expand-coreutils-arguments args) + (append-map expand-coreutils-argument args)) + +(define (help-option? arg) + (or (equal? arg '--help) + (equal? arg "--help"))) + +(define (argument->command-name arg) + (cond + [(symbol? arg) arg] + [(string? arg) (string->symbol arg)] + [(path? arg) (string->symbol (path->string arg))] + [else #f])) + +(define (run-coreutils-command-if-known command) + (define command-name + (and (pair? command) + (argument->command-name (car command)))) + (define known-command + (and command-name + (find-coreutils-command command-name))) + (if known-command + (begin + (apply dispatch-coreutils-command command-name (cdr command)) + #t) + #f)) + +(define (dispatch-coreutils-command command-name . args) + (unless (symbol? command-name) + (raise-argument-error 'dispatch-coreutils-command "symbol?" command-name)) + (define command (find-coreutils-command command-name)) + (unless command + (raise-arguments-error 'dispatch-coreutils-command + "unknown coreutils command" + "command" command-name)) + (if (ormap help-option? args) + (coreutils-help command-name) + (parameterize ([current-coreutils-command-runner + run-coreutils-command-if-known]) + (apply (coreutils-command-procedure command) + (expand-coreutils-arguments args))))) diff --git a/private/env-support.rkt b/private/env-support.rkt new file mode 100644 index 0000000..f046f77 --- /dev/null +++ b/private/env-support.rkt @@ -0,0 +1,9 @@ +#lang racket/base + +(provide (struct-out environment-assignment) + current-coreutils-command-runner) + +(struct environment-assignment (name value) #:transparent) + +(define current-coreutils-command-runner + (make-parameter #f)) diff --git a/private/extended.rkt b/private/extended.rkt new file mode 100644 index 0000000..e57a274 --- /dev/null +++ b/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)) + (stringstring 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) + stringstring)) + (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")]))) diff --git a/private/help.rkt b/private/help.rkt new file mode 100644 index 0000000..b4c07d5 --- /dev/null +++ b/private/help.rkt @@ -0,0 +1,63 @@ +#lang racket/base + +(require racket/format + racket/system + "commands.rkt" + "racket-tools.rkt") + +(provide coreutils-help + coreutils-help-search-term + raco-executable) + +(define (arg->string arg) + (cond + [(string? arg) arg] + [(symbol? arg) (symbol->string arg)] + [else (~a arg)])) + +(define (arg->symbol arg) + (cond + [(symbol? arg) arg] + [(string? arg) (string->symbol arg)] + [else #f])) + +(define (coreutils-help-search-term value) + (define name (arg->symbol value)) + (define command (and name (find-coreutils-command name))) + (if command + (symbol->string (coreutils-command-documentation-term command)) + (arg->string value))) + +(define (raco-executable) + (find-raco-executable)) + +(define (open-racket-documentation search-term) + (define ok? + (system* (raco-executable) + "docs" + "--" + search-term)) + (unless ok? + (raise-arguments-error 'help + "raco docs failed" + "search term" search-term))) + +(define (write-command-list) + (displayln "rash-coreutils commands:") + (for ([command (in-list coreutils-commands)]) + (printf " ~a\n" (coreutils-command-name command))) + (newline) + (displayln "Use: help or --help") + (displayln "Other terms are passed to Racket's documentation search.")) + +(define (coreutils-help . args) + (cond + [(null? args) + (write-command-list)] + [(= (length args) 1) + (open-racket-documentation + (coreutils-help-search-term (car args)))] + [else + (raise-arguments-error 'help + "expected zero or one search term" + "arguments" args)])) diff --git a/private/path-output.rkt b/private/path-output.rkt new file mode 100644 index 0000000..868e04e --- /dev/null +++ b/private/path-output.rkt @@ -0,0 +1,17 @@ +#lang racket/base + +(require racket/format + racket/path + racket/string) + +(provide path->rash-string) + +(define (path->rash-string path) + (define text + (cond + [(path? path) (path->string path)] + [(string? path) path] + [else (path->string (string->path (~a path)))])) + (if (eq? (system-type 'os) 'windows) + (string-replace text "\\" "/") + text)) diff --git a/private/racket-tools.rkt b/private/racket-tools.rkt new file mode 100644 index 0000000..6c513d7 --- /dev/null +++ b/private/racket-tools.rkt @@ -0,0 +1,75 @@ +#lang racket/base + +(require racket/format + racket/list + racket/path + racket/string + racket/system + setup/dirs) + +(provide coreutils-raco + find-raco-executable) + +(define (raco-executable-name) + (if (eq? (system-type 'os) 'windows) + "raco.exe" + "raco")) + +(define (existing-raco-in directory) + (and directory + (let ([path (build-path directory (raco-executable-name))]) + (and (file-exists? path) path)))) + +(define (find-raco-executable) + ;; Prefer the console executable directory of the current Racket + ;; installation. This avoids accidentally using raco from another Racket + ;; installation on PATH. + (define console-bin + (with-handlers ([exn:fail? (λ (_) #f)]) + (find-console-bin-dir))) + (define from-console-bin + (existing-raco-in console-bin)) + + ;; Portable and non-standard installations commonly put raco next to the + ;; currently running Racket executable. + (define exec-file + (with-handlers ([exn:fail? (λ (_) #f)]) + (find-system-path 'exec-file))) + (define from-exec-dir + (and exec-file + (existing-raco-in (path-only exec-file)))) + + ;; PATH is deliberately last because it may point to another installation. + (or from-console-bin + from-exec-dir + (find-executable-path (raco-executable-name)) + (error 'raco "cannot find raco for the current Racket installation"))) + +(define (command-item->strings value) + (cond + [(symbol? value) (list (symbol->string value))] + [(path? value) (list (path->string value))] + [(string? value) (list value)] + [(number? value) (list (~a value))] + [(list? value) (append-map command-item->strings value)] + [else + (raise-argument-error + 'raco + "command item (string, symbol, path, number, or list)" + value)])) + +(define (coreutils-raco . command) + (define arguments + (append-map command-item->strings command)) + (define executable (find-raco-executable)) + (printf "> ~a ~a\n" + (path->string executable) + (string-join arguments " ")) + + (unless (apply system* executable arguments) + (error 'raco + "command failed~a" + (if (null? arguments) + "" + (format ": ~a" (car arguments))))) + (void)) diff --git a/scrbl/rash-coreutils.scrbl b/scrbl/rash-coreutils.scrbl new file mode 100644 index 0000000..920fedc --- /dev/null +++ b/scrbl/rash-coreutils.scrbl @@ -0,0 +1,220 @@ +#lang scribble/manual + +@(require (for-label racket/base + (only-in rash-coreutils + coreutils-pwd coreutils-ls coreutils-mkdir coreutils-rmdir + coreutils-rm coreutils-cp coreutils-mv coreutils-cat + coreutils-touch coreutils-echo coreutils-which 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 + raco + coreutils-raco))) + +@title{rash-coreutils} +@author["Hans Dijkema / hans@dijkewijk.nl"] + +@defmodule[rash-coreutils] + +@bold{rash-coreutils} provides platform-independent Unix-style shell commands +for Rash. The commands are implemented in Racket, so common shell utilities do +not depend on @tt{cmd.exe}, PowerShell, or Unix executables being installed. + +Rash remains responsible for shell syntax such as pipelines, globbing, tilde +expansion, variable expansion, and redirection. @bold{rash-coreutils} supplies +the commands themselves plus Racket-specific additions such as regular-expression +path selectors. + +@section{Commands} + +The package provides @tt{pwd}, @tt{ls}, @tt{mkdir}, @tt{rmdir}, @tt{rm}, +@tt{cp}, @tt{mv}, @tt{cat}, @tt{touch}, @tt{echo}, @tt{which}, @tt{head}, +@tt{tail}, @tt{wc}, @tt{sort}, @tt{uniq}, @tt{cut}, @tt{tee}, @tt{tr}, +@tt{basename}, @tt{dirname}, @tt{realpath}, @tt{readlink}, @tt{stat}, @tt{du}, +@tt{df}, @tt{mktemp}, @tt{printenv}, @tt{env}, @tt{date}, @tt{raco}, and @tt{help}. + +The option set is deliberately smaller than GNU coreutils. Unsupported options +raise an error instead of silently approximating another command's behavior. + +@section{Racket procedures} + +Each shell command has an explicitly named Racket procedure. All procedures +write to the normal current ports so Rash pipeline and redirection semantics +continue to work. + +@index["rash-coreutils-pwd"] +@defproc[(coreutils-pwd) void?]{Writes the current directory.} + +@index["rash-coreutils-ls"] +@defproc[(coreutils-ls [arg any/c] ...) void?]{Lists paths. Supports @tt{-a}, @tt{-l}, and their long forms.} + +@index["rash-coreutils-mkdir"] +@defproc[(coreutils-mkdir [arg any/c] ...) void?]{Creates directories. Supports @tt{-p}.} + +@index["rash-coreutils-rmdir"] +@defproc[(coreutils-rmdir [arg any/c] ...) void?]{Removes empty directories.} + +@index["rash-coreutils-rm"] +@defproc[(coreutils-rm [arg any/c] ...) void?]{Removes paths. Supports recursive and force options.} + +@index["rash-coreutils-cp"] +@defproc[(coreutils-cp [arg any/c] ...) void?]{Copies a source to a destination. Directory copies require @tt{-r}.} + +@index["rash-coreutils-mv"] +@defproc[(coreutils-mv [source any/c] [destination any/c]) void?]{Moves or renames a path.} + +@index["rash-coreutils-cat"] +@defproc[(coreutils-cat [arg any/c] ...) void?]{Copies files, or standard input, to standard output.} + +@index["rash-coreutils-touch"] +@defproc[(coreutils-touch [arg any/c] ...) void?]{Updates modification times or creates empty files.} + +@index["rash-coreutils-echo"] +@defproc[(coreutils-echo [arg any/c] ...) void?]{Writes arguments separated by spaces.} + +@index["rash-coreutils-which"] +@defproc[(coreutils-which [arg any/c] ...) void?]{Finds executables using Racket's executable search.} + +@index["rash-coreutils-head"] +@defproc[(coreutils-head [arg any/c] ...) void?]{Writes the first lines of input. Supports @tt{-n}.} + +@index["rash-coreutils-tail"] +@defproc[(coreutils-tail [arg any/c] ...) void?]{Writes the last lines of input. Supports @tt{-n}.} + +@index["rash-coreutils-wc"] +@defproc[(coreutils-wc [arg any/c] ...) void?]{Counts lines, words, and bytes. Supports @tt{-l}, @tt{-w}, and @tt{-c}.} + +@index["rash-coreutils-sort"] +@defproc[(coreutils-sort [arg any/c] ...) void?]{Sorts lines. Supports @tt{-r} and @tt{-n}.} + +@index["rash-coreutils-uniq"] +@defproc[(coreutils-uniq [arg any/c] ...) void?]{Collapses adjacent duplicate lines. Supports @tt{-c}.} + +@index["rash-coreutils-cut"] +@defproc[(coreutils-cut [arg any/c] ...) void?]{Selects one delimited field with @tt{-d} and @tt{-f}.} + +@index["rash-coreutils-tee"] +@defproc[(coreutils-tee [arg any/c] ...) void?]{Copies standard input to standard output and files. Supports @tt{-a}.} + +@index["rash-coreutils-tr"] +@defproc[(coreutils-tr [arg any/c] ...) void?]{Translates characters from standard input. Character ranges such as @tt{a-z}, @tt{A-Z}, and @tt{0-9} are expanded. @tt{-d} deletes characters and @tt{-s} squeezes repeated characters.} + +@index["rash-coreutils-basename"] +@defproc[(coreutils-basename [path any/c]) void?]{Writes the final path component.} + +@index["rash-coreutils-dirname"] +@defproc[(coreutils-dirname [path any/c]) void?]{Writes the directory portion of a path.} + +@index["rash-coreutils-realpath"] +@defproc[(coreutils-realpath [path any/c]) void?]{Writes a complete simplified path.} + +@index["rash-coreutils-readlink"] +@defproc[(coreutils-readlink [path any/c]) void?]{Resolves a symbolic link.} + +@index["rash-coreutils-stat"] +@defproc[(coreutils-stat [path any/c] ...) void?]{Writes basic portable path metadata.} + +@index["rash-coreutils-du"] +@defproc[(coreutils-du [arg any/c] ...) void?]{Calculates recursive file size. Supports @tt{-h}.} + +@index["rash-coreutils-df"] +@defproc[(coreutils-df) void?]{Lists filesystem roots. Racket has no portable API for total and free filesystem capacity, so this initial implementation deliberately does not invent platform-specific subprocess fallbacks.} + +@index["rash-coreutils-mktemp"] +@defproc[(coreutils-mktemp [arg any/c] ...) void?]{Creates a temporary file, or a directory with @tt{-d}, and writes its path.} + +@index["rash-coreutils-printenv"] +@defproc[(coreutils-printenv [name any/c] ...) void?]{Writes environment variables.} + +@index["rash-coreutils-env"] +@defproc[(coreutils-env [arg any/c] ...) void?]{Creates a copied environment, applies leading @tt{NAME=value} assignments, and either writes that environment or runs the remaining command in it. Racket values are converted to environment strings.} + +The Rash form can mix shell-style assignment names with Racket expressions: + +@verbatim{ +(define x 42) +env ANSWER=(values x) printenv ANSWER +} + +A parenthesized expression in Rash line mode is ordinary Racket code. Therefore +the value after an empty @tt{NAME=} token can be a number, symbol, path, string, +or another printable Racket value. + +@index["rash-coreutils-date"] +@defproc[(coreutils-date [arg any/c] ...) void?]{Writes the current date and time using Gregor. Supports @tt{-u}/@tt{--utc}, @tt{-I}/@tt{--iso}, @tt{--tz ZONE}, and @tt{--format CLDR-PATTERN}. The format pattern follows Gregor's CLDR syntax rather than pretending to implement every GNU @tt{date} format escape.} + +@verbatim{ +date +date --iso +date --utc --iso +date --tz Europe/Amsterdam --format "yyyy-MM-dd HH:mm:ss" +} + +@index["rash-coreutils-raco"] +@defproc[(raco [arg any/c] ...) void?]{Runs @tt{raco} from the current Racket installation. The executable is resolved from the active Racket installation before PATH is considered, so it also works on Windows when @tt{raco.exe} is not on PATH. Arguments may be strings, symbols, paths, numbers, or nested lists. With no arguments, the underlying @tt{raco} program is invoked without a subcommand.} + +@defproc[(coreutils-raco [arg any/c] ...) void?]{Explicit implementation name for @racket[raco].} + +@verbatim{ +raco setup rash-coreutils +raco pkg show +} + +The same @racket[raco] binding is a normal Racket procedure, so expression-mode code can use @racket[(raco '(setup rash-coreutils))]. The explicit implementation name @racket[coreutils-raco] is also exported. + +@section{Path selection} + +Shell-style argument expansion remains Rash's responsibility. The aliases expand +back into Rash's @tt{=unix-pipe=} operator, preserving Rash globbing, tilde +expansion, and @tt{$} expansion. + +@verbatim{ +ls *.rkt +ls -l info* +cat info* +} + +Regular-expression values are an additional @bold{rash-coreutils} selector. A +@racket[#rx""] or @racket[#px""] value is matched against entry names in the +current directory. + +@verbatim{ +ls #px"^info[0-9]+[.]rkt$" +} + + +@section{Windows paths} + +On Windows, commands that write path names use forward slashes in their textual output. Rash treats backslashes as escape characters in line mode, so a printed path such as @tt{C:/Users/name/AppData/Local/Temp/file} can be copied directly into another Rash command. Racket path values themselves remain native and can be passed directly to a command through a Racket expression. + +@section{Help} + +@tt{help} uses Racket's documentation search through @tt{raco docs}. Registered +commands use package-specific index terms such as @tt{rash-coreutils-ls}. + +@verbatim{ +help +help ls +ls --help +help directory-list +} + +@section{Capturing and redirecting output} + +Commands use normal ports. Rash can therefore capture or redirect them without +special support in this package. + +@verbatim{ +(define git-path { which git |> read-line }) +ls &> listing.txt +cat info.rkt &>! copy.rkt +} + +@section{Compatibility scope} + +The command names and common options follow Unix conventions, but this package +does not claim complete GNU coreutils compatibility. Platform-independent +behavior, predictable Rash scripting, and useful integration with Racket values +are the primary goals. diff --git a/tests/acceptance-tests.rkt b/tests/acceptance-tests.rkt new file mode 100644 index 0000000..4436338 --- /dev/null +++ b/tests/acceptance-tests.rkt @@ -0,0 +1,3 @@ +#lang rash + +(require rash-coreutils) diff --git a/tests/coreutils.rkt b/tests/coreutils.rkt new file mode 100644 index 0000000..3608b33 --- /dev/null +++ b/tests/coreutils.rkt @@ -0,0 +1,166 @@ +#lang racket/base + +(require rackunit + racket/path + racket/file + racket/port + "../private/coreutils.rkt" + "../private/extended.rkt" + "../private/dispatcher.rkt" + "../private/help.rkt" + "../private/racket-tools.rkt" + "../private/env-support.rkt") + +(define (capture-output procedure . args) + (with-output-to-string + (λ () + (apply procedure args)))) + +(define (capture-filter input procedure . args) + (parameterize ([current-input-port (open-input-string input)]) + (apply capture-output procedure args))) + +(define test-root (make-temporary-file "rash-coreutils-~a" 'directory)) + +(dynamic-wind + void + (λ () + (parameterize ([current-directory test-root]) + (coreutils-mkdir "a") + (check-true (directory-exists? "a")) + + (coreutils-mkdir "-p" "b/c") + (check-true (directory-exists? "b/c")) + + (coreutils-touch "one.txt") + (check-true (file-exists? "one.txt")) + + (call-with-output-file "one.txt" + #:exists 'truncate + (λ (out) + (display "hello\n" out))) + (check-equal? (capture-output coreutils-cat "one.txt") "hello\n") + + (coreutils-cp "one.txt" "two.txt") + (check-true (file-exists? "two.txt")) + + (coreutils-mv "two.txt" "three.txt") + (check-false (file-exists? "two.txt")) + (check-true (file-exists? "three.txt")) + + (check-equal? (capture-output coreutils-echo "hello" "world") + "hello world\n") + + (check-true (regexp-match? #rx"one[.]txt" + (capture-output coreutils-ls))) + + (define long-listing (capture-output coreutils-ls "-l")) + (check-true (regexp-match? #rx"[-] +[0-9]+ +one[.]txt" + long-listing)) + + (coreutils-touch ".hidden") + (define long-all-listing (capture-output coreutils-ls "-la")) + (check-true (regexp-match? #rx"[-] +[0-9]+ +[.]hidden" + long-all-listing)) + + (coreutils-touch "info1.rkt") + (coreutils-touch "info22.rkt") + (coreutils-touch "other.rkt") + + (define regexp-arguments + (expand-coreutils-arguments (list #px"^info[0-9]+[.]rkt$"))) + (check-equal? + (sort (map (λ (path) + (path->string (file-name-from-path path))) + regexp-arguments) + string