From 948a386108191931bcee2503b70595559cee3773 Mon Sep 17 00:00:00 2001
From: michel-schinz <michel-schinz>
Date: Mon, 17 May 2004 20:12:30 +0000
Subject: [PATCH] - now use the installation library to install itself (also as
 a   package)

---
 install.scm | 131 +---------------------------------------------------
 1 file changed, 1 insertion(+), 130 deletions(-)

diff --git a/install.scm b/install.scm
index 70a1b4f..9010449 100755
--- a/install.scm
+++ b/install.scm
@@ -1,132 +1,3 @@
 #!/bin/sh
-exec scsh -e main -o let-opt -o srfi-1 -o srfi-37 -s "$0" "$@"
+exec scsh -lm scheme/install-lib-module.scm -o install-lib -e install-main -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))))))