raco setup: allow foreign-lib and man-page installation

This change hopefully fills out the things that a distribution
can do and that packages should be able to extend.

collects/scribblings/raco/setup.scrbl

@@ -26,7 +26,9 @@
                     dynext/file-sig
                     racket/gui/base
                     racket/future
-                    mrlib/terminal))
+                    mrlib/terminal
+                    (only-in ffi/unsafe ffi-lib)
+                    racket/path))
 
 @(define-syntax-rule (local-module mod . body)
    (begin
@@ -128,7 +130,11 @@ flags:
    the assumption that they are already up-to-date.}
 
  @item{@DFlag{no-launcher} or @Flag{x} --- refrain from creating
-   executables (as specified in @filepath{info.rkt} files; see
+   executables or installing @tt{man} pages (as specified in
+   @filepath{info.rkt}; see @secref["setup-info"].}
+
+ @item{@DFlag{no-foreign-libs} --- refrain from installing foreign
+   libraries (as specified in @filepath{info.rkt}; see
    @secref["setup-info"]).}
 
  @item{@DFlag{no-install} or @Flag{i} --- refrain from running
@@ -459,6 +465,26 @@ Optional @filepath{info.rkt} fields trigger additional actions by
    @racket[mred-launcher-flags] --- Backward-compatible variant of
    @racket[gracket-launcher-names], etc.}
 
+ @item{@indexed-racket[copy-foreign-libs] : @racket[(listof (and/c
+   path-string? relative-path?))] --- Files to copy into a
+   directory where foreign libraries are found by @racket[ffi-lib].}
+
+ @item{@indexed-racket[move-foreign-libs] : @racket[(listof (and/c
+   path-string? relative-path?))] --- Like @racket[copy-foreign-libs],
+   but the original file is removed after it is copied (which makes sense
+   for precompiled packages).}
+
+ @item{@indexed-racket[copy-man-pages] : @racket[(listof (and/c
+   path-string? relative-path? filename-extension))] --- Files to copy
+   into a @tt{man} directory. The file suffix determines its category;
+   for example, @litchar{.1} should be used for a @tt{man} page
+   describing an executable.}
+
+ @item{@indexed-racket[move-man-pages] : @racket[(listof (and/c
+   path-string? relative-path? filename-extension))] --- Like
+   @racket[copy-man-pages], but the original file is removed after it
+   is copied (which makes sense for precompiled packages).}
+
  @item{@indexed-racket[install-collection] : @racket[path-string?]  --- A
    library module relative to the collection that provides
    @racket[installer]. The @racket[installer] procedure accepts either
@@ -663,7 +689,7 @@ form.}
  @filepath{.so}/@filepath{.dll}/@filepath{.dylib} files in the
  specified collections. @defaults[@racket[#f]]}
 
-@defparam[compile-mode path (or/c path? false/c)]{
+@defparam[compile-mode path (or/c path? #f)]{
   If a @racket[path] is given, use a @filepath{.zo} compiler other than plain
   @exec{compile}, and build to @racket[(build-path "compiled" (compile-mode))].
   @defaults[@racket[#f]]}
@@ -676,7 +702,10 @@ form.}
   collection path. @defaults[@racket[#t]]}
 
 @defboolparam[make-launchers on?]{
-  If on, make collection @filepath{info.rkt}-specified launchers. @defaults[@racket[#t]]}
+  If on, make collection @filepath{info.rkt}-specified launchers and @tt{man} pages. @defaults[@racket[#t]]}
+
+@defboolparam[make-foreign-lib on?]{
+  If on, install collection @filepath{info.rkt}-specified libraries. @defaults[@racket[#t]]}
 
   @defboolparam[make-docs on?]{
     If on, build documentation.
@@ -697,6 +726,12 @@ form.}
  If on, avoid building bytecode in the main installation tree when building
  other bytecode (e.g., in a user-specific collection). @defaults[@racket[#f]]}
 
+@defboolparam[make-tidy on?]{
+ If on, remove metadata cache information and
+  documentation for non-existent collections (to clean up after removal)
+  even when @racket[specific-collections] or @racket[specific-planet-dirs]
+  is non-@racket['()] or @racket[make-only] is true. @defaults[@racket[#f]]}
+
 @defboolparam[call-install on?]{
   If on, call collection @filepath{info.rkt}-specified setup code.
   @defaults[@racket[#t]]}
@@ -733,6 +768,10 @@ form.}
     is also @racket['()]. @defaults[@racket['()]]
   }
 
+@defboolparam[make-only on?]{
+ If true, set up no collections if @racket[specific-collections]
+ and @racket[specific-planet-dirs] are both @racket['()].}
+  
 @defparam[archives arch (listof path-string?)]{
   A list of @filepath{.plt} archives to unpack; any collections specified
   by the archives are set-up in addition to the collections listed in
@@ -779,7 +818,7 @@ interface.
 
 @defproc[(run-single-installer
           (file path-string?)
-          (get-dir-proc (-> (or/c path-string? false/c)))) void?]{
+          (get-dir-proc (-> (or/c path-string? #f)))) void?]{
    Creates a separate thread and namespace, runs the installer in that
    thread with the new namespace, and returns when the thread
    completes or dies. It also creates a custodian
@@ -860,7 +899,7 @@ v
   }
 
 @defproc[(run-single-installer (file path-string?)
-                               (get-dir-proc (-> (or/c path-string? false/c))))
+                               (get-dir-proc (-> (or/c path-string? #f))))
          void?]{
   The same as the export from @racketmodname[setup/plt-single-installer], 
   but with a GUI.}
@@ -890,7 +929,7 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   The @racketmodname[setup/dirs] library provides several procedures for locating
   installation directories:}
 
-@defproc[(find-collects-dir) (or/c path? false/c)]{
+@defproc[(find-collects-dir) (or/c path? #f)]{
   Returns a path to the installation's main @filepath{collects} directory, or
   @racket[#f] if none can be found. A @racket[#f] result is likely only
   in a stand-alone executable that is distributed without libraries.}
@@ -904,7 +943,7 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   which means that this result is not sensitive to the value of the 
   @racket[use-user-specific-search-paths] parameter.}
 
-@defproc[(find-doc-dir) (or/c path? false/c)]{
+@defproc[(find-doc-dir) (or/c path? #f)]{
   Returns a path to the installation's @filepath{doc} directory.
   The result is @racket[#f] if no such directory is available.}
 
@@ -920,12 +959,12 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   included only if the value of the @racket[use-user-specific-search-paths]
   parameter is @racket[#t].}
 
-@defproc[(find-lib-dir) (or/c path? false/c)]{
+@defproc[(find-lib-dir) (or/c path? #f)]{
   Returns a path to the installation's @filepath{lib} directory, which contains
   libraries and other build information. The result is @racket[#f] if no such
   directory is available.}
 
-@defproc[(find-dll-dir) (or/c path? false/c)]{
+@defproc[(find-dll-dir) (or/c path? #f)]{
   Returns a path to the directory that contains DLLs for use with the
   current executable (e.g., @filepath{libmzsch.dll} on Windows).
   The result is @racket[#f] if no such directory is available, or if no
@@ -944,7 +983,7 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   value of the @racket[use-user-specific-search-paths] parameter
   is @racket[#t].}
 
-@defproc[(find-include-dir) (or/c path? false/c)]{
+@defproc[(find-include-dir) (or/c path? #f)]{
   Returns a path to the installation's @filepath{include} directory, which
   contains @filepath{.h} files for building Racket extensions and embedding
   programs. The result is @racket[#f] if no such directory is available.}
@@ -960,12 +999,12 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   latter is included only if the value of the
   @racket[use-user-specific-search-paths] parameter is @racket[#t].}
 
-@defproc[(find-console-bin-dir) (or/c path? false/c)]{
+@defproc[(find-console-bin-dir) (or/c path? #f)]{
   Returns a path to the installation's executable directory, where the
   stand-alone Racket executable resides. The result is @racket[#f] if no
   such directory is available.}
 
-@defproc[(find-gui-bin-dir) (or/c path? false/c)]{
+@defproc[(find-gui-bin-dir) (or/c path? #f)]{
   Returns a path to the installation's executable directory, where the
   stand-alone GRacket executable resides. The result is @racket[#f] if no such
   directory is available.}
@@ -979,6 +1018,14 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   programs; the directory indicated by the returned path may or may
   not exist.}
 
+@defproc[(find-man-dir) (or/c path? #f)]{
+  Returns a path to the installation's man-page directory. The result is
+  @racket[#f] if no such directory exists.}
+
+@defproc[(find-user-man-dir) path?]{
+  Returns a path to the user's man-page directory; 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.}
@@ -995,7 +1042,7 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
                    [#:namespace namespace (or/c namespace? #f) #f])
          (or/c
           (symbol? [(-> any)] . -> . any)
-          false/c)]{
+          #f)]{
    Accepts a list of strings naming a collection or sub-collection,
    and calls @racket[get-info/full] with the full path corresponding to the
    named collection and the @racket[namespace] argument.}
@@ -1004,7 +1051,7 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
                         [#:namespace namespace (or/c namespace? #f) #f])
          (or/c
           (symbol? [(-> any)] . -> . any)
-          false/c)]{
+          #f)]{
 
    Accepts a path to a directory. If it finds either a well-formed
    an @filepath{info.rkt} file or an @filepath{info.ss} file (with

collects/setup/configtab.rkt

@@ -18,7 +18,8 @@
     lib-search-dirs
     include-dir
     include-search-dirs
-    bin-dir))
+    bin-dir
+    man-dir))
 (define-for-syntax string-exports
   '(cgc-suffix
     3m-suffix))

collects/setup/dirs.rkt

@@ -122,6 +122,15 @@
   get-lib-search-dirs find-dll-dir
   "lib")
 
+;; ----------------------------------------
+;; "man"
+
+(define-finder provide
+  config:man-dir
+  find-man-dir
+  find-user-man-dir
+  "man")
+
 ;; ----------------------------------------
 ;; Executables
 

collects/setup/option-sig.rkt

@@ -14,6 +14,7 @@
      make-only
      make-zo
      make-info-domain
+     make-foreign-libs
      make-launchers
      make-docs
      make-user

collects/setup/option-unit.rkt

@@ -39,6 +39,7 @@
   (define-flag-param make-only #f)
   (define-flag-param make-zo #t)
   (define-flag-param make-launchers #t)
+  (define-flag-param make-foreign-libs #t)
   (define-flag-param make-info-domain #t)
   (define-flag-param make-docs #t)
   (define-flag-param make-user #t)

collects/setup/setup-cmdline.rkt

@@ -60,6 +60,8 @@
       (add-flags '((trust-existing-zos #t)))]
      [("-x" "--no-launcher") "Do not produce launcher programs"
       (add-flags '((make-launchers #f)))]
+     [("--no-foreign-libs") "Do not install foreign libraries"
+      (add-flags '((make-foreign-libs #f)))]
      [("-i" "--no-install") "Do not call collection-specific pre-installers"
       (add-flags '((call-install #f)))]
      [("-I" "--no-post-install") "Do not call collection-specific post-installers"

collects/setup/setup-unit.rkt

@@ -101,6 +101,10 @@
     (make-path->relative-string
      (list (cons find-gui-bin-dir "<gui-bin>/"))))
 
+  (define path->relative-string/lib
+    (make-path->relative-string
+     (list (cons find-lib-dir "<lib>/"))))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                   Errors                      ;;
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1213,13 +1217,13 @@
                            make-mzscheme-launcher
                            mzscheme-launcher-up-to-date?))))))
 
-  (define (read-launchers receipt-path)
+  (define (read-receipt-hash receipt-path)
     (if (file-exists? receipt-path)
         (with-handlers ([exn:fail?
                          (lambda (exn)
                            (setup-printf
                             "WARNING"
-                            "error reading launcher list ~s: ~a"
+                            "error reading receipts ~s: ~a"
                             receipt-path
                             (exn-message exn))
                            #hash())])
@@ -1232,14 +1236,14 @@
                  (error "content is not a hash table")))))
         #hash()))
 
-  (define (write-launchers receipt-path ht)
+  (define (write-receipt-hash receipt-path ht)
     (call-with-output-file*
      #:exists 'truncate/replace
      receipt-path
-     (lambda (o) (write ht o))))
+     (lambda (o) (write ht o) (newline o))))
 
   (define (record-launcher receipt-path name kind variant coll coll-path)
-    (let ([ht (read-launchers receipt-path)])
+    (let ([ht (read-receipt-hash receipt-path)])
       (define coll-rel (let ([p (path->main-collects-relative coll-path)])
                          (if (path? p)
                              (path->bytes p)
@@ -1251,11 +1255,11 @@
       (unless (equal? (hash-ref ht exe-key #f)
                       exe-val)
         (let ([ht (hash-set ht exe-key exe-val)]) 
-          (write-launchers receipt-path ht)))))
+          (write-receipt-hash 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 ht (read-receipt-hash receipt-path))
     (define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)])
                   (define coll-path (main-collects-relative->path (cdr v)))
                   (cond
@@ -1295,7 +1299,171 @@
                     ht])))
     (unless (equal? ht ht2)
       (setup-printf "updating" "launcher list")
-      (write-launchers receipt-path ht2)))
+      (write-receipt-hash receipt-path ht2)))
+
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;       Foriegn Libraries and Man Pages         ;;
+  ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (make-copy/move-step what
+                               whats
+                               what/title
+                               copy-tag
+                               move-tag
+                               find-target-dir
+                               find-user-target-dir
+                               receipt-file
+                               check-entry
+                               build-dest-path)
+    (define (make-libs-step)
+      (setup-printf #f (format "--- installing ~a ---" whats))
+      (when (or no-specific-collections?
+                (make-tidy))
+        (unless (avoid-main-installation)
+          (tidy-libs #f
+                     (find-target-dir)
+                     (find-lib-dir)))
+        (when (make-user)
+          (tidy-libs #t
+                     (find-user-target-dir)
+                     (find-user-lib-dir))))
+      (for ([cc ccs-to-compile])
+        (begin-record-error cc what/title
+                            (define info (cc-info cc))
+                            (define copy-libs
+                              (call-info info copy-tag (lambda () null) check-entry))
+                            (define move-libs
+                              (call-info info move-tag (lambda () null) check-entry))
+
+                            (unless (and (null? copy-libs)
+                                         (null? move-libs))
+                              (define dir (if (cc-main? cc)
+                                              (find-target-dir)
+                                              (find-user-target-dir)))
+                              (define r-dir (if (cc-main? cc)
+                                                (find-lib-dir)
+                                                (find-user-lib-dir)))
+                              (define receipt-path (build-path r-dir receipt-file))
+                              (make-directory* dir)
+                              (make-directory* r-dir)
+
+                              (define (copy-lib lib [check (lambda (s d) #t)])
+                                (define src (path->complete-path lib (cc-path cc)))
+                                (define lib-name (file-name-from-path lib))
+                                (define dest (build-dest-path dir lib-name))
+                                (when (check src dest)
+                                  (unless (and (file-exists? dest)
+                                               (same-content? src dest))
+                                    (setup-printf "installing" (string-append what " ~a")
+                                                  (path->relative-string/lib dest))
+                                    (record-lib receipt-path lib-name (cc-collection cc) (cc-path cc))
+                                    (when (file-exists? dest) (delete-file dest))
+                                    (copy-file src dest)))
+                                src)
+                              
+                              (for ([lib (in-list copy-libs)])
+                                (copy-lib lib))
+                              
+                              (for ([lib (in-list move-libs)])
+                                (define src
+                                  (copy-lib lib 
+                                            (lambda (src dest)
+                                              (or (not (file-exists? dest))
+                                                  (file-exists? src)))))
+                                (when (file-exists? src)
+                                  (delete-file src)))))))
+
+    (define (same-content? a b)
+      (call-with-input-file* 
+       a
+       (lambda (a)
+         (call-with-input-file* 
+          b
+          (lambda (b)
+            (define as (make-bytes 4096))
+            (define bs (make-bytes 4096))
+            (let loop ()
+              (define an (read-bytes! as a))
+              (define bn (read-bytes! bs a))
+              (and (equal? an bn)
+                   (equal? as bs)
+                   (or (eof-object? an)
+                       (loop)))))))))
+
+    (define (record-lib receipt-path name coll coll-path)
+      (let ([ht (read-receipt-hash receipt-path)])
+        (define coll-rel (let ([p (path->main-collects-relative coll-path)])
+                           (if (path? p)
+                               (path->bytes p)
+                               p)))
+        (define lib-key (path-element->bytes name))
+        (define lib-val (cons (map path->string coll) coll-rel))
+        (unless (equal? (hash-ref ht lib-key #f)
+                        lib-val)
+          (let ([ht (hash-set ht lib-key lib-val)]) 
+            (write-receipt-hash receipt-path ht)))))
+
+    (define (tidy-libs user? target-dir lib-dir)
+      (define receipt-path (build-path lib-dir receipt-file))
+      (define ht (read-receipt-hash 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 lib
+                      (hash-set ht k v)]
+                     [else
+                      ;; remove the lib
+                      (define lib-path (build-dest-path target-dir (bytes->path-element k)))
+                      (when (file-exists? lib-path)
+                        (setup-printf "deleting" (string-append what " ~a")
+                                      (path->relative-string/lib lib-path))
+                        (delete-file lib-path))
+                      ht])))
+      (unless (equal? ht ht2)
+        (setup-printf "updating" (format "~a list" what))
+        (write-receipt-hash receipt-path ht2)))
+    
+    make-libs-step)
+
+  (define make-foreign-libs-step
+    (make-copy/move-step "foreign library"
+                         "foreign libraries"
+                         "Foreign Library Setup"
+                         'copy-foreign-libs
+                         'move-foreign-libs
+                         find-lib-dir
+                         find-user-lib-dir
+                         "libs.rktd"
+                         (lambda (l)
+                           (unless (list-of relative-path-string? l)
+                             (error "entry is not a list of relative path strings:" l)))
+                         build-path))
+
+  (define make-mans-step
+    (make-copy/move-step "man page"
+                         "man pages"
+                         "Man Page Setup"
+                         'copy-man-pages
+                         'move-man-pages
+                         find-man-dir
+                         find-user-man-dir
+                         "mans.rktd"
+                         (lambda (l)
+                           (unless (list-of (lambda (p)
+                                              (and (relative-path-string? p)
+                                                   (filename-extension p)))
+                                            l)
+                             (error 
+                              "entry is not a list of relative path strings,each with a non-empty extension:" 
+                              l)))
+                         (lambda (d n)
+                           (build-path d 
+                                       (bytes->path-element (bytes-append #"man" (filename-extension n)))
+                                       n))))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; setup-unit Body                ;;
@@ -1318,10 +1486,15 @@
 
   (do-install-part 'pre)
 
+  (when (make-foreign-libs) (make-foreign-libs-step))
+
   (when (make-zo) (make-zo-step))
   (when (make-info-domain) (make-info-domain-step))
 
   (when (make-launchers) (make-launchers-step))
+  (when (make-launchers) 
+    (unless (eq? 'windows (system-type))
+      (make-mans-step)))
 
   (when make-docs?
     (make-docs-step))

collects/setup/unixstyle-install.rkt

@@ -297,6 +297,7 @@
              (printf "  (define lib-dir ~s)\n" (dir: 'librkt))
              (printf "  (define include-dir ~s)\n" (dir: 'includerkt))
              (printf "  (define bin-dir ~s)\n" (dir: 'bin))
+             (printf "  (define man-dir ~s)\n" (dir: 'man))
              (printf "  (define absolute-installation? #t))\n")))
          ;; recompile & set times as if nothing happened (don't remove .dep)
          ;; this requires the file to look the same on all compilations, and