#!/usr/bin/gosh
;;;
;;; gauche-package - Gauche package builder/manager
;;;  
;;;   Copyright (c) 2004 Shiro Kawai, All rights reserved.
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;  
;;;  $Id: gauche-package.in,v 1.7 2004/05/16 20:40:27 shirok Exp $
;;;

(use srfi-1)
(use srfi-13)
(use gauche.parseopt)
(use gauche.version)
(use gauche.package)
(use gauche.package.build)
(use gauche.package.fetch)
(use gauche.collection)
(use file.util)
(use util.list)

(define *commands* '())
(define *helps* '())

(define (usage . maybe-command)
  (let ((cmd (get-optional maybe-command #f)))
    (if cmd
      (cond ((assoc-ref *helps* cmd)
             => (lambda (doc)
                  (print "Usage: gauche-package " (car doc)) ;; synopsys
                  (print "  " (cadr doc)) ;; summary
                  (unless (null? (cddr doc)) (print (caddr doc)))))
            (else
             (print "Unknown command name: " cmd)
             (print "Valid commands are: " (map car (reverse *helps*)))))
      (begin
        (print "Usage: gauche-package <command> [options] <args> ...")
        (print "Commands:")
        (dolist (help (reverse *helps*))
          (format #t "  ~15a - ~a\n" (car help) (caddr help)))
        (print "Type 'gauche-package help <command>' for detailed help of each command."))))
  (exit 0))

(define (app-error fmt . args)
  (apply format #t fmt args)
  (newline)
  (exit 0))

(define *config* '())

(define (read-config)
  (let ((config-file (build-path (home-directory) ".gauche-package")))
    (when (file-is-readable? config-file)
      (set! *config* (with-input-from-file config-file read)))
    (dolist (p *config*)
      (when (eq? (car p) 'build-dir)
        (set! (cdr p) (expand-path (cdr p))))))
  )

(define (main args)
  (read-config)
  (cond ((null? (cdr args)) (usage))
        ((assoc-ref *commands* (cadr args)) => (cut <> (cddr args)))
        (else (print "Unknown command: " (cadr args))
              (usage)))
  0)

;;======================================================
;; Command definitions
;;

(define-macro (define-cmd name doc . body)
  `(begin
     (push! *helps* (cons ,name ',doc)) ; doc : (<synopsys> <summary> <detail>)
     (push! *commands* (cons ,name
                             (lambda (args)
                               (let ((usage-self (lambda () (usage ,name))))
                                 ,@body))))))

;;------------------------------------------------------
;; install
;;
(define-cmd "install"
  ("install [options] <tarball-path/url>"
   "Fetch, extract, configure, make & install"
   "Argument:
  a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  of a tarball.
Options:
  -n, --dry-run   : shows commands to be executed, without running them.
  -C, --configure-options=<options>
                  : pass <options> to ./configure.  overrides -r.
  -r, --reconfigure
                  : uses the same configure options as before
      --clean     : clean up the build directory after installation
  -S, --install-as=<user> : sudo to <user> when installing")
  (let-args args ((dry-run "n|dry-run")
                  (copts   "C|configure-options=s" #f)
                  (reconf  "r|reconfigure")
                  (clean   "clean")
                  (sudo    "S|install-as=s" #f)
                  . args)
    (unless (= (length args) 1) (usage-self))
    (gauche-package-build (car args)
                          :config *config*
                          :dry-run dry-run :install #t :clean clean
                          :sudo-install sudo
                          :reconfigure reconf
                          :configure-options copts)))

;;------------------------------------------------------
;; build
;;
(define-cmd "build"
  ("build [options] <tarball-path/url>"
   "Fetch, extract, configure & make"
   "Argument:
  a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  of a tarball.
Options:
  -n, --dry-run   : shows commands to be executed, without running them.
  -C, --configure-options=<options>
                  : pass <options> to ./configure.  overrides -r.
  -r, --reconfigure
                  : uses the same configure options as before")
  (let-args args ((dry-run "n|dry-run")
                  (copts   "C|configure-options=s" #f)
                  (reconf  "r|reconfigure")
                  . args)
    (unless (= (length args) 1) (usage-self))
    (gauche-package-build (car args)
                          :config *config*
                          :dry-run dry-run
                          :reconfigure reconf
                          :configure-options copts)))

;;------------------------------------------------------
;; reconfigure
;;
(define-cmd "reconfigure"
  ("configure-options <package>"
   "Show configure options of <package>"
   "Argument: a package name.
  If the package has installed .gpd (Gauche package description) file, show
  the options to the configure script when the package is built.")
  (unless (= (length args) 1) (usage-self))
  (let1 gpd (find-gauche-package-description (car args) :all-versions #t)
    (if gpd
      (print (ref gpd 'configure))
      (print ";; I don't know about package " (car args)))))

;;------------------------------------------------------
;; list
;;
(define-cmd "list"
  ("list"
   "List known installed packages"
   "Shows installed packages.  Only packages that have .gpd file are listed.
Options:
  -a, --all    : shows all packages, even the ones that are installed for
                 other versions of Gauche.")
  (let-args args ((all?  "a|all"))
    (let1 gpds (map path->gauche-package-description
                    (gauche-package-description-paths :all-versions all?))
      (dolist (gpd (sort gpds
                         (lambda (a b)
                           (string<= (ref a 'name) (ref b 'name)))))
        (if (version=? (gauche-version) (ref gpd 'gauche-version))
          (format #t " ~19a ~8a~%" (ref gpd 'name) (ref gpd 'version))
          (when all?
            (format #t "(~19a ~8a for Gauche ~a)~%"
                    (ref gpd 'name) (ref gpd 'version)
                    (ref gpd 'gauche-version))))
        ))))

;;------------------------------------------------------
;; make-gpd
;;
(define-cmd "make-gpd"
  ("make-gpd <name> <param> ..."
   "Make gpd file (called from configure macro)")
  (when (null? args) (usage-self))
  (let loop ((p (cdr args))
             (r '()))
    (cond ((null? p)
           (let ((gpd (apply make <gauche-package-description>
                             :name (car args)
                             (reverse! r))))
             (with-output-to-file #`",(car args).gpd"
               (cut write-gauche-package-description gpd))))
          ((null? (cdr p))
           (app-error "gauche-package: make-gpd: parameter list not even"))
          (else
           (loop (cddr p)
                 (list* (cadr p)
                        (make-keyword (string-trim (car p) #[-:]))
                        r)))
          )))

;;------------------------------------------------------
;; help
;;

(define-cmd "help"
  ("help <command>"
   "Show detailed help of <command>")
  (apply usage args))

;; Local variables:
;; mode: scheme
;; end:
