pkg/dirs-catalog added

This utility that is needed by `make` turns out to be useful in other
scripts.

Makefile

@@ -99,7 +99,7 @@ error-need-prefix:
 LOC_CATALOG = build/local/pkgs-catalog
 
 local-catalog:
-	"$(DESTDIR)$(PREFIX)/bin/racket" racket/src/pkgs-catalog.rkt $(LOC_CATALOG) pkgs
+	"$(DESTDIR)$(PREFIX)/bin/racket" -l- pkg/dirs-catalog --check-metadata $(LOC_CATALOG) pkgs
 	"$(DESTDIR)$(PREFIX)/bin/raco" pkg catalog-copy --force --from-config $(LOC_CATALOG) $(UNIX_CATALOG)
 
 # ------------------------------------------------------------
@@ -287,7 +287,7 @@ WIN32_BUNDLE_RACO = bundle\racket\racket $(BUNDLE_RACO_FLAGS)
 # ------------------------------------------------------------
 # Linking all packages (development mode; not an installer build)
 
-PKGS_CATALOG = -U -G build/config racket/src/pkgs-catalog.rkt --link
+PKGS_CATALOG = -U -G build/config -l- pkg/dirs-catalog --link --check-metadata
 PKGS_CONFIG = -U -G build/config racket/src/pkgs-config.rkt
 
 pkgs-catalog:

pkgs/racket-pkgs/racket-doc/pkg/scribblings/apis.scrbl

@@ -50,3 +50,4 @@ to the @exec{raco pkg} sub-subcommands.
 @include-section["path.scrbl"]
 @include-section["name.scrbl"]
 @include-section["db.scrbl"]
+@include-section["dirs-catalog.scrbl"]

pkgs/racket-pkgs/racket-doc/pkg/scribblings/dirs-catalog.scrbl

