From ebd7ebea4f071be91a390561d32fea8717ad0ea5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 24 Apr 2013 10:43:30 -0600 Subject: [PATCH] raco setup: put launchers for user collections in user space Also, remove executables (in full setup or "tidy" mode) when the corresponding collections are removed. As a result of these changes, `raco pkg' puts launchers from user-scoped packages in user space and cleans up launchers from removed packages. There's no attempt to include "launchers.rktd" in a distribution. That should be ok: having an entry in "launchers.rktd" just makes a launcher a candidate for removal. Including "launchers.rktd" would be a hassle for many reasons, including that the initial set of launchers is platform-specific. --- collects/launcher/launcher-unit.rkt | 31 ++++--- collects/scribblings/raco/launcher.scrbl | 20 +++-- collects/scribblings/raco/setup.scrbl | 9 ++ collects/setup/setup-unit.rkt | 110 ++++++++++++++++++++++- 4 files changed, 150 insertions(+), 20 deletions(-) diff --git a/collects/launcher/launcher-unit.rkt b/collects/launcher/launcher-unit.rkt index c9f247b293..e87730c7cd 100644 --- a/collects/launcher/launcher-unit.rkt +++ b/collects/launcher/launcher-unit.rkt @@ -622,15 +622,19 @@ (string-append (if mred? file (unix-sfx file mred?)) ".exe")] [else file])) -(define (program-launcher-path name mred?) +(define (program-launcher-path name mred? user?) (let* ([variant (current-launcher-variant)] [mac-script? (and (eq? (system-type) 'macosx) (script-variant? variant))]) (let ([p (add-file-suffix (build-path (if (or mac-script? (not mred?)) - (find-console-bin-dir) - (find-gui-bin-dir)) + (if user? + (find-user-console-bin-dir) + (find-console-bin-dir)) + (if user? + (find-user-gui-bin-dir) + (find-gui-bin-dir))) ((if mac-script? unix-sfx sfx) name mred?)) variant mred?)]) @@ -639,20 +643,23 @@ (path-replace-suffix p #".app") p)))) -(define (gracket-program-launcher-path name) - (program-launcher-path name #t)) -(define (mred-program-launcher-path name) - (gracket-program-launcher-path name)) +(define (gracket-program-launcher-path name #:user? [user? #f]) + (program-launcher-path name #t user?)) +(define (mred-program-launcher-path name #:user? [user? #f]) + (gracket-program-launcher-path name #:user? user?)) -(define (racket-program-launcher-path name) +(define (racket-program-launcher-path name #:user? [user? #f]) (case (system-type) [(macosx) - (add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f)) + (add-file-suffix (build-path (if user? + (find-user-console-bin-dir) + (find-console-bin-dir)) + (unix-sfx name #f)) (current-launcher-variant) #f)] - [else (program-launcher-path name #f)])) -(define (mzscheme-program-launcher-path name) - (racket-program-launcher-path name)) + [else (program-launcher-path name #f user?)])) +(define (mzscheme-program-launcher-path name #:user? [user? #f]) + (racket-program-launcher-path name #:user? user?)) (define (gracket-launcher-is-directory?) #f) diff --git a/collects/scribblings/raco/launcher.scrbl b/collects/scribblings/raco/launcher.scrbl index 7db49da303..fb5c16cae7 100644 --- a/collects/scribblings/raco/launcher.scrbl +++ b/collects/scribblings/raco/launcher.scrbl @@ -175,10 +175,14 @@ arguments.} @section{Launcher Path and Platform Conventions} -@defproc[(gracket-program-launcher-path [name string?]) path?]{ +@defproc[(gracket-program-launcher-path [name string?] + [#:user? user? any/c #f]) + path?]{ -Returns a pathname for an executable in the Racket installation -called something like @racket[name]. For Windows, the @filepath{.exe} +Returns a pathname for an executable called something like @racket[name] +in the Racket installation (if @racket[user?] is @racket[#f]) or the +user's Racket executable directory (if @racket[user?] is @racket[#t]). +For Windows, the @filepath{.exe} suffix is automatically appended to @racket[name]. For Unix, @racket[name] is changed to lowercase, whitespace is changed to @litchar{-}, and the path includes the @filepath{bin} subdirectory of @@ -186,9 +190,11 @@ the Racket installation. For Mac OS X, the @filepath{.app} suffix is appended to @racket[name].} -@defproc[(racket-program-launcher-path [name string?]) path?]{ +@defproc[(racket-program-launcher-path [name string?] + [#:user? user? any/c #f]) + path?]{ -Returns the same path as @racket[(gracket-program-launcher-path name)] +Returns the same path as @racket[(gracket-program-launcher-path name #:user? user?)] for Unix and Windows. For Mac OS X, the result is the same as for Unix.} @@ -254,7 +260,7 @@ Like @racket[gracket-launcher-get-file-extension+style+filters], but for Racket launchers.} @deftogether[( -@defproc[(mred-program-launcher-path [name string?]) path?] +@defproc[(mred-program-launcher-path [name string?] [#:user? user? any/c #f]) path?] @defproc[(mred-launcher-is-directory?) boolean?] @defproc[(mred-launcher-is-actually-directory?) boolean?] @defproc[(mred-launcher-add-suffix [path-string? path]) path?] @@ -268,7 +274,7 @@ Backward-compatible aliases for @racket[gracket-program-launcher-path], etc.} @deftogether[( -@defproc[(mzscheme-program-launcher-path [name string?]) path?] +@defproc[(mzscheme-program-launcher-path [name string?] [#:user? user? any/c #f]) path?] @defproc[(mzscheme-launcher-is-directory?) boolean?] @defproc[(mzscheme-launcher-is-actually-directory?) boolean?] @defproc[(mzscheme-launcher-add-suffix [path-string? path]) path?] diff --git a/collects/scribblings/raco/setup.scrbl b/collects/scribblings/raco/setup.scrbl index 8f7848daba..49ae968c65 100644 --- a/collects/scribblings/raco/setup.scrbl +++ b/collects/scribblings/raco/setup.scrbl @@ -961,6 +961,15 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. } stand-alone GRacket executable resides. The result is @racket[#f] if no such directory is available.} +@defproc[(find-user-console-bin-dir) path?]{ + Returns a path to the user's executable directory; the directory + indicated by the returned path may or may not exist.} + +@defproc[(find-user-gui-bin-dir) path?]{ + Returns a path to the user's executable directory for graphical + programs; the directory indicated by the returned path may or may + not exist.} + @defthing[absolute-installation? boolean?]{ A binary boolean flag that is true if this installation is using absolute path names.} diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index d0b6df5f36..1d3abc383e 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -1073,6 +1073,18 @@ (unless (list-of (list-of string?) l) (error "result is not a list of strings:" l))) (define ((or-f f) x) (when x (f x))) + (when (or no-specific-collections? + (make-tidy)) + (unless (avoid-main-installation) + (tidy-launchers #f + (find-console-bin-dir) + (find-gui-bin-dir) + (find-lib-dir))) + (when (make-user) + (tidy-launchers #t + (find-user-console-bin-dir) + (find-user-gui-bin-dir) + (find-user-lib-dir)))) (for ([cc ccs-to-compile]) (begin-record-error cc "Launcher Setup" (define info (cc-info cc)) @@ -1102,7 +1114,19 @@ (for ([mzln (in-list mzlns)] [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))] [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))]) - (define p (program-launcher-path mzln)) + (define p (program-launcher-path mzln #:user? (not (cc-main? cc)))) + (define receipt-path + (build-path (if (cc-main? cc) + (find-lib-dir) + (find-user-lib-dir)) + "launchers.rktd")) + (define (prep-dir p) + (define dir (path-only p)) + (make-directory* dir)) + (prep-dir p) + (prep-dir receipt-path) + (record-launcher receipt-path mzln kind (current-launcher-variant) + (cc-collection cc) (cc-path cc)) (define aux `((exe-name . ,mzln) (framework-root . #f) @@ -1174,6 +1198,90 @@ make-mzscheme-launcher mzscheme-launcher-up-to-date?)))))) + (define (read-launchers receipt-path) + (if (file-exists? receipt-path) + (with-handlers ([exn:fail? + (lambda (exn) + (setup-printf + "WARNING" + "error reading launcher list ~s: ~a" + receipt-path + (exn-message exn)) + #hash())]) + (call-with-input-file* + receipt-path + (lambda (i) + (define ht (read i)) + (if (hash? ht) + ht + (error "content is not a hash table"))))) + #hash())) + + (define (write-launchers receipt-path ht) + (call-with-output-file* + #:exists 'truncate/replace + receipt-path + (lambda (o) (write ht o)))) + + (define (record-launcher receipt-path name kind variant coll coll-path) + (let ([ht (read-launchers receipt-path)]) + (define coll-rel (let ([p (path->main-collects-relative coll-path)]) + (if (path? p) + (path->bytes p) + p))) + (define exe-key (vector kind + variant + name)) + (define exe-val (cons (map path->string coll) coll-rel)) + (unless (equal? (hash-ref ht exe-key #f) + exe-val) + (let ([ht (hash-set ht exe-key exe-val)]) + (write-launchers receipt-path ht))))) + + (define (tidy-launchers user? bin-dir gui-bin-dir lib-dir) + (define receipt-path (build-path lib-dir "launchers.rktd")) + (define ht (read-launchers receipt-path)) + (define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)]) + (define coll-path (main-collects-relative->path (cdr v))) + (cond + [(and (directory-exists? coll-path) + ;; Collection path must match collection resolution: + (with-handlers ([exn:fail? (lambda (exn) #f)]) + (equal? coll-path (apply collection-path (car v))))) + ;; keep the launcher + (hash-set ht k v)] + [else + ;; remove the launcher + (define kind (vector-ref k 0)) + (define variant (vector-ref k 1)) + (define name (vector-ref k 2)) + (parameterize ([current-launcher-variant variant]) + (define exe-path ((if (eq? kind 'gui) + gracket-program-launcher-path + racket-program-launcher-path) + name + #:user? user?)) + (define is-dir? + (if (eq? kind 'gui) + (gracket-launcher-is-actually-directory?) + (racket-launcher-is-actually-directory?))) + (define rel-exe-path + ((if (eq? kind 'gui) + path->relative-string/gui-bin + path->relative-string/console-bin) + exe-path)) + (cond + [(and (not is-dir?) (file-exists? exe-path)) + (setup-printf "deleting" "launcher ~a" rel-exe-path) + (delete-file exe-path)] + [(and is-dir? (directory-exists? exe-path)) + (setup-printf "deleting" "launcher ~a" rel-exe-path) + (delete-directory/files exe-path)])) + ht]))) + (unless (equal? ht ht2) + (setup-printf "updating" "launcher list") + (write-launchers receipt-path ht2))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; setup-unit Body ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;