273 lines
8.6 KiB
Racket
273 lines
8.6 KiB
Racket
#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)
|
|
string<?
|
|
#:key path-display-name))
|
|
(for ([entry (in-list entries)])
|
|
(when (or all? (not (hidden-name? entry)))
|
|
(write-ls-entry entry long?))))
|
|
|
|
(define (coreutils-pwd . args)
|
|
(unless (null? args)
|
|
(raise-arguments-error 'pwd "does not accept arguments" "arguments" args))
|
|
(displayln (path->rash-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)))))
|