(scripts make-module-catalog)

[Thien-Thi Nguyen]

first, see SLIB and grok slibcat.  then, this will make more sense.
e.g., here is a frag from guile-1.4.x top-level Makefile.am:

install-data-hook:
  : [...snip...]
  ls -d $(DESTDIR)$(pkglibdir)/[0-9]* $(DESTDIR)$(pkgdatadir)/[0-9]* \
    | sed 's/^/-x /g' > TMP1
  $(DESTDIR)$(bindir)/guile -c '(for-each write-line %load-path)' \
    | sed '\,'$(prefix)',!d' > TMP2
  $(DESTDIR)$(bindir)/guile-tools make-module-catalog `cat TMP1 TMP2`
  rm -f TMP1 TMP2

(tabs replaced with two spaces.)  TMP1 holds excluded directories,
formatted as: "-x DIR".  these are the version-specific subdirs for
previously installed versions only -- other exclusions are done
automatically by make-module-catalog.  TMP2 holds all dirs in
`%load-path' that are under $(prefix).

see also (scripts slurp), recently posted.

thi

_________________________________
#!/bin/sh
exec ${GUILE-guile} -e '(scripts make-module-catalog)' -s $0 "$@" # -*- scheme 
-*-
!#
;;; make-module-catalog --- Create a .module-catalog file

;;      Copyright (C) 2003 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <address@hidden>

;;; Commentary:

;; Usage: make-module-catalog [OPTIONS] [DIR ...]
;;
;; Create a module catalog (named ".module-catalog") in each directory DIR.
;; A module catalog is an alist with module names (list of symbols) for the
;; key and CATALOG-INFO, described below, for the value.  OPTIONS are zero
;; or more of the following (defaults in square braces):
;;
;;  -v, --verbose      -- describe each file scanned
;;  -x, --exclude NAME -- do not scan NAME, which may be either a filename
;;                        or a directory name (also excludes children);
;;                        this option may be given multiple times
;;  -o, --output STEM  -- write to DIR/STEM [".module-catalog"]
;;  -b, --bufsize NUM  -- use NUM bytes for the scan buffer [256]
;;
;; Note that STEM may not include a directory component.  Also, the minimum
;; buffer size is 128; a specified NUM less than that is silently adjusted.
;;
;; Each catalog entry has the form:
;;
;;   (MODULE-NAME [KW1 ...] . FILENAME)
;;
;; MODULE-NAME is a list of symbols, such as: (scripts slurp).  KW1... are
;; zero or more symbols that indicate special-handling required (if any) for
;; the module.  Here is a list of symbols generated and their reason:
;;
;;   scm_init_module -- module is a dynamically loadable library that
;;                      follows the "scm_init_MODULE_NAME_module"
;;                      convention outlined in the Guile manual
;;
;; FILENAME is a string, the absolute path to the file that provides the
;; interface to the module.  (This file may also provide the definitions, or
;; implementation, of the module, although that is not required.)
;;
;; There are two special catalog entries whose keys are not module names:
;;
;;   **exclude**  -- list of subdirectories excluded from this catalog
;;   **version**  -- version of guile which produced this catalog
;;
;; The asterisks (*) are part of the symbol name.
;;
;;
;; Acknowledgements: The idea and style of the module catalog are directly
;;                   inspired by SLIB.  Thanks again, Aubrey Jaffer!
;;
;;
;; TODO: Factor bounded-space grep into its own module.
;;       Design/export Scheme module interface.

;;; Code:

(define-module (scripts make-module-catalog)
  :autoload (scripts PROGRAM) (HVQC-MAIN)
  :autoload (ice-9 ftw) (nftw)
  :autoload (scripts slurp) (slurp-file!)
  :autoload (ice-9 regex) (match:start match:end)
  :autoload (ice-9 rdelim) (read-line)
  :autoload (ice-9 popen) (open-input-pipe))

(define (make-scanner bufsize)
  (set! bufsize (max bufsize 128))
  (let ((buf (make-string bufsize))
        (rx (make-regexp "^\\(define-module *(\\([^()]*\\))" regexp/newline))
        (backtrack 64))                 ; suits rx
    ;; rv
    (lambda (dir filename statinfo flag)
      (cond ((not (eq? 'regular flag))
             (list #f flag))
            ((begin
               ;; slurp more than necessary to support the comparisons below
               (slurp-file! buf filename 0 8 0)
               (and (char=? #\177 (string-ref buf 0))
                    (string=? "ELF" (make-shared-substring buf 1 4))))
             (let* ((infer (format #f "nm ~A | sed ~A~A~A~A"
                                   filename
                                   "'/scm_init_.*_module$/!d;'"
                                   "'s/.*scm_init_/(/;'"
                                   "'s/_module$/)/;'"
                                   "'s/_/ /'"))
                    (p (open-input-pipe infer))
                    (line (read-line p)))
               (close-pipe p)
               (cond ((eof-object? line) (list #f 'unrecognized 'ELF))
                     (else (list (with-input-from-string line read)
                                 'scm_init_module)))))
            ((string=? "!<arch>" (make-shared-substring buf 0 7))
             (list #f 'ar-archive))
            ((and (char=? #\# (string-ref buf 0))
                  (not (char=? #\! (string-ref buf 1))))
             (list #f 'unixoid-text-config))
            ((let ((p (open-input-file filename))
                   (fsize (stat:size statinfo)))
               (let loop ((start 0))
                 (and start
                      (let* ((left (let ((diff (- (+ start bufsize) fsize)))
                                     (and (< 0 diff)
                                          (- fsize start))))
                             (fill (or left bufsize))
                             ;; We end-justify so that `regexp-exec' never
                             ;; sees the previous `buf' contents, saving us a
                             ;; defensive (and expensive) `string-fill!'.
                             (fpos (- bufsize fill)))
                        (slurp-file! buf p start fill fpos)
                        (or (regexp-exec rx buf fpos)
                            (loop (if left
                                      #f
                                      (+ start (- bufsize backtrack)))))))))
             => (lambda (m)
                  (list (with-input-from-string
                            (make-shared-substring
                             buf (match:start m 1) (match:end m 1))
                          read))))
            (else (list #f 'unrecognized))))))

(define (make-module-catalog options dir)
  (or (file-exists? dir) (error "no such file:" dir))
  (or (file-is-directory? dir) (error "not a directory:" dir))
  (let* ((fn (or (assq-ref options 'output) ".module-catalog"))
         (out (format #f "~A/~A" dir fn))
         (verbose (assq 'verbose options))
         (exclude (delete dir (or (assq-ref options 'exclude) '())))
         (cur (and (file-exists? out)
                   (let* ((out-mtime (stat:mtime (stat out)))
                          (p (open-input-file out))
                          (ls (read p))
                          (ht (make-hash-table 31)))
                     (close-port p)
                     (or (list? ls)
                         (error "bad file format: ~A" out))
                     (for-each (lambda (prev)
                                 (let* ((file (cdr (last-pair prev)))
                                        (mt (and file (string? file)
                                                 (file-exists? file)
                                                 (stat:mtime (stat file)))))
                                   (and mt (< mt out-mtime)
                                        (hash-set! ht file prev))))
                               ls)
                     ht)))
         (cat '())
         (scan (make-scanner (cond ((assq-ref options 'bufsize)
                                    => (lambda (s)
                                         (if (string? s)
                                             (string->number s)
                                             s)))
                                   (else 256))))
         (mask #f)
         (orphans '())
         (new 0) (ignored 0) (carried 0))
    (and (assq-ref options 'from-shell)
         (format #t "~A ~A\n" (if (file-exists? out)
                                  "Updating"
                                  "Making")
                 out))
    (nftw dir
          (lambda (filename statinfo flag base level)
            (let* ((xk? (let ((rv (and mask (> level mask)))) ; excluded kid
                          (and mask (not rv) (set! mask #f))
                          rv))
                   (res (cond (xk? (list #f 'child-of-excluded level))
                              ((and cur (hash-ref cur filename #f))
                               => (lambda (prev)
                                    (set! carried (1+ carried))
                                    (set! cat (cons prev cat))
                                    (list #f 'previously-scanned)))
                              ((and (not mask) (member filename exclude))
                               (and (eq? 'directory flag) (set! mask level))
                               (set! orphans (cons filename orphans))
                               (list #f 'excluded level))
                              (else
                               (scan dir filename statinfo flag)))))
              (cond ((car res)
                     (set! new (1+ new))
                     (set! cat (cons `(,@res . ,filename) cat)))
                    (else (set! ignored (1+ ignored))))
              (and verbose (format #t " ~A => ~A\n"
                                   filename (or (car res)
                                                (format #f "ignored ~A"
                                                        (cdr res))))))
            #t)                         ; keep going
          'physical)
    (let ((p (open-output-file out)))
      (format p ";;; ~A\n" out)
      (format p ";;; generated ~A UTC -- do not edit!\n\n"
              (strftime "%Y-%m-%d %H:%M:%S" (gmtime (current-time))))
      (format p "(\n")
      (for-each (lambda (x)
                  (cond ((equal? (car x) '(guile)))
                        ((equal? (car x) '(guile-user)))
                        (else (format p " ~S\n" x))))
                cat)
      (format p " ~S\n" (cons '**exclude** orphans))
      (format p " ~S\n" (cons '**version** (version)))
      (format p ")\n\n")
      (format p ";;; ~A ends here\n" out))
    (set! ignored (- ignored carried))
    (and (assq-ref options 'from-shell)
         (format #t " => Done ~A.\n"
                 `(,new new ,carried carried-over ,ignored ignored)))
    (list new carried ignored)))

(define (make-module-catalog/qop qop)
  (let* ((options '())
         (chk! (lambda (key)
                 (qop key (lambda (val)
                            (set! options (acons key val options)))))))
    (for-each chk! '(verbose output exclude bufsize))
    (qop 'output (lambda (name)
                   (and (string-index name #\/)
                        (error "cannot include directory:" name))))
    (cond ((assq 'exclude options)
           => (lambda (cell)
                (set-cdr! cell (append (qop '())
                                       (let ((cc (cdr cell)))
                                         (if (list? cc)
                                             cc
                                             (list cc)))))))
          (else (set! options (acons 'exclude (qop '()) options))))
    (set! options (acons 'from-shell #t options))
    (let ((do-it! (lambda (dir)
                    (make-module-catalog options dir))))
      (for-each do-it! (qop '())))))

(define (main args)
  (HVQC-MAIN
   args make-module-catalog/qop
   '(usage . commentary)
   '(package . "Guile")
   '(option-spec (verbose (single-char #\v))
                 (output  (single-char #\o) (value #t))
                 (exclude (single-char #\x) (value #t) (merge-multiple? #t))
                 (bufsize (single-char #\b) (value #t)))))

;;; make-module-catalog ends here