diff --git a/stash2.scm b/stash2.scm new file mode 100644 index 0000000..3f69777 --- /dev/null +++ b/stash2.scm @@ -0,0 +1,101 @@ +;;; Code: + +;; Import necessary modules +(use-modules (ice-9 getopt-long) + (ice-9 popen) ;; Additional module for executing system commands + (ice-9 rdelim)) + +;;; ANSI Color Codes for terminal output +(define red-text "\x1b[31m") +(define yellow-text "\x1b[33m") +(define green-text "\x1b[32m") +(define reset-text "\x1b[0m") + +;;; Function to wrap messages in color +(define (color-message message color) + (string-append color message reset-text)) + +(define (shell-quote-argument arg) + (if (string-contains arg " ") + (string-append "\"" (string-replace arg "\"" "\\\"") "\"") + arg)) + +(define (parse-arguments args) + "Parse command-line arguments." + (let* ((opts (getopt-long args + '((target (value #t) (required? #t)) + (package-dir (value #t) (required? #t)))))) + opts)) + +(define (delete-directory path) + (if (file-is-directory? path) + (begin + (system (string-append "rm -r " (shell-quote-argument path))) + #t) + #f)) + +(define (prompt-user-for-action) + "Prompt the user to decide how to handle a conflict: overwrite (o), skip (s), or rename (r)." + (display (color-message "A conflict was detected. Choose action - Overwrite (o), Skip (s), or Rename (r): " yellow-text)) + (let ((response (read-line))) + (cond + ((string-ci=? response "o") 'overwrite) + ((string-ci=? response "s") 'skip) + ((string-ci=? response "r") 'rename) + (else + (display (color-message "Invalid input. " red-text)) + (prompt-user-for-action))))) ; Recursive call on invalid input. + +(define (handle-conflicts existing-path new-symlink-path) + "Handle conflicts between existing files and new symlinks." + (case (prompt-user-for-action) + ((overwrite) + (if (file-is-directory? existing-path) + (delete-directory existing-path) ;; Call the delete-directory function + (delete-file existing-path)) ;; Use Guile's built-in delete-file for files + (symlink new-symlink-path existing-path) + (format #t (color-message (string-append "Existing file/directory overwritten with new symlink: " existing-path " -> " new-symlink-path "\n") green-text))) + ((skip) + (display (color-message "Skipped creating new symlink due to conflict.\n" red-text))) + ((rename) + ;; Prompt for new name and execute renaming + (display (color-message "Enter new name for the existing symlink or file: " yellow-text)) + (let ((new-name (read-line))) + (let ((new-path (string-append (dirname existing-path) "/" new-name))) + (rename-file existing-path new-path) + (format #t (color-message (string-append "Renamed " existing-path " to " new-name "\n") green-text))))) + (else + (display (color-message "No valid action selected, no changes made.\n" red-text))))) + +(define (create-symlink source target) + "Create a symlink for the source directory at the target location." + (let ((target-symlink-path (string-append target "/" (basename source)))) + (if (file-exists? target-symlink-path) + (handle-conflicts target-symlink-path source) ; Call conflict handler if file exists + (catch 'system-error + (lambda () + (symlink source target-symlink-path) + (display (color-message (string-append "Symlink created for: " target-symlink-path " -> " source "\n") green-text))) + (lambda args + (display (color-message "Error creating symlink.\n" red-text))))))) + +;;; Updated main function with error handling using `catch` +(define (main args) + "Main function to parse arguments and initiate processing." + (let* ((options (parse-arguments args)) + (target-dir (assoc-ref options 'target)) + (package-dir (assoc-ref options 'package-dir))) + (if (and target-dir package-dir) + (catch 'symlink-error + (lambda () + (create-symlink package-dir target-dir)) ;; Try to create symlink + (lambda (key . args) + ;; Handle the 'symlink-error + (display (color-message (format #f "Error creating symlink: ~a\n" (car args)) red-text)))) + (begin + (display (color-message "Error: Missing required arguments.\n" red-text)) + (display (color-message "Usage: guile stash.scm --target= --package-dir=\n" yellow-text)) + (exit 1))))) + +;; Entry point for guile-stash +(main (command-line))