1: ;;;
    2: ;;; gauche-package - Gauche package builder/manager
    3: ;;;  
    4: ;;;   Copyright (c) 2004-2005 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-package.in,v 1.13 2005/09/04 09:22:43 shirok Exp $
   34: ;;;
   35: 
   36: (use srfi-1)
   37: (use srfi-13)
   38: (use gauche.parseopt)
   39: (use gauche.version)
   40: (use gauche.package)
   41: (use gauche.collection)
   42: (use file.util)
   43: (use file.filter)
   44: (use util.list)
   45: (use text.tr)
   46: 
   47: (autoload gauche.package.build
   48:           gauche-package-build)
   49: (autoload gauche.package.compile
   50:           gauche-package-compile-and-link
   51:           gauche-package-compile
   52:           gauche-package-link
   53:           gauche-package-clean)
   54: 
   55: (define *commands* '())
   56: (define *helps* '())
   57: 
   58: (define (usage . maybe-command)
   59:   (let ((cmd (get-optional maybe-command #f)))
   60:     (if cmd
   61:       (cond ((assoc-ref *helps* cmd)
   62:              => (lambda (doc)
   63:                   (print "Usage: gauche-package " (car doc)) ;; synopsys
   64:                   (print "  " (cadr doc)) ;; summary
   65:                   (unless (null? (cddr doc)) (print (caddr doc)))))
   66:             (else
   67:              (print "Unknown command name: " cmd)
   68:              (print "Valid commands are: " (map car (reverse *helps*)))))
   69:       (begin
   70:         (print "Usage: gauche-package <command> [options] <args> ...")
   71:         (print "Commands:")
   72:         (dolist (help (reverse *helps*))
   73:           (format #t "  ~15a - ~a\n" (car help) (caddr help)))
   74:         (print "Type 'gauche-package help <command>' for detailed help of each command."))))
   75:   (exit 0))
   76: 
   77: (define (app-error fmt . args)
   78:   (apply format #t fmt args)
   79:   (newline)
   80:   (exit 0))
   81: 
   82: (define *config* '())
   83: 
   84: (define (read-config)
   85:   (let ((config-file (build-path (home-directory) ".gauche-package")))
   86:     (when (file-is-readable? config-file)
   87:       (set! *config* (with-input-from-file config-file read)))
   88:     (dolist (p *config*)
   89:       (when (eq? (car p) 'build-dir)
   90:         (set! (cdr p) (expand-path (cdr p))))))
   91:   )
   92: 
   93: (define (main args)
   94:   (read-config)
   95:   (cond ((null? (cdr args)) (usage))
   96:         ((assoc-ref *commands* (cadr args)) => (cut <> (cddr args)))
   97:         (else (print "Unknown command: " (cadr args))
   98:               (usage)))
   99:   0)
  100: 
  101: ;;======================================================
  102: ;; Command definitions
  103: ;;
  104: 
  105: (define-macro (define-cmd name doc . body)
  106:   `(begin
  107:      (push! *helps* (cons ,name ',doc)) ; doc : (<synopsys> <summary> <detail>)
  108:      (push! *commands* (cons ,name
  109:                              (lambda (args)
  110:                                (let ((usage-self (lambda () (usage ,name))))
  111:                                  ,@body))))))
  112: 
  113: ;;------------------------------------------------------
  114: ;; install
  115: ;;
  116: (define-cmd "install"
  117:   ("install [options] <tarball-path/url>"
  118:    "Fetch, extract, configure, make & install"
  119:    "Argument:
  120:   a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  121:   of a tarball.
  122: Options:
  123:   -n, --dry-run   : shows commands to be executed, without running them.
  124:   -C, --configure-options=<options>
  125:                   : pass <options> to ./configure.  overrides -r.
  126:   -r, --reconfigure
  127:                   : uses the same configure options as before
  128:       --clean     : clean up the build directory after installation
  129:   -S, --install-as=<user> : sudo to <user> when installing")
  130:   (let-args args ((dry-run "n|dry-run")
  131:                   (copts   "C|configure-options=s" #f)
  132:                   (reconf  "r|reconfigure")
  133:                   (clean   "clean")
  134:                   (sudo    "S|install-as=s" #f)
  135:                   . args)
  136:     (unless (= (length args) 1) (usage-self))
  137:     (gauche-package-build (car args)
  138:                           :config *config*
  139:                           :dry-run dry-run :install #t :clean clean
  140:                           :sudo-install sudo
  141:                           :reconfigure reconf
  142:                           :configure-options copts)))
  143: 
  144: ;;------------------------------------------------------
  145: ;; build
  146: ;;
  147: (define-cmd "build"
  148:   ("build [options] <tarball-path/url>"
  149:    "Fetch, extract, configure & make"
  150:    "Argument:
  151:   a path to a tarball (uncompressed, gzipped or bzipped), or URL (http or ftp)
  152:   of a tarball.
  153: Options:
  154:   -n, --dry-run   : shows commands to be executed, without running them.
  155:   -C, --configure-options=<options>
  156:                   : pass <options> to ./configure.  overrides -r.
  157:   -r, --reconfigure
  158:                   : uses the same configure options as before")
  159:   (let-args args ((dry-run "n|dry-run")
  160:                   (copts   "C|configure-options=s" #f)
  161:                   (reconf  "r|reconfigure")
  162:                   . args)
  163:     (unless (= (length args) 1) (usage-self))
  164:     (gauche-package-build (car args)
  165:                           :config *config*
  166:                           :dry-run dry-run
  167:                           :reconfigure reconf
  168:                           :configure-options copts)))
  169: 
  170: ;;------------------------------------------------------
  171: ;; reconfigure
  172: ;;
  173: (define-cmd "reconfigure"
  174:   ("configure-options <package>"
  175:    "Show configure options of <package>"
  176:    "Argument: a package name.
  177:   If the package has installed .gpd (Gauche package description) file, show
  178:   the options to the configure script when the package is built.")
  179:   (unless (= (length args) 1) (usage-self))
  180:   (let1 gpd (find-gauche-package-description (car args) :all-versions #t)
  181:     (if gpd
  182:       (print (ref gpd 'configure))
  183:       (print ";; I don't know about package " (car args)))))
  184: 
  185: ;;------------------------------------------------------
  186: ;; list
  187: ;;
  188: (define-cmd "list"
  189:   ("list"
  190:    "List known installed packages"
  191:    "  Only packages that have .gpd file are listed.
  192: Options:
  193:   -a, --all    : shows all packages, even the ones that are installed for
  194:                  other versions of Gauche.")
  195:   (let-args args ((all?  "a|all"))
  196:     (let1 gpds (map path->gauche-package-description
  197:                     (gauche-package-description-paths :all-versions all?))
  198:       (dolist (gpd (sort gpds
  199:                          (lambda (a b)
  200:                            (string<= (ref a 'name) (ref b 'name)))))
  201:         (if (version=? (gauche-version) (ref gpd 'gauche-version))
  202:           (format #t " ~19a ~8a~%" (ref gpd 'name) (ref gpd 'version))
  203:           (when all?
  204:             (format #t "(~19a ~8a for Gauche ~a)~%"
  205:                     (ref gpd 'name) (ref gpd 'version)
  206:                     (ref gpd 'gauche-version))))
  207:         ))))
  208: 
  209: ;;------------------------------------------------------
  210: ;; make-gpd
  211: ;;
  212: (define-cmd "make-gpd"
  213:   ("make-gpd <name> <param> ..."
  214:    "Make gpd file (called from the configure script)"
  215:    "
  216:   This command is to create a gpd (Gauche package description) file.  
  217:   Usually the user doens't invoke this command.  It is intended to be
  218:   called within the configure script, like the following:
  219: 
  220:     gauche-package make-gpd Foo \\
  221:        -version $PACKAGE_VERSION \\
  222:        -configure \"./configure $GAUCHE_PACKAGE_CONFIGURE_ARGS\"
  223: 
  224:   If you generate template configure.ac by 'gauche-package generate',
  225:   the make-gpd stuff is included in it.")
  226:   (when (null? args) (usage-self))
  227:   (let loop ((p (cdr args))
  228:              (r '()))
  229:     (cond ((null? p)
  230:            (let ((gpd (apply make <gauche-package-description>
  231:                              :name (car args)
  232:                              (reverse! r))))
  233:              (with-output-to-file #`",(car args).gpd"
  234:                (cut write-gauche-package-description gpd))))
  235:           ((null? (cdr p))
  236:            (app-error "gauche-package: make-gpd: parameter list not even"))
  237:           (else
  238:            (loop (cddr p)
  239:                  (list* (cadr p)
  240:                         (make-keyword (string-trim (car p) #[-:]))
  241:                         r)))
  242:           )))
  243: 
  244: ;;------------------------------------------------------
  245: ;; compile
  246: ;;
  247: (define-cmd "compile"
  248:   ("compile [options] [<extension-name>] <file> ..."
  249:    "Compile and link an extension module from sources"
  250:    "
  251:   <file> can be any types the system's C compiler accepts, plus a stub
  252:   file (with extension '.stub') which is a genstub source.
  253: 
  254:   By default, this command compiles given files with the options appropriate
  255:   to compile Gauche extensions, then links a dynamically loadable object
  256:   <extension-name>.so (the suffix may differ among systems).  
  257:   If '-c' option is given, only compilation of a single file is done.  
  258:   You can give extra flags for the compiler/linker via options.
  259: 
  260:   <extension-name> must match the name passed to SCM_INIT_EXTENSION, 
  261:   and must be a valid C identifier.  (NB: <extension-name> is used only 
  262:   as the filename and the argument of SCM_INIT_EXTENSION, and has nothing 
  263:   to do with the package name or the module name.  
  264: 
  265: Options:
  266:   -c, --compile       : compile only.  with this option, <module> shouldn't
  267:                         be given and only one <file> is allowed.
  268:   -n, --dry-run       : just display commands to be executed.
  269:   -v, --verbose       : reports commands being executed.
  270:   -o, --output=name   : alternative output file name
  271:       --clean         : instead of compile and link, removes the intermediate
  272:                         and output file(s) that would be generated otherwise.
  273:                         useful for 'make clean'.
  274:   --cc=CC             : alternative C compiler.  Note that the compile should
  275:                         have compatible ABI with the one that compiled Gauche.
  276:   --cppflags=CPPFLAGS : extra cpp flags for compile, such as -I/usr/local
  277:   --cflags=CFLAGS     : extra cc flags for compile
  278:   --ldflags=LDFLAGS   : extra ld flags
  279:   --libs=LIBS         : extra libraries")
  280:   (let-args args ((dry-run      "n|dry-run")
  281:                   (verbose      "v|verbose")
  282:                   (compile-only "c|compile")
  283:                   (output       "o|output=s")
  284:                   (clean        "clean")
  285:                   (cc           "cc=s")
  286:                   (cppflags     "cppflags=s")
  287:                   (cflags       "cflags=s")
  288:                   (ldflags      "ldflags=s")
  289:                   (libs         "libs=s")
  290:                   . args)
  291:     (cond
  292:      (clean
  293:       (unless (null? args)
  294:         (gauche-package-clean (if compile-only #f (car args))
  295:                               (if compile-only args (cdr args))
  296:                               :output output)))
  297:      (compile-only
  298:       (unless (= (length args) 1) (usage-self))
  299:       (gauche-package-compile (car args)
  300:                               :dry-run dry-run :verbose verbose
  301:                               :output output :cc cc
  302:                               :cppflags cppflags :cflags cflags))
  303:      (else
  304:       (when (<= (length args) 1) (usage-self))
  305:       (gauche-package-compile-and-link (car args) (cdr args)
  306:                                        :dry-run dry-run :verbose verbose
  307:                                        :output output :cc cc :ld cc
  308:                                        :cppflags cppflags :cflags cflags
  309:                                        :ldflags ldflags :libs libs)))
  310:     ))
  311: 
  312: ;;------------------------------------------------------
  313: ;; generate
  314: ;;
  315: (define-cmd "generate"
  316:   ("generate package-name [module-name]"
  317:    "Generate template source tree for a new Gauche extension"
  318:    "
  319:   This command creates a directory <package-name> under the current
  320:   directory, and populates it with the template files.  It is an easy
  321:   way to start writing Gauche extension.
  322: 
  323:   <package-name> is the one you'll see as a part of the name of tarball,
  324:   for example, \"Gauche-gl\".  It is the name of the unit of distribution
  325:   and installation of your package.
  326: 
  327:   <module-name>, if given, is used as the name of the module
  328:   instead of <package-name>.  It may affect the generated directory
  329:   structure.")
  330:   (let-optionals* args ((package-name #f)
  331:                         (module-name #f)
  332:                         . more)
  333:     (unless (and package-name (null? more)) (usage-self))
  334:     (unless (#/^[\w-]+$/ package-name)
  335:       (app-error "Invalid character in package-name ~s: You can only use alphanumeric chars, underscore, and minus sign." package-name))
  336:     (unless (or (not module-name) (#/^[\w.-]+$/ module-name))
  337:       (app-error "Invalid character in module-name ~s" module-name))
  338:     (let* ((package-name*  (rxmatch-case package-name
  339:                              (#/^Gauche-(.*)/ (#f rest) rest)
  340:                              (else package-name)))
  341:            (extension-name (string-tr package-name* "A-Za-z_-" "a-za-z__"))
  342:            (module-name (string->symbol (or module-name extension-name)))
  343:            (tmpl-dir (sys-dirname (gauche-library-directory)))
  344:            (scm-subdir (sys-dirname (module-name->path module-name))))
  345:       (make-directory* (simplify-path (build-path package-name scm-subdir)))
  346:       (for-each
  347:        (lambda (file)
  348:          (let* ((src-path (build-path tmpl-dir #`"template.,file"))
  349:                 (dst-name (regexp-replace* 
  350:                            file
  351:                            #/extension/ extension-name
  352:                            #/module/ (sys-basename
  353:                                       (module-name->path module-name))))
  354:                 (dst-path (if (equal? file "module.scm")
  355:                             (build-path package-name scm-subdir dst-name)
  356:                             (build-path package-name dst-name))))
  357:            (filter-copy src-path dst-path
  358:                         package-name extension-name module-name '("DIST"))))
  359:        '("Makefile.in" "configure.ac" "extension.c" "extension.h"
  360:          "extensionlib.stub" "module.scm" "test.scm" "DIST")))
  361:     ))
  362: 
  363: (define (filter-copy src dst
  364:                      package-name extension-name module-name executables)
  365:   (let1 EXTENSION-NAME (string-upcase extension-name)
  366:     (file-filter (lambda (in out)
  367:                    (port-for-each
  368:                     (lambda (line)
  369:                       (display
  370:                        (regexp-replace-all*
  371:                         line
  372:                         #/@@package@@/ package-name
  373:                         #/@@modname@@/ (x->string module-name)
  374:                         #/@@modpath@@/ (module-name->path module-name)
  375:                         #/@@extname@@/ extension-name
  376:                         #/@@EXTNAME@@/ EXTENSION-NAME)
  377:                        out)
  378:                       (newline out))
  379:                     (cut read-line in)))
  380:                  :input src
  381:                  :output dst)
  382:     (when (member (sys-basename dst) executables)
  383:       (sys-chmod dst #o755))
  384:     ))
  385: 
  386: ;;------------------------------------------------------
  387: ;; help
  388: ;;
  389: 
  390: (define-cmd "help"
  391:   ("help <command>"
  392:    "Show detailed help of <command>")
  393:   (apply usage args))
  394: 
  395: ;; Local variables:
  396: ;; mode: scheme
  397: ;; end: