#!/bin/sh
main='(module-ref (resolve-module '\''(scripts PROGRAM2)) '\'main')'
exec ${GUILE-guile} -l $0 -c "($main (command-line))" "$@"
!#
;;; PROGRAM2 --- 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 <hacker@random.node>

;;; Commentary:

;; Usage: PROGRAM2 [ARGS]
;;
;; PROGRAM2 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.  QOP handles these keys specially:
;;
;;  #:full-args   -- return the full arg list (similar to `command-line')
;;  #:parsed-full -- return the full results of `getopt-long' parsing
;;  #:parsed-opts -- similar to #:parsed-full but omit the '() entry
;;
;; 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 PROGRAM2 | sed s/PROGRAM2/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 PROGRAM2)        ; 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 `PROGRAM2' is useful from Scheme
            ;;      (also, add other useful exported procs here)
            ;; PROGRAM2
            ))


;; 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 ((eq? #:full-args key)   full-args)
                      ((eq? #:parsed-full key) parsed)
                      ((eq? #:parsed-opts key) (delete (assq '() parsed)
                                                       parsed))
                      ((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 (PROGRAM2/called-from-script-MAIN . args)
  ;; These args do not include invocation filename.
  ;; Example: invocation: ./PROGRAM2 1 2 3
  ;;                args: ("1" "2" "3")
  #t)

(define (PROGRAM2/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: ./PROGRAM2 1 2 3
  ;;                args: ("PROGRAM2" "1" "2" "3")
  ;;                eval: (object-property (car args) 'invocation-filename)
  ;;                        => "./PROGRAM2"
  #t)

(define (PROGRAM2/qop qop)
  #t)

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

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

;;; PROGRAM2 ends here
