99 lines
2.8 KiB
Racket
99 lines
2.8 KiB
Racket
#lang scheme/base
|
|
(require racket/cmdline
|
|
raco/command-name
|
|
"../link.rkt")
|
|
|
|
(define link-file (make-parameter #f))
|
|
(define link-name (make-parameter #f))
|
|
(define root-mode (make-parameter #f))
|
|
(define link-version (make-parameter #f))
|
|
(define remove-mode (make-parameter #f))
|
|
(define repair-mode (make-parameter #f))
|
|
(define show-mode (make-parameter #f))
|
|
(define install-only (make-parameter #f))
|
|
(define user-only (make-parameter #f))
|
|
|
|
(define link-symbol (string->symbol (short-program+command-name)))
|
|
|
|
(define dirs
|
|
(command-line
|
|
#:program (short-program+command-name)
|
|
#:once-each
|
|
[("-l" "--list") "Show the link table (after changes)"
|
|
(show-mode #t)]
|
|
#:once-any
|
|
[("-n" "--name") name "Collection name to add (single <dir>) or remove"
|
|
(link-name name)]
|
|
[("-d" "--root") "Treat <dir> as a collection root"
|
|
(root-mode #t)]
|
|
#:once-each
|
|
[("-x" "--version-regexp") regexp "Set the version pregexp"
|
|
(with-handlers ([exn:fail:contract? (lambda (exn)
|
|
(raise-user-error link-symbol
|
|
"bad version regexp: ~a"
|
|
regexp))])
|
|
(link-version (pregexp regexp)))]
|
|
[("-r" "--remove") "Remove links for the specified directories"
|
|
(remove-mode #t)]
|
|
#:once-any
|
|
[("-u" "--user") "Adjust/list user-specific links"
|
|
(user-only #t)]
|
|
[("-i" "--installation") "Adjust/list installation-wide links"
|
|
(install-only #t)]
|
|
[("-f" "--file") file "Select an alternate link file"
|
|
(link-file (path->complete-path file))]
|
|
#:once-each
|
|
[("--repair") "Enable repair mode to fix existing links"
|
|
(repair-mode #t)]
|
|
#:args
|
|
dir dir))
|
|
|
|
(when (and (link-name)
|
|
(not (remove-mode))
|
|
(not (= 1 (length dirs))))
|
|
(raise-user-error link-symbol
|
|
"expected a single directory for `--name' mode"))
|
|
|
|
(define show-both?
|
|
(and (null? dirs)
|
|
(show-mode)
|
|
(not (user-only))
|
|
(not (install-only))
|
|
(not (link-file))))
|
|
|
|
(when show-both?
|
|
(printf "User links:\n"))
|
|
|
|
(define (go user?)
|
|
(apply links
|
|
dirs
|
|
#:root? (root-mode)
|
|
#:user? user?
|
|
#:file (link-file)
|
|
#:name (link-name)
|
|
#:version-regexp (link-version)
|
|
#:error (lambda (who . args)
|
|
(apply raise-user-error link-symbol args))
|
|
#:remove? (remove-mode)
|
|
#:show? (show-mode)
|
|
#:repair? (repair-mode)))
|
|
|
|
(define l1
|
|
(go (not (install-only))))
|
|
(define l2
|
|
(if (and (not (or (user-only)
|
|
(install-only)))
|
|
(remove-mode))
|
|
(go #f)
|
|
null))
|
|
|
|
(when show-both?
|
|
(printf "Installation links:\n")
|
|
(void (links #:user? #f #:show? #t)))
|
|
|
|
(when (and (remove-mode)
|
|
(null? l1)
|
|
(null? l2))
|
|
(printf "[no links removed]\n"))
|
|
|