1: ;;;
    2: ;;; install - Generic installation utility
    3: ;;;  
    4: ;;;   Copyright (c) 2004-2006 Shiro Kawai, All rights reserved.
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;;  $Id: gauche-install.in,v 1.3 2006/04/07 21:33:45 shirok Exp $
   34: ;;;
   35: 
   36: ;; This is intended to replace 'install' program, in order to avoid
   37: ;; variations of system's install program.  Although most 'install'
   38: ;; programs have various extensions, we can't reliably use those
   39: ;; extended features since we don't know such extended install program
   40: ;; is avilable on the target system.  Assuming minimum featured install
   41: ;; program makes makefile messy.
   42: 
   43: (use srfi-1)
   44: (use srfi-2)
   45: (use gauche.parseopt)
   46: (use gauche.parameter)
   47: (use file.util)
   48: 
   49: (define (p . args) (for-each print args))
   50: 
   51: (define (usage)
   52:   (p "Usage: gauche-install [options] file dest             (1st format)"
   53:      "       gauche-install [options] file ... directory    (2nd format)"
   54:      "       gauche-install -d [options] directory ...      (3rd format)"
   55:      "       gauche-install -T directory [options] file ... (4th format)"
   56:      "       gauche-install -U directory [options] file ... (5th format)"
   57:      "Options:"
   58:      "  -T, --target=DIR  : installs files to the DIR, creating paths if needed."
   59:      "                      Partial path of files are preserved. (4th format only)"
   60:      "  -U, --uninstall=DIR : Reverse of -T, e.g. removes files from its"
   61:      "                      destination."
   62:      "  -S, --srcdir=DIR  : look for files within DIR; useful if VPATH is used"
   63:      "      --shebang=PATH : adds #!PATH before the file contents."
   64:      "                       useful to install scripts."
   65:      "  -d, --directory   : creates directories.  (3rd format only)."
   66:      "  -m, --mode=MODE   : change mode of the installed file."
   67:      "  -o, --owner=OWNER : change owner of the installed file (root only)."
   68:      "  -g, --group=GROUP : change owner of the installed file (root only)."
   69:      "  -v, --verbose     : work verbosely"
   70:      "  -n, --dry-run     : just prints what actions to be done."
   71:      )
   72:   (exit 0))
   73: 
   74: (define verbose (make-parameter #f))
   75: (define dry-run (make-parameter #f))
   76: 
   77: (define-syntax do-it
   78:   (syntax-rules ()
   79:     ((_ mesg . actions)
   80:      (begin (when (and (verbose) mesg) (print mesg))
   81:             (unless (dry-run) . actions)))))
   82: 
   83: (define (app-errorf fmt msg)
   84:   (format (current-error-port) fmt msg)
   85:   (newline (current-error-port))
   86:   (exit 1))
   87: 
   88: (define (ensure-directory path . args)
   89:   (if (file-exists? path)
   90:     (unless (file-is-directory? path)
   91:       (app-errorf "non-directory file gets in my way: ~s" path))
   92:     (let-optionals* args ((mode #f)
   93:                           (owner #f)
   94:                           (group #f))
   95:       (do-it #`"creating directory ,path"
   96:              (guard (e (else (app-errorf "can't create directory: ~s"
   97:                                          (ref e 'message))))
   98:                (when (make-directory* path)
   99:                  (when mode (sys-chmod path mode))
  100:                  (when (or owner group)
  101:                    (sys-chown path
  102:                               (->ugid sys-user-name->uid owner "user")
  103:                               (->ugid sys-group-name->gid group "group")))))
  104:              ))))
  105: 
  106: ;; user/group -> uid/gid
  107: (define (->ugid str->id arg type)
  108:   (cond ((not arg) -1)
  109:         ((integer? arg) arg)
  110:         ((and (string? arg) (str->id arg)))
  111:         (else (app-errorf #`"bad ,type name: ~a" arg))))
  112: 
  113: ;; find source path
  114: (define (ensure-src file srcdir)
  115:   (or (and-let* ((srcdir)
  116:                  (srcpath (build-path srcdir file))
  117:                  ((file-exists? srcpath)))
  118:         srcpath)
  119:       file))
  120: 
  121: ;; copy, possibly with appending prelude
  122: (define (cp src dest prelude)
  123:   (if prelude
  124:     (receive (out name) (sys-mkstemp src)
  125:       (display prelude out)
  126:       (call-with-input-file src
  127:         (lambda (in)
  128:           (copy-port in out :unit 65536)))
  129:       (close-output-port out)
  130:       (move-file name dest :if-exists :supersede))
  131:     (copy-file src dest :if-exists :supersede :safe #t)))
  132: 
  133: ;; standard install
  134: (define (install src dest prelude mode owner group)
  135:   (do-it #`"installing ,src to ,dest"
  136:          (and (cp src dest prelude)
  137:               (sys-chmod dest mode)
  138:               (when (or owner group)
  139:                 (sys-chown dest
  140:                            (->ugid sys-user-name->uid owner "user")
  141:                            (->ugid sys-group-name->gid group "group"))))))
  142: 
  143: 
  144: ;; Entry point
  145: (define (main args)
  146:   (let-args (cdr args)
  147:       ((#f      "c")        ;; ignore for historical reason
  148:        (mkdir   "d|directory")
  149:        (mode    "m|mode=s" #o755 => (cut string->number <> 8))
  150:        (owner   "o|owner=s")
  151:        (group   "g|group=s")
  152:        (srcdir  "S|srcdir=s")
  153:        (target  "T|target=s")
  154:        (utarget "U|uninstall=s")
  155:        (shebang "shebang=s")
  156:        (verb    "v")
  157:        (dry     "n|dry-run")
  158:        (#f      "h|help" => usage)
  159:        (else (opt . _) (print "Unknown option : " opt) (usage))
  160:        . args)
  161: 
  162:     (parameterize ((verbose (or verb dry))
  163:                    (dry-run dry))
  164:       (when shebang (set! shebang #`"#!,shebang\n"))
  165:       (cond
  166:        (mkdir  (for-each (cut ensure-directory <> mode owner group) args))
  167:        (target (for-each (lambda (src)
  168:                            (let1 dst (build-path target src)
  169:                              (ensure-directory (sys-dirname dst))
  170:                              (install (ensure-src src srcdir) dst
  171:                                       shebang mode owner group)))
  172:                          args))
  173:        (utarget (for-each (lambda (src)
  174:                             (sys-unlink (build-path utarget src)))
  175:                           args))
  176:        (else
  177:         (case (length args)
  178:           ((0) (usage))
  179:           ((1) #f)          ;; no-op
  180:           ((2) ;; file to file or file to dir
  181:            (let* ((src (car args))
  182:                   (dst (if (file-is-directory? (cadr args))
  183:                          (build-path (cadr args) (sys-basename src))
  184:                          (cadr args))))
  185:              (ensure-directory (sys-dirname dst))
  186:              (install (ensure-src src srcdir) dst
  187:                       shebang mode owner group)))
  188:           (else
  189:            (let ((target (car (last-pair args))))
  190:              (for-each (lambda (src)
  191:                          (let1 dst (build-path target (sys-basename src))
  192:                            (ensure-directory (sys-dirname dst))
  193:                            (install (ensure-src src srcdir) dst
  194:                                     shebang mode owner group)))
  195:                        (drop-right args 1)))))))
  196:       ))
  197:   0)
  198: 
  199: ;; Local variables:
  200: ;; mode: scheme
  201: ;; end: