- incorporated the rest of Martin's changes: the library can now be
used to install programs (although the internals still have to be cleaned, and the new features documented),
This commit is contained in:
michel-schinz
parent
3eee4ba1a8
commit
2b825f6d36
|
|
@ -1,5 +1,5 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib.scm,v 1.16 2004/05/12 18:39:04 michel-schinz Exp $
|
||||
;;; $Id: install-lib.scm,v 1.17 2004/05/16 14:33:12 michel-schinz Exp $
|
||||
|
||||
;; TODO
|
||||
;; - think about --build: does it make sense?
|
||||
|
|
@ -302,7 +302,7 @@
|
|||
|
||||
;; Names of all non-shared (i.e. platform-dependent) locations.
|
||||
(define non-shared-locations
|
||||
'(lib))
|
||||
'(lib bin))
|
||||
|
||||
;; All locations defined for a layout.
|
||||
(define all-locations (append shared-locations non-shared-locations))
|
||||
|
|
@ -378,26 +378,38 @@
|
|||
|
||||
(define (fhs-layout pkg)
|
||||
(let* ((scsh-version-dir (string-append "scsh-" scsh-version-string))
|
||||
(base (absolute-file-name (package-full-name pkg)
|
||||
(paths->file-name "share"
|
||||
(base (paths->file-name "share"
|
||||
scsh-version-dir
|
||||
"modules"))))
|
||||
"modules"
|
||||
(package-full-name pkg))))
|
||||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name (package-full-name pkg)
|
||||
(paths->file-name
|
||||
"lib" scsh-version-dir "modules")))
|
||||
(doc . ,(absolute-file-name (package-full-name pkg)
|
||||
(paths->file-name
|
||||
"share" "doc" scsh-version-dir)))
|
||||
(active . ,(paths->file-name
|
||||
"share" scsh-version-dir "modules")))))
|
||||
(lib . ,(paths->file-name "lib"
|
||||
scsh-version-dir
|
||||
"modules"
|
||||
(package-full-name pkg)))
|
||||
(doc . ,(paths->file-name "share"
|
||||
"doc"
|
||||
scsh-version-dir
|
||||
(package-full-name pkg)))
|
||||
(active . ,(paths->file-name "share"
|
||||
scsh-version-dir
|
||||
"modules")))))
|
||||
|
||||
(define (fhs-program-layout pkg)
|
||||
(let* ((pkg-share (paths->file-name "share" (package-full-name pkg))))
|
||||
`((bin . "bin")
|
||||
(scheme . ,(paths->file-name pkg-share "scheme"))
|
||||
(doc . ,(paths->file-name "share"
|
||||
"doc"
|
||||
(package-full-name pkg))))))
|
||||
|
||||
(define predefined-layouts
|
||||
`(("scsh" . ,scsh-layout-1)
|
||||
("scsh-alt" . ,scsh-layout-2)
|
||||
("fhs" . ,fhs-layout)))
|
||||
("fhs" . ,fhs-layout)
|
||||
("fhs-program" . ,fhs-program-layout)))
|
||||
|
||||
;; If NAME-OR-LAYOUT refers to a predefined layout, return it.
|
||||
;; Otherwise, if NAME-OR-LAYOUT is a valid layout definition, parse
|
||||
|
|
@ -430,7 +442,7 @@
|
|||
(alist-get ext (package-extensions pkg) #f))
|
||||
|
||||
;; List of all defined packages
|
||||
(define *packages* (make-fluid #f))
|
||||
(define *packages* (make-fluid (make-cell '())))
|
||||
|
||||
;; Add PKG to the above list of all defined packages.
|
||||
(define (add-package pkg)
|
||||
|
|
@ -446,6 +458,11 @@
|
|||
(cwd)
|
||||
(lambda () body ...))))))
|
||||
|
||||
(define-syntax define-program
|
||||
(syntax-rules ()
|
||||
((define-program name version extensions body ...)
|
||||
(define-package name version extensions body ...))))
|
||||
|
||||
;; Load (and evaluate the contents of) the file "pkg-def.scm" in the
|
||||
;; current directory and return the packages it defines.
|
||||
(define (load-packages)
|
||||
|
|
@ -455,14 +472,10 @@
|
|||
(load-quietly package-definition-file))
|
||||
(cell-ref (fluid *packages*)))))
|
||||
|
||||
;; Like load-package but check additionally that none of the loaded
|
||||
;; packages require a more recent version of the installation library,
|
||||
;; and fail if it is the case.
|
||||
(define (load&check-packages)
|
||||
(let ((pkgs (load-packages)))
|
||||
(for-each (lambda (pkg)
|
||||
(and-let*
|
||||
((req-lst (package-extension pkg 'install-lib-version))
|
||||
;; Check that the given package does not require a more recent version
|
||||
;; of the installation library, and fail if it is the case.
|
||||
(define (check-package pkg)
|
||||
(and-let* ((req-lst (package-extension pkg 'install-lib-version))
|
||||
(req (first req-lst))
|
||||
((or (not (= (version-major req)
|
||||
(version-major install-lib-version)))
|
||||
|
|
@ -472,7 +485,11 @@
|
|||
"package "(package-name pkg)" needs a newer "
|
||||
"version of install-lib: "(version->string req)"\n"
|
||||
"(installed: " (version->string install-lib-version) ")")))
|
||||
pkgs)
|
||||
|
||||
;; Like load-package but additionally check loaded packages.
|
||||
(define (load&check-packages)
|
||||
(and-let* ((pkgs (load-packages))
|
||||
((for-each check-package pkgs)))
|
||||
pkgs))
|
||||
|
||||
(define (load-package-in dir)
|
||||
|
|
@ -784,7 +801,31 @@ advanced options:
|
|||
END
|
||||
)
|
||||
|
||||
(define program-usage #<<END
|
||||
Usage: ~a [options]
|
||||
|
||||
options:
|
||||
-h, --help display this help message, then exit
|
||||
--prefix <dir> specify directory where files are installed
|
||||
--layout <layout> specify layout of installation directory
|
||||
(predefined: ~a)
|
||||
--dry-run don't do anything, print what would have been done
|
||||
--verbose print messages about what is being done
|
||||
--force overwrite existing files during installation
|
||||
--no-user-defaults don't read user default from ~~/.scsh-pkg-defaults.scm
|
||||
|
||||
advanced options:
|
||||
--build <name> name of platform for which to build
|
||||
--layout-from <file> load layout of installation directory from file
|
||||
--layout-to <file> output layout to given file
|
||||
--dest-dir <dir> specify prefix to used during installation
|
||||
(to be used only during staged installations)
|
||||
|
||||
END
|
||||
)
|
||||
|
||||
(define usage-descr-col 26)
|
||||
(define program-usage-descr-col 26)
|
||||
|
||||
;; Complete the above USAGE string to include information about the
|
||||
;; package options PKG-OPTS.
|
||||
|
|
@ -806,9 +847,27 @@ END
|
|||
pkg-opts)
|
||||
(set! usage (string-output-port-output usage-port))))
|
||||
|
||||
(define (complete-program-usage! pkg-opts)
|
||||
(let ((usage-port (make-string-output-port)))
|
||||
(write-string program-usage usage-port)
|
||||
(write-string "\npackage-specific options:\n" usage-port)
|
||||
(for-each
|
||||
(lambda (pkg-opt)
|
||||
(let ((option/arg (format #f "--~a ~a"
|
||||
(pkg-opt-name pkg-opt)
|
||||
(pkg-opt-arg-help pkg-opt))))
|
||||
(format usage-port
|
||||
" ~a~a~a [~a]\n"
|
||||
option/arg
|
||||
(spaces 2 (- program-usage-descr-col (string-length option/arg)))
|
||||
(pkg-opt-help pkg-opt)
|
||||
((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt)))))
|
||||
pkg-opts)
|
||||
(set! program-usage (string-output-port-output usage-port))))
|
||||
|
||||
;; Display the usage string, then all MSGS on the standard output
|
||||
;; port, then exit with an error code of 1.
|
||||
(define (display-usage-and-exit . msgs)
|
||||
(define (display-usage-and-exit usage . msgs)
|
||||
(format #t
|
||||
usage
|
||||
(car (command-line))
|
||||
|
|
@ -897,7 +956,7 @@ END
|
|||
alist)))))
|
||||
(list
|
||||
(option '(#\h "help") #f #f
|
||||
(lambda args (display-usage-and-exit)))
|
||||
(lambda args (display-usage-and-exit usage)))
|
||||
(option '("prefix") #t #f (alist-arg-updater 'prefix))
|
||||
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
|
||||
(option '("layout") #t #f (alist-arg-updater 'layout))
|
||||
|
|
@ -916,15 +975,42 @@ END
|
|||
(option '("verbose") #f #t (alist-boolean-updater 'verbose))
|
||||
(option '("force") #f #t (alist-boolean-updater 'force)))))
|
||||
|
||||
(define program-options
|
||||
(let ((alist-arg-updater (lambda (key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key arg alist))))
|
||||
(alist-boolean-updater (lambda (key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key
|
||||
(or (not arg)
|
||||
(parse-boolean arg))
|
||||
alist)))))
|
||||
(list
|
||||
(option '(#\h "help") #f #f
|
||||
(lambda args (display-usage-and-exit program-usage)))
|
||||
(option '("prefix") #t #f (alist-arg-updater 'prefix))
|
||||
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
|
||||
(option '("layout") #t #f (alist-arg-updater 'layout))
|
||||
(option '("layout-from") #t #f
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace 'layout
|
||||
(let ((layout (call-with-input-file arg read)))
|
||||
(lambda args layout))
|
||||
alist)))
|
||||
(option '("layout-to") #t #f (alist-arg-updater 'layout-to))
|
||||
(option '("dry-run") #f #t (alist-boolean-updater 'dry-run))
|
||||
(option '("verbose") #f #t (alist-boolean-updater 'verbose))
|
||||
(option '("force") #f #t (alist-boolean-updater 'force)))))
|
||||
|
||||
(define no-user-defaults-option "--no-user-defaults")
|
||||
|
||||
(define (parse-options args options defaults)
|
||||
(define (parse-options usage args options defaults)
|
||||
(args-fold args
|
||||
options
|
||||
(lambda (option name . rest)
|
||||
(display-usage-and-exit "Unknown option "name))
|
||||
(display-usage-and-exit usage "Unknown option "name))
|
||||
(lambda (operand . rest)
|
||||
(display-usage-and-exit "Don't know what to do with " operand))
|
||||
(display-usage-and-exit usage "Don't know what to do with " operand))
|
||||
defaults))
|
||||
|
||||
;; Return user-specific defaults.
|
||||
|
|
@ -955,6 +1041,19 @@ END
|
|||
(force . #f)
|
||||
(exclude . ,(lambda args #f))))
|
||||
|
||||
(define program-options-defaults
|
||||
`((prefix . "/usr/local")
|
||||
(dest-dir . "/")
|
||||
(layout . "fhs-program")
|
||||
(layout-to . #f)
|
||||
(build . ,(host))
|
||||
(non-shared-only . #f)
|
||||
(inactive . #t)
|
||||
(dry-run . #f)
|
||||
(verbose . #f)
|
||||
(force . #f)
|
||||
(exclude . ,(lambda args #f))))
|
||||
|
||||
(define (install-main cmd-line)
|
||||
(let* ((packages (load&check-packages))
|
||||
(all-pkg-opts (all-package-options packages)))
|
||||
|
|
@ -967,7 +1066,8 @@ END
|
|||
(read-user-defaults))
|
||||
options-defaults)
|
||||
(map pkg-opt-key&default all-pkg-opts)))
|
||||
(options-values (parse-options (delete no-user-defaults-option
|
||||
(options-values (parse-options usage
|
||||
(delete no-user-defaults-option
|
||||
(cdr cmd-line))
|
||||
all-opts
|
||||
all-dfts))
|
||||
|
|
@ -990,3 +1090,34 @@ END
|
|||
(display-error-and-exit "invalid layout "layout))
|
||||
(install-packages packages options-values)
|
||||
(display-use-hint prefix resolved-layout packages)))))
|
||||
|
||||
(define (install-program-main cmd-line)
|
||||
(let* ((packages (cell-ref (fluid *packages*)))
|
||||
(all-pkg-opts (all-package-options packages)))
|
||||
(for-each check-package packages)
|
||||
(if (not (null? all-pkg-opts))
|
||||
(complete-program-usage! all-pkg-opts))
|
||||
(let* ((all-opts (append program-options
|
||||
(map pkg-opt->option all-pkg-opts)))
|
||||
(all-dfts (append (alist-combine
|
||||
(if (member no-user-defaults-option cmd-line)
|
||||
'()
|
||||
(read-user-defaults))
|
||||
program-options-defaults)
|
||||
(map pkg-opt-key&default all-pkg-opts)))
|
||||
(options-values (parse-options program-usage
|
||||
(delete no-user-defaults-option
|
||||
(cdr cmd-line))
|
||||
all-opts
|
||||
all-dfts))
|
||||
(prefix (alist-get 'prefix options-values))
|
||||
(layout (alist-get 'layout options-values)))
|
||||
(if (null? packages)
|
||||
(display-error-and-exit
|
||||
"no package to install"))
|
||||
(if (not (file-name-absolute? prefix))
|
||||
(display-error-and-exit "prefix must be an absolute path"))
|
||||
(let ((resolved-layout (resolve-layout layout)))
|
||||
(if (not resolved-layout)
|
||||
(display-error-and-exit "invalid layout "layout))
|
||||
(install-packages packages options-values)))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue