module (scripts PROGRAM) that demos/supports new "guile -e" handling

[Thien-Thi Nguyen]

currently, executable modules invocation convention suffers from info
loss: unlike a C program's argv, the args that such a scheme program
sees are missing the invocation filename.  this makes it a chore (and
sometimes an impossibility) to infer that filename for source-based
reflective processing (such as extracting commentary).

in conjunction w/ the `-e "MODULE-NAME PROC-NAME"' patch recently
posted, the following module (scripts PROGRAM) both provides a new
stylized main procedure `HVQC-MAIN'[1] and demonstrates its use.

the code also provides `script-MAIN' for continuity, but that will go
away by guile 1.4.2 release (it won't be documentated either).  people
wishing to continue using the old methods anyway can use the "jam the
command-line" workaround:

#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
first='(set-car! (command-line) "'$0'")'
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
exec ${GUILE-guile} -l $0 -c "$first (apply $main (cdr (command-line)))" "$@"
!#

the `args' available through `script-MAIN' will still lack the
invocation filename, but at least it will be available through the
expression `(car (command-line))'.

thi


[1] Help Version Query-options Callback

___________________
#!/bin/sh
exec ${GUILE-guile} -e '(scripts PROGRAM)' -s $0 "$@" # -*- scheme -*-
!#
;;; PROGRAM --- Do something

;;      Copyright (C) 2002,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: J.R.Hacker <address@hidden>

;;; Commentary:

;; Usage: PROGRAM [ARGS]
;;
;; PROGRAM does nothing when invoked from the shell.
;; Optional arg "--version" means display version only.
;; Optional arg "--help" means display help only.
;;
;;
;; Usage from a Scheme program:
;;  (HVQC-MAIN args callback . config)
;;
;; This procedure abstracts "--help", "--version", getopt-long interaction
;; (using a "query op") and callback calling, in configurable ways.
;;
;; ARGS is a list of strings taken from the command line.  CALLBACK is a
;; procedure w/ one of two signatures depending on what CONFIG is.  CONFIG
;; is a list of key/value pairs for customizing behavior.  These keys are
;; recognized:
;;
;;  package     -- a string describing program affiliation (for "--version")
;;  version     -- a string to use instead of Guile's version
;;  usage       -- use instead of default usage message (a string is used
;;                 directly, the symbol `commentary' means extract usage info
;;                 from the program file's Commentary section, a thunk is
;;                 called for its string return value)
;;  option-spec -- a specification suitable for use w/ `getopt-long'
;;
;; If CONFIG includes `option-spec', pass ARGS and the specification to
;; `getopt-long', construct a closure QOP (query options) that encapsulates
;; the parse results, and do: (CALLBACK QOP).  QOP takes a key and an optional
;; proc; if the key results in a non-#f value, call PROC on that value (or
;; `identity' if no proc specified) and return the result.  If the key's value
;; is #f, QOP returns that.
;;
;; If CONFIG does not include `option-spec', do: (CALLBACK ARGS).
;;
;;
;; Usage for New Programs:
;;  (0) Read the friendly manual.
;;  (1) Figure out the name of the new script, say "my-prog".
;;  (2) $ guile-tools --source PROGRAM | sed s/PROGRAM/my-prog/g > my-prog
;;  (3) $ chmod +x my-prog
;;  (4) Edit my-prog to taste (don't miss the NB! notes).

;;; Code:

;; NB!: comment-in for debugging
;; (debug-enable 'debug 'backtrace)

(define-module (scripts PROGRAM)        ; NB! The module name need not include
                                        ; "scripts", but in any case make sure
                                        ; the name matches the argument to the
                                        ; "guile -e" switch, above.

  ;; NB!: comment-in and remove the spaces around the G
  ;; :autoload (scripts PRO G RAM) (HVQC-MAIN)

  ;; NB!: delete these two autoloads
  :autoload (ice-9 getopt-long) (getopt-long)
  :autoload (ice-9 documentation) (file-commentary)

  :export (;; NB!: delete these two exported procs
           HVQC-MAIN
           script-MAIN
           ;; NB!: comment-in if proc `PROGRAM' is useful from Scheme
           ;;      (also, add other useful exported procs here)
           ;; PROGRAM
           ))


;; NB!: delete everything following this line except `main'

(define (hvqc invocation-filename full-args callback w/args config)
  (let ((name (car full-args))
        (args (cdr full-args)))
    (cond

     ;; --help
     ((and (not (null? args))
           (string=? (car args) "--help"))
      (let ((where (assq-ref config 'usage)))
        (display (cond ((eq? 'commentary where)
                        (file-commentary (invocation-filename)))
                       ((thunk? where)
                        (where))
                       ((string? where)
                        where)
                       (else
                        (format #f "Usage: ~A [ARGS]\n" name)))))
      #t)

     ;; --version
     ((and (not (null? args))
           (string=? (car args) "--version"))
      (display (format #f "~A ~A\n"
                       (cond ((assq-ref config 'package)
                              => (lambda (package)
                                   (format #f "~A (~A)" name package)))
                             (else name))
                       (or (assq-ref config 'version)
                           (assq-ref %guile-build-info 'guileversion))))
      #t)

     ;; callback w/ qop
     ((assq-ref config 'option-spec)
      => (lambda (option-spec)
           (let ((parsed (getopt-long full-args option-spec)))
             (callback (lambda (key . proc)
                         (cond ((option-ref parsed key #f)
                                => (if (null? proc)
                                       identity
                                       (car proc)))
                               (else #f)))))))

     ;; callback w/ args
     (else
      (w/args)))))

(define (script-MAIN args name callback . config)
  (exit (hvqc (lambda ()
                (or (%search-load-path name)
                    (%search-load-path (format #f "scripts/~A" name))))
              (cons name args)
              callback
              (lambda () (apply callback args))
              config)))

(define (HVQC-MAIN args callback . config)
  (exit (let* ((base (basename (car args)))
               (full-args (cons base (cdr args))))
          (set-object-property! base 'invocation-filename (car args))
          (hvqc (lambda () (car args))
                full-args
                callback
                (lambda () (callback full-args))
                config))))

(define (PROGRAM/called-from-script-MAIN . args)
  ;; These args do not include invocation filename.
  ;; Example: invocation: ./PROGRAM 1 2 3
  ;;                args: ("1" "2" "3")
  #t)

(define (PROGRAM/called-from-HVQC-MAIN args)
  ;; These args include the basename of the invocation filename as the first
  ;; arg, which also has the full filename in property `invocation-filename'.
  ;; Example: invocation: ./PROGRAM 1 2 3
  ;;                args: ("PROGRAM" "1" "2" "3")
  ;;                eval: (object-property (car args) 'invocation-filename)
  ;;                        => "./PROGRAM"
  #t)

(define (PROGRAM/qop qop)
  #t)

(define (OLD-STYLE-main . args)
  (script-MAIN args
               "PROGRAM" PROGRAM/called-from-script-MAIN
               '(usage . commentary)
               '(package . "Guile")))

(define (main args)
  (HVQC-MAIN args PROGRAM/called-from-HVQC-MAIN
             '(usage . commentary)
             '(package . "Guile")))

;;; PROGRAM ends here