@@ -0,0 +1,59 @@
+#lang scribble/manual
+@(require "common.rkt"
+          scribble/bnf
+          (for-label pkg/dirs-catalog
+                     racket/base
+                     racket/contract/base))
+
+@title[#:tag "dirs-catalog"]{Package Directories Catalog}
+
+@defmodule[pkg/dirs-catalog]{The @racketmodname[pkg/dirs-catalog] module
+provides @racket[create-dirs-catalog], which generates a @tech{package
+catalog} (as a directory) that refers to a set of packages that are
+found in a given set of directories. Packages are discovered in the
+given directory as subdirectories that have an @filepath{info.rkt}
+file.}
+
+For example, the main Racket development repository includes a
+@filepath{pkgs} directory that holds packages such as @pkgname{base},
+and @racket[create-dirs-catalog] constructs a catalog to be used to
+install those packages.
+
+When run directly as a program, @racketmodname[pkg/dirs-catalog] expects a
+destination catalog followed by any number paths for directories that
+hold packages:
+
+@commandline{racket -l- pkg/dirs-catalog @nonterm{dest-catalog} @nonterm{dir} ...}
+
+The @DFlag{link}, @DFlag{merge}, @DFlag{check-metadata}, and
+@DFlag{quiet} flags correspond to optional keyword arguments of
+@racket[create-dirs-catalog].
+
+@history[#:added "6.1.1.6"]
+
+@defproc[(create-dirs-catalog [catalog-path path-string?]
+                              [dirs (listof path-string?)]
+                              [#:link? link? any/c #f]
+                              [#:merge? merge? any/c #f]
+                              [#:check-metadata? check-metadata? any/c #f]
+                              [#:status-printf status-printf (string? any/c ... -> void?) void])
+           void?]{
+
+Creates or modifies @racket[catalog-path] as a directory that works as
+a catalog (see @secref["catalog-protocol"]) to list the packages that
+are contained in each directory specified by @racket[dirs]. Packages
+are discovered in @racket[dirs] as subdirectories that have an
+@filepath{info.rkt} file.
+
+If @racket[link?] is true, then the catalog specifies that the package
+should be installed as a directory link, as opposed to copies.
+
+If @racket[merge?] is true, then existing catalog entries in
+@racket[catalog-path] are preserved, otherwise old catalog entries are
+removed.
+
+To create author and description information for each package in the
+catalog, @racket[create-dirs-catalog] looks for a @racket[pkg-authors]
+and @racket[pkg-desc] definition in each package's @filepath{info.rkt}
+file. If either definition is missing and @racket[check-metadata?] is
+true, an error is reported.}

racket/collects/pkg/dirs-catalog.rkt

@@ -0,0 +1,162 @@
+#lang racket/base
+(require racket/cmdline
+         racket/file
+         racket/format
+         racket/string
+         racket/path
+         setup/getinfo
+         pkg/lib)
+
+;; Find packages in a directory tree, where "info.rkt" indicates a
+;; package, and create a catalog that points to those packages --- to
+;; be installed as links if `--link` is specified.
+
+(provide create-dirs-catalog)
+
+(module+ main
+  (define link? #f)
+  (define merge? #f)
+  (define check-metadata? #f)
+  (define quiet? #f)
+  
+  (command-line
+   #:once-each
+   ["--link" "Install packages as links"
+    (set! link? #t)]
+   ["--merge" "Preserve existing packages in catalog"
+    (set! merge? #t)]
+   ["--check-metadata" "Complain if metadata (author and description) is missing"
+    (set! check-metadata? #t)]
+   [("--quiet" "-q") "Avoid status printouts"
+    (set! quiet? #t)]
+   #:args
+   (catalog-path . dir)
+   (create-dirs-catalog catalog-path
+                        ;; a list:
+                        dir
+                        #:status-printf (if quiet? void printf)
+                        #:link? link?
+                        #:merge? merge?
+                        #:check-metadata? check-metadata?)))
+  
+(define (create-dirs-catalog catalog-path
+                             dirs
+                             #:status-printf [status-printf void]
+                             #:link? [link? #f]
+                             #:merge? [merge? #f]
+                             #:check-metadata? [check-metadata? #f])
+  ;; found: maps each available package name to a directory
+  (define found (make-hash))
+  
+  (status-printf "Finding packages\n")
+
+  ;; Recur through directory tree, and treat each directory
+  ;; that has an "info.rkt" file as a package (and don't recur
+  ;; further into the package)
+  (for ([src-dir (in-list dirs)])
+    (when (directory-exists? src-dir)
+      (let loop ([src-dir src-dir])
+        (for ([f (in-list (directory-list src-dir))])
+          (define src-f (build-path src-dir f))
+          (cond
+           [(file-exists? (build-path src-f "info.rkt"))
+            (define f-name (path->string f))
+            (when (hash-ref found f-name #f)
+              (error 'pack-local 
+                     "found package ~a multiple times: ~a and ~a"
+                     f-name
+                     (hash-ref found f-name)
+                     src-f))
+            (hash-set! found f-name src-f)]
+           [(directory-exists? src-f)
+            (loop src-f)])))))
+
+  (unless merge?
+    (when (directory-exists? (build-path catalog-path "pkg"))
+      (for ([l (directory-list (build-path catalog-path "pkg"))])
+        (unless (hash-ref found (path->string l) #f)
+          (status-printf " Uncataloging package ~a\n" (path->string l))
+          (delete-directory/files (build-path catalog-path "pkg" l))))))
+  
+  (define metadata-ns (make-base-namespace))
+  (define (get-pkg-info pkg-dir)
+    (get-info/full pkg-dir
+                   #:namespace metadata-ns
+                   #:bootstrap? #t))
+
+  (define missing-desc null)
+  (define missing-authors null)
+
+  (define (relative-path->relative-url p)
+    (apply ~a #:separator "/"
+           (map (lambda (e)
+                  (case e
+                    [(up) ".."]
+                    [(same) "."]
+                    [else (path-element->string e) e]))
+                (explode-path p))))
+
+  (for ([(pkg-name dir) (in-hash found)])
+    (define i (get-pkg-info dir))
+    (define deps
+      (extract-pkg-dependencies i))
+    (define desc (i 'pkg-desc (lambda _ #f)))
+    (unless (string? desc)
+      (set! missing-desc (cons pkg-name missing-desc)))
+    (define authors (i 'pkg-authors (lambda _ null)))
+    (unless (and (list? authors)
+                 ((length authors) . >= . 1))
+      (set! missing-authors (cons pkg-name missing-authors)))
+    (define pkg
+      `#hash((name . ,pkg-name)
+             (source . ,(string-append
+                         (relative-path->relative-url
+                          (find-relative-path (simple-form-path
+                                               (path->complete-path catalog-path))
+                                              (simple-form-path
+                                               (path->complete-path dir))))
+                         (if link?
+                             "?type=static-link"
+                             "")))
+             (author . ,(string-join (for/list ([r authors])
+                                       (if (symbol? r)
+                                           (format "~a@racket-lang.org" r)
+                                           r))
+                                     " "))
+             (checksum . "")
+             (description . ,(or desc "???"))
+             (tags . ())
+             (dependencies . ,deps)
+             (modules . ,(pkg-directory->module-paths
+                          dir
+                          pkg-name
+                          #:namespace metadata-ns))))
+    (define pkg-file (build-path catalog-path "pkg" pkg-name))
+    (define exists? (file-exists? pkg-file))
+    (cond
+     [(and exists?
+           (equal? (with-handlers ([exn:fail:read? void])
+                     (call-with-input-file* pkg-file read))
+                   pkg))
+      ;; No change
+      (void)]
+     [else
+      (status-printf " ~aataloging package ~a\n"
+                     (if exists? "Rec" "C")
+                     pkg-name)
+      (make-directory* (build-path catalog-path "pkg"))
+      (call-with-output-file*
+       pkg-file
+       #:exists 'truncate/replace
+       (lambda (o)
+         (write pkg o)
+         (newline o)))]))
+
+  (for ([p (in-list missing-desc)])
+    (status-printf "Missing package description for ~a\n" p))
+  (for ([p (in-list missing-authors)])
+    (status-printf "Missing package authors for ~a\n" p))
+
+  (when check-metadata?
+    (unless (and (null? missing-authors) (null? missing-desc))
+      (error 'link-all "not all packages have description and authors."))))

racket/src/pkgs-catalog.rkt

@@ -1,139 +0,0 @@
-#lang racket/base
-(require racket/cmdline
-         racket/file
-         racket/format
-         racket/string
-         racket/path
-         setup/getinfo
-         pkg/lib)
-
-;; Find packages in a directory tree ("info.rkt" indicates a package),
-;; create a catalog that points to those packages --- to be installed as
-;; links if `--link` is specified.
-
-;; Used by the top-level Makefile in the main Racket repository.
-
-(define link? #f)
-
-(define-values (catalog-path dirs)
-  (command-line
-   #:once-each
-   ["--link" "Install packages as links"
-    (set! link? #t)]
-   #:args
-   (catalog-path . dir)
-   (values catalog-path dir)))
-
-;; found: maps each available package name to a directory
-(define found (make-hash))
-
-(printf "Finding packages\n")
-
-;; Recur through directory tree, and treat each directory
-;; that has an "info.rkt" file as a package (and don't recur
-;; further into the package)
-(for ([src-dir (in-list dirs)])
-  (when (directory-exists? src-dir)
-    (let loop ([src-dir src-dir])
-      (for ([f (in-list (directory-list src-dir))])
-        (define src-f (build-path src-dir f))
-        (cond
-         [(file-exists? (build-path src-f "info.rkt"))
-          (define f-name (path->string f))
-          (when (hash-ref found f-name #f)
-            (error 'pack-local 
-                   "found package ~a multiple times: ~a and ~a"
-                   f-name
-                   (hash-ref found f-name)
-                   src-f))
-          (hash-set! found f-name src-f)]
-         [(directory-exists? src-f)
-          (loop src-f)])))))
-
-(when (directory-exists? (build-path catalog-path "pkg"))
-  (for ([l (directory-list (build-path catalog-path "pkg"))])
-    (unless (hash-ref found (path->string l) #f)
-      (printf " Uncataloging package ~a\n" (path->string l))
-      (delete-directory/files (build-path catalog-path "pkg" l)))))
-
-(define metadata-ns (make-base-namespace))
-(define (get-pkg-info pkg-dir)
-  (get-info/full pkg-dir
-                 #:namespace metadata-ns
-                 #:bootstrap? #t))
-
-(define missing-desc null)
-(define missing-authors null)
-
-(define (relative-path->relative-url p)
-  (apply ~a #:separator "/"
-         (map (lambda (e)
-                (case e
-                  [(up) ".."]
-                  [(same) "."]
-                  [else (path-element->string e) e]))
-              (explode-path p))))
-
-(for ([(pkg-name dir) (in-hash found)])
-  (define i (get-pkg-info dir))
-  (define deps
-    (extract-pkg-dependencies i))
-  (define desc (i 'pkg-desc (lambda _ #f)))
-  (unless (string? desc)
-    (set! missing-desc (cons pkg-name missing-desc)))
-  (define authors (i 'pkg-authors (lambda _ null)))
-  (unless (and (list? authors)
-               ((length authors) . >= . 1))
-    (set! missing-authors (cons pkg-name missing-authors)))
-  (define pkg
-    `#hash((name . ,pkg-name)
-           (source . ,(string-append
-                       (relative-path->relative-url
-                        (find-relative-path (simple-form-path
-                                             (path->complete-path catalog-path))
-                                            (simple-form-path
-                                             (path->complete-path dir))))
-                       (if link?
-                           "?type=static-link"
-                           "")))
-           (author . ,(string-join (for/list ([r authors])
-                                     (if (symbol? r)
-                                         (format "~a@racket-lang.org" r)
-                                         r))
-                                   " "))
-           (checksum . "")
-           (description . ,(or desc "???"))
-           (tags . ())
-           (dependencies . ,deps)
-           (modules . ,(pkg-directory->module-paths
-                        dir
-                        pkg-name
-                        #:namespace metadata-ns))))
-  (define pkg-file (build-path catalog-path "pkg" pkg-name))
-  (define exists? (file-exists? pkg-file))
-  (cond
-   [(and exists?
-         (equal? (with-handlers ([exn:fail:read? void])
-                   (call-with-input-file* pkg-file read))
-                 pkg))
-    ;; No change
-    (void)]
-   [else
-    (printf " ~aataloging package ~a\n"
-            (if exists? "Rec" "C")
-            pkg-name)
-    (make-directory* (build-path catalog-path "pkg"))
-    (call-with-output-file*
-     pkg-file
-     #:exists 'truncate/replace
-     (lambda (o)
-       (write pkg o)
-       (newline o)))]))
-
-(for ([p (in-list missing-desc)])
-  (printf "Missing package description for ~a\n" p))
-(for ([p (in-list missing-authors)])
-  (printf "Missing package authors for ~a\n" p))
-
-(unless (and (null? missing-authors) (null? missing-desc))
-  (error 'link-all "not all packages have description and authors."))