suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco setup: put launchers for user collections in user space

Browse Source 
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.
This commit is contained in:
Matthew Flatt 2013-04-24 10:43:30 -06:00
parent 2dc6b2f87f
commit ebd7ebea4f
4 changed files with 150 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
collects/launcher/launcher-unit.rkt
View File

@ -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)

20
collects/scribblings/raco/launcher.scrbl
View File

@ -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?]

9
collects/scribblings/raco/setup.scrbl
View File

@ -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.}

110
collects/setup/setup-unit.rkt
View File

@ -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 ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;