diff --git a/collects/scribblings/raco/link.scrbl b/collects/scribblings/raco/link.scrbl index b257527170..e369f00af1 100644 --- a/collects/scribblings/raco/link.scrbl +++ b/collects/scribblings/raco/link.scrbl @@ -45,17 +45,19 @@ Full command-line options: @item{@Flag{l} or @DFlag{list} --- Shows the current link table. If any other command-line arguments are provided that modify the link table, the table is shown after modifications. If no - directory arguments are provided, and if none of @Flag{r}, - @DFlag{remove}, @Flag{i}, @DFlag{installation}, @Flag{f}, or + directory arguments are provided, and if none of @Flag{u}, + @DFlag{user}, @Flag{i}, @DFlag{installation}, @Flag{f}, or @DFlag{file} are specified, then the link table is shown for both the user-specific and installation-wide @tech[#:doc reference-doc]{collection links files}.} @item{@Flag{n} @nonterm{name} or @DFlag{name} @nonterm{name} --- Sets - the collection name for adding or removing a single link. By - default, the collection name for an added link is derived from - the directory name. When the @Flag{r} or @DFlag{remove} flag is - also used, only links with a collection name matching + the collection name for adding a single link or removing + matching links. By default, the collection name for an added + link is derived from the directory name. When the @Flag{r} or + @DFlag{remove} flag is also used, only links with a collection + name matching @nonterm{name} are removed, and if no directory + arguments are provided, all links with a match to @nonterm{name} are removed.} @item{@Flag{x} @nonterm{regexp} or @DFlag{version-regexp} @@ -65,17 +67,28 @@ Full command-line options: or @DFlag{remove} flag is also used, only links with a version regexp matching @nonterm{regexp} are removed.} + @item{@Flag{r} or @DFlag{remove} --- Selects remove mode instead + of add mode.} + + @item{@Flag{u} or @DFlag{user} --- Limits listing and removal + of links to the user-specific @tech[#:doc + reference-doc]{collection links file} and not the + collection-wide @tech[#:doc reference-doc]{collection links + file}. This flag is mutually exclusive with @Flag{i}, + @DFlag{installation}, @Flag{f}, and @DFlag{file}.} + @item{@Flag{i} or @DFlag{installation} --- Reads and writes links in installation-wide @tech[#:doc reference-doc]{collection links - file} instead of the user-specific @tech[#:doc - reference-doc]{collection links file}. This flag is mutally - exclusive with @Flag{f} and @DFlag{file}.} + file} and not the user-specific @tech[#:doc + reference-doc]{collection links file}. This flag is mutually + exclusive with @Flag{u}, @DFlag{user}, @Flag{f}, and + @DFlag{file}.} @item{@Flag{f} @nonterm{file} or @DFlag{file} @nonterm{file} --- Reads and writes links in @nonterm{file} instead of the user-specific @tech[#:doc reference-doc]{collection links - file}. This flag is mutally exclusive with @Flag{i} and - @DFlag{installation}.} + file}. This flag is mutually exclusive with @Flag{u}, + @DFlag{user}, @Flag{i}, and @DFlag{installation}.} @item{@DFlag{repair} --- Enables repairs to the existing file content when the content is erroneous. The file is repaired by deleting @@ -89,19 +102,28 @@ Full command-line options: @defmodule[setup/link] -@defproc[(links [dirs (listof path?)] - [#:file file path-string? (find-system-path 'links-file)] +@defproc[(links [dir path?] ... + [#:user? user? #t] + [#:file file (or/c path-string? #f) #f] [#:name name (or/c string? #f) #f] [#:version-regexp version-regexp (or/c regexp? #f) #f] [#:error error-proc (symbol? string? any/c ... . -> . any) error] [#:remove? remove? any/c #f] [#:show? show? any/c #f] [#:repair? repair? any/c #f]) - (listof string?)]{ + list?]{ -A function version of the @exec{raco link} command. The -@racket[error-proc] argument is called to raise exceptions that would -be fatal to the @exec{raco link} command. +A function version of the @exec{raco link} command that always works +on a single file---either @racket[file] if it is a path string, the +user-specific @tech[#:doc reference-doc]{collection links file} if +@racket[user?] is true, of the installation-wide @tech[#:doc +reference-doc]{collection links file} if @racket[user?] is false. + +The @racket[error-proc] argument is called to raise exceptions that +would be fatal to the @exec{raco link} command. + +If @racket[remove?] is false, the result is a list of top-level +collection names (as strings) that are mapped by @racket[file] and +that apply to the running version of Racket. If @racket[remove?] is +true, the result is a list of entries that were removed from the file.} -The result is a list of top-level collections that are mapped by -@racket[file] and that apply to the running version of Racket.} diff --git a/collects/setup/commands/link.rkt b/collects/setup/commands/link.rkt index 28c06bbefa..d912cc423b 100644 --- a/collects/setup/commands/link.rkt +++ b/collects/setup/commands/link.rkt @@ -9,7 +9,8 @@ (define remove-mode (make-parameter #f)) (define repair-mode (make-parameter #f)) (define show-mode (make-parameter #f)) -(define user-mode (make-parameter #t)) +(define install-only (make-parameter #f)) +(define user-only (make-parameter #f)) (define link-symbol (string->symbol (short-program+command-name))) @@ -19,7 +20,7 @@ #:once-each [("-l" "--list") "Show the link table (after changes)" (show-mode #t)] - [("-n" "--name") name "Set the collection name (for a single directory)" + [("-n" "--name") name "Collection name to add (single ) or remove" (link-name name)] [("-x" "--version-regexp") regexp "Set the version pregexp" (with-handlers ([exn:fail:contract? (lambda (exn) @@ -30,8 +31,10 @@ [("-r" "--remove") "Remove links for the specified directories" (remove-mode #t)] #:once-any - [("-i" "--installation") "Adjust user-independent links in the installation" - (user-mode #f)] + [("-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 @@ -41,6 +44,7 @@ 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")) @@ -48,27 +52,41 @@ (define show-both? (and (null? dirs) (show-mode) - (user-mode) - (not (remove-mode)) + (not (user-only)) + (not (install-only)) (not (link-file)))) (when show-both? (printf "User links:\n")) -(void - (apply links - dirs - #:user? (user-mode) - #: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 (go user?) + (apply links + dirs + #: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")) + diff --git a/collects/setup/link.rkt b/collects/setup/link.rkt index cd659bf72e..36fa3a3cf6 100644 --- a/collects/setup/link.rkt +++ b/collects/setup/link.rkt @@ -82,13 +82,18 @@ (define new-table (reverse - (for/fold ([table (reverse table)]) ([d (in-list dirs)]) - (let* ([dp (path->complete-path d)] - [a-name (or name - (let-values ([(base name dir?) (split-path dp)]) - (path-element->string name)))] + (for/fold ([table (reverse table)]) ([d (in-list + (if (and (null? dirs) + name) + '(#f) + dirs))]) + (let* ([dp (and d (path->complete-path d))] + [a-name (and d + (or name + (let-values ([(base name dir?) (split-path dp)]) + (path-element->string name))))] [rx version-regexp] - [d (path->string dp)]) + [d (and dp (path->string dp))]) (unless remove? (unless (directory-exists? dp) (error 'links @@ -96,7 +101,8 @@ dp))) (if remove? (filter (lambda (e) - (or (not (equal? (cadr e) d)) + (or (and d + (not (equal? (cadr e) d))) (and name (not (equal? (car e) name))) (and version-regexp @@ -148,10 +154,13 @@ (format " version: ~s" (caddr e)))))) - ;; Return list of collections mapped for this version: - (let ([ht (make-hash)]) - (for ([e (in-list new-table)]) - (when (or (null? (cddr e)) - (regexp-match? (caddr e) (version))) - (hash-set! ht (car e) #t))) - (hash-map ht (lambda (k e) k)))) + (if remove? + ;; return list of removed entries: + (filter (lambda (e) (not (member e new-table))) table) + ;; Return list of collections mapped for this version: + (let ([ht (make-hash)]) + (for ([e (in-list new-table)]) + (when (or (null? (cddr e)) + (regexp-match? (caddr e) (version))) + (hash-set! ht (car e) #t))) + (hash-map ht (lambda (k e) k)))))