Initial import

2026-08-17 23:19:13 +02:00
parent 8210aa8e63
commit 1d546c3d6f
20 changed files with 1799 additions and 1 deletions
@@ -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)
+          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)))))