scsh-conservatory
/
scsh-install-lib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- modified layouts so that scsh's major and minor versions appear 

explicitely in all paths,
- check locations given by the package installation script, and fail
  if one is unknown,
- added "install-lib-version" extension, so that package installation
  scripts can explicitely specify which version of install-lib they
  need,
- added a message which is printed at the end of a successful
  installation and indicates how to set SCSH_LIB_DIRS,
- provided a way to "turn off" boolean options like --force, by
  providing an explicit "=no",
- replaced a few calls to "error" by calls to
  "display-error-and-exit", to try to be consistent and use "error"
  only for "internal" errors not due to the end user,
- removed "platform" parameter from layouts, not needed anymore since
  the "lib" location was made platform-independent a long time ago,
- documented --no-user-defaults.
This commit is contained in:
michel-schinz 2004-03-14 14:10:25 +00:00
parent 352d32cae6
commit b2a4c81312
1 changed files with 161 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

197
scheme/install-lib/install-lib.scm
View File

@ -1,12 +1,41 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.12 2004/02/23 20:11:40 michel-schinz Exp $
;;; $Id: install-lib.scm,v 1.13 2004/03/14 14:10:25 michel-schinz Exp $
;; TODO
;; - think about --host: does it make sense?
;; - get-directory should get 'install or 'final instead of #f #t
;; - add a "--debug" option
;; - add support for communication between configure and pkg-def.scm
;; - add support for image creation
;; - add support to maintain a documentation index
;;
;; Version of the installation library
;;
;; The versioning scheme is as follows: a version is composed of three
;; integers called (from left to right) "major", "minor" and
;; "revision".
;;
;; Two versions which share a "major" and "minor" number must be fully
;; compatible in that one should be exchangeable for the other without
;; (important) change in behaviour.
;;
;; Two versions which share a "major" number must be compatible in an
;; ascendent fashion: the features offered by the version with the
;; greatest "minor" number must be a superset of those offered by the
;; other.
;;
;; Two versions which do not even share a "major" number can be
;; mutually incompatible.
;;
;; Clients using the installation library must specify which "major"
;; and "minor" number they need --- if the above scheme is respected,
;; the "revision" should not matter. This need is satisfied if the
;; requested "major" number matches the one of the library, and the
;; requested "minor" is smaller or equal to the one of the library.
(define install-lib-version '(1 0 0))
;;
;; Support code templates
;;
@ -52,6 +81,14 @@
(define default-perms-fn
(lambda (name) #o755))
;; Fail if CONDITION is not true, displaying ERROR-MSG with ARGUMENTS.
(define (assert condition error-msg . arguments)
(if (not condition)
(apply error error-msg arguments)))
;; True iff LIST has more than one element.
(define (many? list) (> (length list) 1))
;; Return the name of the parent directory of FNAME.
(define (parent-directory fname)
(file-name-directory (directory-as-file-name fname)))
@ -93,12 +130,17 @@
(path-list->file-name (append new-root-pl (cdr fname-pl)))
(error "no root to replace in relative file name" fname))))
;; Similar to path-list->file-name, but take all arguments as
;; components of the path.
(define (paths->file-name . paths)
(path-list->file-name paths))
;; If FILE exists, fail if --force was not given, delete it otherwise.
(define (delete-file-or-fail file)
(if (file-exists? file)
(if (get-option-value 'force)
(-delete-file file)
(error "target file exists" file))))
(display-error-and-exit "target file already exists: " file))))
;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a
;; non-existing file (i.e. it cannot be the name of a directory).
@ -141,7 +183,7 @@
(define (alist-get key alist . rest)
(cond ((assoc key alist) => cdr)
((not (null? rest)) (first rest))
(else (error "internal error: cannot find key in alist" key alist))))
(else (error "cannot find key in alist" key alist))))
;; Convert all arguments to strings using DISPLAY and concatenate the
;; result in a single string which is returned.
@ -191,6 +233,14 @@
;; Versions are represented as lists of integers, the most significant
;; being at the head.
;; Return major/minor parts of a version.
(define version-major first)
(define version-minor second)
;; Return true iff OBJECT can be interpreted as a version.
(define (version? object)
(and (list? object) (every integer? object)))
;; Return the printed representation of VERSION.
(define (version->string version)
(string-join (map number->string version) "."))
@ -234,9 +284,14 @@
;; All locations defined for a layout.
(define all-locations (append shared-locations non-shared-locations))
;; Return true iff the given location is "active", that is if files
;; should be installed in it.
;; Return true iff LOCATION is valid.
(define (valid-location? location)
(member location all-locations))
;; Return true iff LOCATION is "active", that is if files should be
;; installed in it.
(define (active-location? location)
(assert (valid-location? location) "invalid location" location)
(member location (if (get-option-value 'non-shared-only)
non-shared-locations
all-locations)))
@ -268,40 +323,53 @@
;; Return the directory associated with the LOCATION in LAYOUT.
(define (layout-dir layout location)
(assert (valid-location? location) "invalid location" location)
(alist-get location layout #f))
;; Predefined layouts
(define (scsh-layout platform base)
;; Directory corresponding to the current major and minor version of
;; scsh.
(define scsh-version-string
(version->string (list scsh-major-version scsh-minor-version)))
(define (scsh-layout base)
`((base . ,base)
(misc-shared . ,base)
(scheme . ,(absolute-file-name "scheme" base))
(lib . ,(absolute-file-name "lib" base))
(doc . ,(absolute-file-name "doc" base))))
(define (scsh-layout-1 platform pkg)
(alist-combine '((active . "."))
(scsh-layout platform (package-full-name pkg))))
(define (scsh-layout-1 pkg)
(alist-combine `((active . ,scsh-version-string))
(scsh-layout (paths->file-name scsh-version-string
(package-full-name pkg)))))
(define (scsh-layout-2 platform pkg)
(define (scsh-layout-2 pkg)
(alist-combine
'((active . "active"))
(scsh-layout platform
(path-list->file-name
(list "installed"
(package-name pkg)
(version->string (package-version pkg)))))))
`((active . ,(paths->file-name scsh-version-string "active")))
(scsh-layout (paths->file-name scsh-version-string
"installed"
(package-name pkg)
(version->string (package-version pkg))))))
(define (fhs-layout platform pkg)
(let ((base (absolute-file-name (package-full-name pkg)
"share/scsh/modules")))
(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"
scsh-version-dir
"modules"))))
`((base . ,base)
(misc-shared . ,base)
(scheme . ,(absolute-file-name "scheme" base))
(lib . ,(absolute-file-name (package-full-name pkg)
"lib/scsh/modules"))
(doc . ,(absolute-file-name (package-full-name pkg) "share/doc"))
(active . "share/scsh/modules"))))
(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")))))
(define predefined-layouts
`(("scsh" . ,scsh-layout-1)
@ -363,6 +431,26 @@
(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))
(req (first req-lst))
((or (not (= (version-major req)
(version-major install-lib-version)))
(> (version-minor req)
(version-minor install-lib-version)))))
(display-error-and-exit
"package "(package-name pkg)" needs a newer "
"version of install-lib: "(version->string req)"\n"
"(installed: " (version->string install-lib-version) ")")))
pkgs)
pkgs))
(define (load-package-in dir)
(with-cwd dir (load-quietly package-definition-file)))
@ -494,7 +582,16 @@
(cond ((or (file-regular? source) (file-symlink? source))
(-copy-file source target))
((file-directory? source)
(-create-directory target (file-mode source))
(if (file-exists? target)
(if (file-directory? target)
(if (get-option-value 'force)
(set-file-mode target (file-mode source))
(display-error-and-exit
"target directory already exists: " target))
(begin
(delete-file-or-fail target)
(-create-directory target (file-mode source))))
(-create-directory target (file-mode source)))
(install-directory-contents% layout
source
location
@ -502,7 +599,8 @@
target-name
target-rel-dir)
perms-fn))
(else (error "cannot install file-system object" source)))))))
(else (display-error-and-exit
"cannot install file-system object: " source)))))))
(define (install-directory-contents% layout
name
@ -594,7 +692,7 @@
(lambda ()
(for-each
(lambda (pkg)
(let* ((rel-layout (layout-fn build pkg))
(let* ((rel-layout (layout-fn pkg))
(layout (absolute-layout rel-layout prefix))
(i-layout (absolute-layout rel-layout dest-prefix)))
(if layout-to
@ -611,7 +709,7 @@
(let-optionals rest ((options-diff '()))
(with-cwd dir
(install-packages
(load-packages)
(load&check-packages)
(fold (lambda (diff options)
(cond ((pair? diff)
(cons diff (alist-delete (car diff) options)))
@ -646,6 +744,7 @@ options:
--inactive don't activate package after installing it
--non-shared-only only install platform-dependent files, if any
--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
@ -721,7 +820,10 @@ END
(alist-replace key arg alist))))
(alist-boolean-updater (lambda (key)
(lambda (opt name arg alist)
(alist-replace key #t alist)))))
(alist-replace key
(or (not arg)
(parse-boolean arg))
alist)))))
(list
(option '(#\h "help") #f #f
(lambda args (display-usage-and-exit)))
@ -736,12 +838,12 @@ END
alist)))
(option '("layout-to") #t #f (alist-arg-updater 'layout-to))
(option '("build") #t #f (alist-arg-updater 'build))
(option '("non-shared-only") #f #f
(option '("non-shared-only") #f #t
(alist-boolean-updater 'non-shared-only))
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run))
(option '("verbose") #f #f (alist-boolean-updater 'verbose))
(option '("force") #f #f (alist-boolean-updater 'force)))))
(option '("inactive") #f #t (alist-boolean-updater 'inactive))
(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")
@ -786,7 +888,7 @@ END
(if (not (file-exists? package-definition-file))
(display-error-and-exit "cannot find package definition file"
"("package-definition-file")"))
(let* ((packages (load-packages))
(let* ((packages (load&check-packages))
(all-pkg-opts (all-package-options packages)))
(if (not (null? all-pkg-opts))
(complete-usage! all-pkg-opts))
@ -807,6 +909,29 @@ END
(display-error-and-exit "no prefix specified (use --prefix option)"))
(if (not (file-name-absolute? prefix))
(display-error-and-exit "prefix must be an absolute path"))
(if (not (resolve-layout layout))
(display-error-and-exit "invalid layout "layout))
(install-packages packages options-values))))
(let ((resolved-layout (resolve-layout layout)))
(if (not resolved-layout)
(display-error-and-exit "invalid layout "layout))
(install-packages packages options-values)
(let ((active-locations
(delete-duplicates
(map (lambda (pkg)
(string-append "\""
(layout-dir (absolute-layout
(resolved-layout pkg)
prefix)
'active)
"\""))
packages)
string=?)))
(display
(as-string
"The following scsh package" (if (many? packages) "s were" " was")
" installed successfully:\n"
" "(string-join (map package-full-name packages) ", ")"\n"
"In order to use "(if (many? packages) "them" "it")", "
"make sure to add the following value"
(if (many? active-locations) "s" "")"\n"
"to the environment variable SCSH_LIB_DIRS (quotes included):\n"
" " (string-join active-locations " ")
"\n")))))))