1: ;; A tool to create symlinks from main source tree to extension modules,
    2: ;; or to remove them.  This is useful to test gosh in the source tree,
    3: ;; without installing them.
    4: ;; Such links are only of developers' interest; they must be cleaned out
    5: ;; to create a distribution tarball.
    6: ;;
    7: ;; $Id: xlink,v 1.11 2007/09/15 04:00:17 shirok Exp $
    8: ;;
    9: 
   10: ;; NB: this script is called before all the necessary 'wiring' is
   11: ;; done during the build, so most useful extension modules are not
   12: ;; available.  We have to do things in primitive way.
   13: 
   14: ;; When an environemnt variable GAUCHE_PRE_GENERATE_FOR_WINVC is defined,
   15: ;; xlink behaves in peculiar way:
   16: ;;   - it ignores files except *.scm.
   17: ;;   - it copies the files instead of symlinks.
   18: ;; The feature is to pre-generate and place files that are cumbersome
   19: ;; to do during Windows/VC++ build.  Pre-generation itself should be
   20: ;; done on windows.
   21: 
   22: (define (usage)
   23:   (print "Usage: gosh xlink [-l|-u][-g group][-b top_builddir][-s top_srcdir] <scm-or-so-file> ...\n"
   24:          "  -l creates symlinks from the source tree to the given\n"
   25:          "     files.  If the given file is a Scheme file, the link\n"
   26:          "     is created in $(top_srcdir)/lib/$(group)/.  If the given\n"
   27:          "     file is a compiled DSO, the link is created in\n"
   28:          "     $(top_builddir)/src.\n"
   29:          "  -u removes symlinks created by -l option.\n"
   30:          "  -g group - extra category of library path.\n"
   31:          "  -b top_builddir - $(top_builddir) passed from Makefile.\n"
   32:          "  -s top_srcdir - $(top_builddir) passed from Makefile."
   33:          )
   34:   (exit 1))
   35: 
   36: (define *link*   #f)
   37: (define *unlink* #f)
   38: (define *group*  #f)
   39: (define *builddir* #f)
   40: (define *srcdir*   #f)
   41: 
   42: (define *pre-gen-winvc*
   43:   (sys-getenv "GAUCHE_PRE_GENERATE_FOR_WINVC"))
   44: 
   45: (define (main args)
   46:   (let1 files (parse-args (cdr args))
   47:     (unless (or *link* *unlink*) (usage))
   48:     (for-each (lambda (file)
   49:                 (let ((path   (build-path (sys-getcwd) file))
   50:                       (target (if (string-suffix? ".scm" file)
   51:                                 (build-path *srcdir* "lib" *group* file)
   52:                                 (build-path *builddir* "src" file))))
   53:                   (if *unlink*
   54:                     (sys-unlink target)
   55:                     (make-link path target))))
   56:               files))
   57:   0)
   58: 
   59: (define (make-link file target)
   60:   (make-directory* (sys-dirname target))
   61:   (unless (or (link-exists? file target)
   62:               (and *pre-gen-winvc* (not (string-suffix? ".scm" file))))
   63:     (sys-unlink target)
   64:     (print "link "file" <- "target)
   65:     (if (and (symbol-bound? 'sys-symlink) (not *pre-gen-winvc*))
   66:       (sys-symlink file target)
   67:       (sys-system #`"cp ,file ,target"))))
   68: 
   69: (define (link-exists? file target)
   70:   (and (global-variable-bound? 'gauche 'sys-lstat)
   71:        (file-exists? target)
   72:        (file-is-symlink? target)
   73:        (equal? file (sys-readlink target))))
   74: 
   75: (define (parse-args args)
   76:   (cond ((null? args) '())
   77:         ((string=? (car args) "-l")
   78:          (set! *link* #t) (parse-args (cdr args)))
   79:         ((string=? (car args) "-u")
   80:          (set! *unlink* #t) (parse-args (cdr args)))
   81:         ((string=? (car args) "-g")
   82:          (set! *group* (cadr args)) (parse-args (cddr args)))
   83:         ((string=? (car args) "-b")
   84:          (set! *builddir* (cadr args)) (parse-args (cddr args)))
   85:         ((string=? (car args) "-s")
   86:          (set! *srcdir* (cadr args)) (parse-args (cddr args)))
   87:         ((#/^-/ (car args)) (usage))
   88:         (else args)))
   89: 
   90: ;; simpler versions of file.util procedures
   91: (define (build-path . args)
   92:   (string-join args "/" 'infix))
   93: 
   94: (define (make-directory* dir)
   95:   (let1 up (sys-dirname dir)
   96:     (unless (equal? up ".")
   97:       (make-directory* up)
   98:       (unless (file-exists? dir)
   99:         (sys-mkdir dir #o755)))))
  100: 
  101: (define (file-is-symlink? path)
  102:   (eq? (ref (sys-lstat path) 'type) 'symlink))
  103: 
  104: (define (string-suffix? suffix str)
  105:   (let ((suffix-len (string-length suffix))
  106:         (str-len    (string-length str)))
  107:     (and (>= str-len suffix-len)
  108:          (string=? (substring str (- str-len suffix-len) str-len) suffix))))
  109: 
  110:     
  111: 
  112: ;; Local variables:
  113: ;; mode: scheme
  114: ;; end: