133 lines
5.0 KiB
Scheme
Executable File
133 lines
5.0 KiB
Scheme
Executable File
#!/bin/sh
|
|
exec scsh -e main -o let-opt -o srfi-1 -o srfi-37 -s "$0" "$@"
|
|
!#
|
|
|
|
;; Install scsh's installation library as follows:
|
|
;; - files install-lib.scm and install-lib-module.scm go to
|
|
;; <prefix>/share/scsh-install-lib/scheme/
|
|
;; - file proposal.pdf goes to
|
|
;; <prefix>/share/doc/scsh-install-lib/
|
|
;; - a new file called scsh-install-pkg, providing an entry point to
|
|
;; the installation library, is installed in <prefix>/bin
|
|
|
|
;; TODO most of the following functions were lifted straight from
|
|
;; install-lib.scm, but should really be shared in some way.
|
|
|
|
;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM.
|
|
(define (alist-replace key datum alist)
|
|
(alist-cons key datum (alist-delete key alist)))
|
|
|
|
;; Return the value associated with KEY in ALIST. If none exists,
|
|
;; return DEFAULT, or signal an error if no DEFAULT was given.
|
|
(define (alist-get key alist . rest)
|
|
(cond ((assoc key alist) => cdr)
|
|
((not (null? rest)) (first rest))
|
|
(else (error "cannot find key in alist" key alist))))
|
|
|
|
;; Return the name of the parent directory of FNAME.
|
|
(define (parent-directory fname)
|
|
(file-name-directory (directory-as-file-name fname)))
|
|
|
|
;; Create directory FNAME and all its parents, as needed.
|
|
(define (create-directory&parents fname . rest)
|
|
(let-optionals rest ((perms #o777))
|
|
(let ((parent (parent-directory fname)))
|
|
(if (not (file-exists? parent))
|
|
(apply create-directory&parents parent rest))
|
|
(if (not (file-exists? fname))
|
|
(create-directory fname perms)))))
|
|
|
|
;; Return the name of FNAME, which must be absolute, with NEW-ROOT as
|
|
;; root.
|
|
(define (re-root-file-name fname new-root)
|
|
(let ((fname-pl (split-file-name fname))
|
|
(new-root-pl (split-file-name new-root)))
|
|
(if (string=? (first fname-pl) "")
|
|
(path-list->file-name (append new-root-pl (cdr fname-pl)))
|
|
(error "no root to replace in relative file name" fname))))
|
|
|
|
;; Copy SOURCE to TARGET-DIR, with the same name.
|
|
(define (copy-file-to-dir source target-dir)
|
|
(let ((target (absolute-file-name (file-name-nondirectory source)
|
|
target-dir)))
|
|
(run (cp ,source ,target))
|
|
(set-file-mode target (file-mode source))))
|
|
|
|
(define usage #<<END
|
|
Usage: ~a [options]
|
|
|
|
options:
|
|
-h, --help display this help message, then exit
|
|
--prefix <dir> specify directory where files are installed
|
|
(default: /usr/local)
|
|
--dest-dir <dir> specify prefix to used during installation
|
|
(to be used only during staged installations)
|
|
|
|
END
|
|
)
|
|
|
|
;; Template for scsh-install-pkg script, must be plugged with the
|
|
;; directory containing the Scheme code.
|
|
(define scsh-install-pkg-template #<<END
|
|
#!/bin/sh
|
|
exec scsh -lm ~a/install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
|
|
!#
|
|
|
|
END
|
|
)
|
|
|
|
(define (display-usage-and-exit prog . args)
|
|
(format (current-error-port) usage prog)
|
|
(if (not (null? args))
|
|
(for-each (lambda (thing) (display thing (current-error-port)))
|
|
(cons "Error: " args)))
|
|
(exit 1))
|
|
|
|
(define (parse-options prog args)
|
|
(args-fold
|
|
args
|
|
(let ((alist-arg-updater (lambda (key)
|
|
(lambda (opt name arg alist)
|
|
(alist-replace key arg alist)))))
|
|
(list (option '(#\h "help") #f #f
|
|
(lambda ignored (display-usage-and-exit prog)))
|
|
(option '("prefix") #t #f (alist-arg-updater 'prefix))
|
|
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))))
|
|
(lambda (option name . rest)
|
|
(display-usage-and-exit prog "Unknown option "name))
|
|
(lambda (operand . rest)
|
|
(display-usage-and-exit prog
|
|
"Don't know what to do with "
|
|
operand))
|
|
'((prefix . "/usr/local")
|
|
(dest-dir . "/"))))
|
|
|
|
(define (main cmd-line)
|
|
(let* ((options (parse-options (car cmd-line) (cdr cmd-line)))
|
|
(prefix (alist-get 'prefix options))
|
|
(r-prefix (absolute-file-name prefix "/"))
|
|
(i-prefix (re-root-file-name r-prefix (alist-get 'dest-dir options))))
|
|
|
|
;; Install documentation
|
|
(let ((doc-dir (absolute-file-name "share/doc/scsh-install-lib"
|
|
i-prefix)))
|
|
(create-directory&parents doc-dir)
|
|
(copy-file-to-dir "doc/proposal.pdf" doc-dir))
|
|
|
|
;; Install Scheme code
|
|
(let ((scheme-dir (absolute-file-name "share/scsh-install-lib/scheme"
|
|
i-prefix)))
|
|
(create-directory&parents scheme-dir)
|
|
(copy-file-to-dir "scheme/install-lib.scm" scheme-dir)
|
|
(copy-file-to-dir "scheme/install-lib-module.scm" scheme-dir))
|
|
|
|
;; Install script
|
|
(let ((bin-dir (absolute-file-name "bin" i-prefix))
|
|
(r-scheme-dir (absolute-file-name "share/scsh-install-lib/scheme"
|
|
r-prefix)))
|
|
(create-directory&parents bin-dir)
|
|
(call-with-output-file (absolute-file-name "scsh-install-pkg" bin-dir)
|
|
(lambda (p)
|
|
(format p scsh-install-pkg-template r-scheme-dir)
|
|
(set-file-mode p #o755))))))
|