#!/bin/sh
main='(module-ref (resolve-module '\''(scripts scan-md-module)) '\'main')'
exec ${GUILE-guile} -l $0 -c "($main (command-line))" "$@"
!#
;;; scan-md-module --- Mine catalog info from machine-dependent module files

;;	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 <ttn@gnu.org>

;;; Commentary:

;; Usage: scan-md-module [--catalog] [FILE ...]
;;
;; Scan binary-module FILE... and display module information one per line.
;; By default the output format is the list:
;;
;;   (MODULE-NAME scm_init_module LINK-FUNC UPSTREAMS)
;;
;; Optional arg `--catalog' means to use format:
;;
;;   (MODULE-NAME scm_init_module LINK-FUNC UPSTREAMS . FILENAME)
;;
;; MODULE-NAME is a list of symbols.  LINK-FUNC is a string, the name of
;; the C function used to dynamically link the module (note that this is
;; different from the "module init function".  UPSTREAMS is a (possibly
;; empty) list of module names which must be completely loaded before
;; linking of this one can occur.  FILENAME is the same as FILE.
;;
;; If the scan is unsuccessful because the file's #:magic was not found,
;; the output is simply "#f".  If the #:magic was found but the file was
;; not recognized anyway, the output is list whose car is #f and the rest
;; of the elements unspecified.
;;
;;
;; Usage from Scheme:
;;
;;  (scan-md-module-file filename) => sexp
;;
;; SEXP has the default format described in the "Usage" section above.
;; To get a "--catalog" style result (presuming the scan is successful),
;; use `(append SEXP FILENAME)'.

;;; Code:

(define-module (scripts scan-md-module)
  #:autoload (scripts PROGRAM2) (HVQC-MAIN)
  #:autoload (scripts slurp) (slurp-file!)
  #:autoload (ice-9 md-data) (all-md-names)
  #:autoload (ice-9 popen) (open-input-pipe)
  #:autoload (ice-9 rdelim) (read-line)
  #:export (scan-md-module-file))

(define minimal-buf-size
  (let ((min-sz #f))
    (lambda ()
      (cond (min-sz)
            (else
             (for-each (lambda (name)
                         (set! min-sz
                               (max (or min-sz 0)
                                    (string-length
                                     (md-body-lookup (md-by-name name)
                                                     #:magic)))))
                       (all-md-names))
             min-sz)))))

(define sub make-shared-substring)

(define (scan-md-module-buf buf filename)

  (define (scan-binary-for-init)
    (let* ((infer (format #f "nm ~A | sed ~A~A~A~A"
                          filename
                          "'/scm_init_.*_module$/!d;'"
                          "'s/.*scm_init_//;'"
                          "'s/_module$//;'"
                          "'s/_/./g'"))
           (p (open-input-pipe infer))
           (init (read-line p)))
      (close-pipe p)
      init))

  (define (infer-module-name-from-binary init md-name)
    (let* ((p (open-input-pipe (format #f "strings ~A | sed ~A~A~A~A~A"
                                       filename
                                       "'/^'" init "'$/!d;'"
                                       "'s/^/(/;'"
                                       "'s/$/)/;'")))
           (name (read-line p)))
      (close-pipe p)
      (if (eof-object? name)
          (list #f 'unrecognized md-name)
          (list (with-input-from-string name read)
                'scm_init_module
                ;; init name
                (let loop ((dot (string-index init #\.)))
                  (if (not dot)
                      (format #f "scm_init_~A_module" init)
                      (begin
                        (string-set! init dot #\_)
                        (loop (string-index init #\. dot)))))
                ;; upstreams
                (let ((cmd (format #f "strings ~A | sed ~A~A"
                                   filename
                                   "'/^\\(.*\\)#_#_$/!d;'"
                                   "'s/....$//g;'")))
                  (set! p (open-input-pipe cmd))
                  (let loop ((line (read-line p)) (acc '()))
                    (if (eof-object? line)
                        (begin
                          (close-pipe p)
                          (map (lambda (s)
                                 (with-input-from-string s read))
                               acc))
                        (loop (read-line p) (cons line acc)))))))))

  (define (scan-md name)
    (and (let ((m (md-body-lookup (md-by-name name) #:magic)))
           (string=? m (sub buf 0 (string-length m))))
         (let ((init (scan-binary-for-init)))
           (if (eof-object? init)
               (list #f 'unrecognized name)
               (infer-module-name-from-binary init name)))))

  ;; do it
  (or-map scan-md (all-md-names)))

(define (scan-md-module-file filename)
  (let ((buf (make-string (minimal-buf-size))))
    (slurp-file! buf filename 0 (minimal-buf-size) 0)
    (scan-md-module-buf buf filename)))

(define (scan-md-module/qop qop)
  (for-each (lambda (file)
              (or (file-exists? file)
                  (error "no such file:" file))
              (let ((raw (scan-md-module-file file)))
                (write (if (qop 'catalog)
                           (and raw (append raw file))
                           raw)))
              (newline))
            (qop '())))

(define (main args)
  (HVQC-MAIN args scan-md-module/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (catalog))))

;;; scan-md-module ends here
