#!/usr/local/bin/gosh
;;;
;;; install - Generic installation utility
;;;
;;;   Copyright (c) 2004-2012  Shiro Kawai  <shiro@acm.org>
;;;
;;;   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.
;;;

;; This is intended to replace 'install' program, in order to avoid
;; variations of system's install program.  Although most 'install'
;; programs have various extensions, we can't reliably use those
;; extended features since we don't know such extended install program
;; is avilable on the target system.  Assuming minimum featured install
;; program makes makefile messy.

(use srfi-1)
(use srfi-2)
(use srfi-13)
(use gauche.parseopt)
(use gauche.parameter)
(use file.util)
(use util.list)
(use util.match)

(define (p . args) (for-each print args))

(define (usage)
  (p "Usage: gauche-install [options] file dest             (1st format*)"
     "       gauche-install [options] file ... directory    (2nd format*)"
     "       gauche-install -d [options] directory ...      (3rd format*)"
     "       gauche-install -T directory [options] file ... (4th format)"
     "       gauche-install -U directory [options] file ... (5th format)"
     "(*: 1st,2nd and 3rd format are compatible with BSD install)"
     "Options:"
     "  -C, --canonical-suffix : If installed file has a suffix *.sci, replace"
     "                      it for *.scm.   This is Gauche specific convention."
     "  -T, --target=DIR  : Installs files to the DIR, creating paths if needed."
     "                      Partial path of files are preserved. (4th format only)"
     "  -U, --uninstall=DIR : Reverse of -T, e.g. removes files from its"
     "                      destination."
     "  -S, --srcdir=DIR  : Look for files within DIR; useful if VPATH is used"
     "      --shebang=PATH : Adds #!PATH before the file contents."
     "                       Useful to install scripts."
     "  -d, --directory   : Creates directories.  (3rd format only)."
     "  -m, --mode=MODE   : Change mode of the installed file."
     "  -p, --strip-prefix=PREFIX : Strip prefix dirs from FILEs before "
     "                      installation. (4th/5th format only)."
     "  -o, --owner=OWNER : Change owner of the installed file(s)."
     "  -g, --group=GROUP : Change group of the installed file(s)."
     "  -v, --verbose     : Work verbosely"
     "  -n, --dry-run     : Just prints what actions to be done."
     )
  (exit 0))

(define verbose (make-parameter #f))
(define dry-run (make-parameter #f))

(define-syntax do-it
  (syntax-rules ()
    [(_ mesg . actions)
     (begin (when (and (verbose) mesg) (print mesg))
            (unless (dry-run) . actions))]))

(define (ensure-directory path :optional (mode #f) (owner #f) (group #f))
  (if (file-exists? path)
    (unless (file-is-directory? path)
      (exit 1 "gauche-install: non-directory file gets in my way: ~s" path))
    (do-it #`"creating directory ,path"
           (guard (e [else (exit 1 "can't create directory: ~s"
                                 (ref e 'message))])
             (when (make-directory* path)
               (when mode (sys-chmod path mode))
               (when (or owner group)
                 (sys-chown path
                            (->ugid sys-user-name->uid owner "user")
                            (->ugid sys-group-name->gid group "group")))))
           )))

;; user/group -> uid/gid
(define (->ugid str->id arg type)
  (cond [(not arg) -1]
        [(integer? arg) arg]
        [(and (string? arg) (str->id arg))]
        [else (exit 1 "bad ~a name: ~a" type arg)]))

;; find source path
(define (ensure-src file srcdir)
  (or (and-let* ([ srcdir ]
                 [srcpath (build-path srcdir file)]
                 [ (file-exists? srcpath) ])
        srcpath)
      file))

;; copy, possibly with appending prelude
(define (cp src dest prelude)
  (if prelude
    (receive (out name) (sys-mkstemp src)
      (display prelude out)
      (call-with-input-file src (cut copy-port <> out :unit 65536))
      (close-output-port out)
      (move-file name dest :if-exists :supersede))
    (copy-file src dest :if-exists :supersede :safe #t)))

;; standard install
(define (install src dest prelude mode owner group canonical?)
  (ensure-directory (sys-dirname dest))
  (do-it #`"installing ,src to ,dest"
         (and (cp src dest prelude)
              (sys-chmod dest mode)
              (begin
                (when (or owner group)
                  (sys-chown dest
                             (->ugid sys-user-name->uid owner "user")
                             (->ugid sys-group-name->gid group "group")))
                (when (and canonical? (string-suffix? ".sci" dest))
                  (sys-rename dest (path-swap-extension dest "scm")))))))

;; strip PREFIX from path if possible.
(define (strip-dir prefix path)
  (cond
   [(not prefix) path]
   [(eq? prefix #t) (sys-basename path)]
   [else
    (let1 pre (if (#/[\/\\]$/ prefix) prefix (string-append prefix "/"))
      (if (string-prefix? pre path)
        (string-drop path (string-length pre))
        path))]))

;; Entry point
(define (main args)
  (let-args (cdr args)
      ([#f      "c"]        ;; ignore for historical reason
       [mkdir   "d|directory"]
       [mode    "m|mode=s" #o755 => (cut string->number <> 8)]
       [owner   "o|owner=s"]
       [group   "g|group=s"]
       [csfx    "C|canonical-suffix"]
       [srcdir  "S|srcdir=s"]
       [target  "T|target=s"]
       [utarget "U|uninstall=s"]
       [shebang "shebang=s"]
       [verb    "v"]
       [dry     "n|dry-run"]
       [sprefix "p|strip-prefix=s"]
       [#f      "h|help" => usage]
       [else (opt . _) (print "Unknown option : " opt) (usage)]
       . args)

    (parameterize ([verbose (or verb dry)]
                   [dry-run dry])
      (when shebang (set! shebang #`"#!,shebang\n"))
      (cond
       [mkdir  (for-each (cut ensure-directory <> mode owner group) args)]
       [target (dolist [src args]
                 (install (ensure-src src srcdir)
                          (build-path target (strip-dir sprefix src))
                          shebang mode owner group csfx))]
       [utarget (dolist [src args]
                  (sys-unlink (build-path utarget (strip-dir sprefix src))))]
       [else
        (match args
          [() (usage)]
          [(_) #f]                      ; no op
          [(src dst)                    ; file to file or file to dir
           (install (ensure-src src srcdir)
                    (if (file-is-directory? (cadr args))
                      (build-path (cadr args) (sys-basename src))
                      (cadr args))
                    shebang mode owner group csfx)]
          [(args ...)
           (let1 target (car (last-pair args))
             (dolist [src (drop-right args 1)]
               (install (ensure-src src srcdir)
                        (build-path target (sys-basename src))
                        shebang mode owner group csfx)))]
          )])))
  0)

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