(scripts make-module-catalog)
Thien-Thi Nguyen <[email protected]>
| Newsgroups | gmane.lisp.guile.user,gmane.lisp.guile.sources |
|---|---|
| Message-ID | <[email protected]> |
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 <[email protected]>
;;; 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
_______________________________________________
Guile-user mailing list
[email protected]
http://mail.gnu.org/mailman/listinfo/guile-user