.Added support for creating and deleting development links to the planet cmd-line tool.
svn: r1906
This commit is contained in:
Jacob Matthews
parent
e1df8982ca
commit
e9b8eda964
|
|
@ -4,12 +4,15 @@
|
|||
(PLANET-SERVER-NAME "planet.plt-scheme.org")
|
||||
(PLANET-SERVER-PORT 270)
|
||||
(PLANET-CODE-VERSION "300")
|
||||
(PLANET-DIR (if (getenv "PLTPLANETDIR")
|
||||
(string->path (getenv "PLTPLANETDIR"))
|
||||
(build-path (find-system-path 'addon-dir) "planet" (PLANET-CODE-VERSION) (version))))
|
||||
(PLANET-BASE-DIR (if (getenv "PLTPLANETDIR")
|
||||
(string->path (getenv "PLTPLANETDIR"))
|
||||
(build-path (find-system-path 'addon-dir)
|
||||
"planet"
|
||||
(PLANET-CODE-VERSION))))
|
||||
(PLANET-DIR (build-path (PLANET-BASE-DIR) (version)))
|
||||
(CACHE-DIR (build-path (PLANET-DIR) "cache"))
|
||||
(LINKAGE-FILE (build-path (PLANET-DIR) "LINKAGE"))
|
||||
(HARD-LINK-FILE (build-path (PLANET-DIR) "HARD-LINKS"))
|
||||
(HARD-LINK-FILE (build-path (PLANET-BASE-DIR) "HARD-LINKS"))
|
||||
(LOGGING-ENABLED? #t)
|
||||
(LOG-FILE (build-path (PLANET-DIR) "INSTALL-LOG"))
|
||||
(DEFAULT-PACKAGE-LANGUAGE (version))
|
||||
|
|
|
|||
|
|
@ -166,9 +166,11 @@ and are stored in a user-specific table called the linkage table.
|
|||
|
||||
2. Acceptable local package
|
||||
|
||||
If the PLaneT client doesn't have any previous linkage information,
|
||||
it checks its list of already-installed PLaneT packages for one that
|
||||
meets the requirement, and uses it if available.
|
||||
If the PLaneT client doesn't have any previous linkage information, it
|
||||
checks its list of already-installed PLaneT packages for one that
|
||||
meets the requirement, and uses it if available. Both PLaneT-installed
|
||||
packages and packages established through a development link are
|
||||
checked simultaneously at this stage.
|
||||
|
||||
3. Acceptable remote package
|
||||
|
||||
|
|
@ -226,6 +228,42 @@ List the current linkage table
|
|||
|
||||
Clear the linkage table, unlinking all packages and allowing upgrades.
|
||||
|
||||
-a, --associate <owner> <pkg> <maj> <min> <dir>
|
||||
|
||||
Create a development link from the given package specifier
|
||||
to the given directory, clearing any previous development
|
||||
links that may have been in place. (See below for an explanation
|
||||
of what development links are.)
|
||||
|
||||
-u, --unassociate <owner> <pkg> <maj> <min>
|
||||
|
||||
Remove any development links from the given package specifier.
|
||||
|
||||
|
||||
_Development links_
|
||||
-------------------
|
||||
|
||||
To aid development, PLaneT allows users to establish direct
|
||||
associations between a particular planet package (e.g. myname
|
||||
myfirstpackage.plt 1 0) with an arbitrary directory on the filesystem
|
||||
(e.g., /home/myname/svn/mypackages/devel/). These associations are
|
||||
intended to allow developers to use their own directory structures,
|
||||
version control systems, etc. while developing PLaneT packages while
|
||||
still being able to use the packages they create as though they were
|
||||
distributed directly by PLaneT. Development links are local to a
|
||||
particular user and repository (but not to a particular MzScheme minor
|
||||
revision).
|
||||
|
||||
To establish a development link, use the planet command-line tool:
|
||||
|
||||
$ planet --associate myname mypackage.plt 1 0 ~/svn/mypackages/devel
|
||||
|
||||
Once you are finished developing a package, you should remove any
|
||||
development links you have established for it, again using the planet
|
||||
command-line tool:
|
||||
|
||||
$ planet --unassociate myname mypackage.plt 1 0
|
||||
|
||||
_Distributing Packages with PLaneT_
|
||||
-----------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -72,6 +72,20 @@ PLANNED FEATURES:
|
|||
""
|
||||
"List the current linkage table"
|
||||
(set! actions (cons show-linkage actions)))
|
||||
|
||||
(("-a" "--associate")
|
||||
owner pkg maj min path
|
||||
""
|
||||
"Create a development link between the specified package specifier "
|
||||
"and the specified directory name"
|
||||
(set! actions (cons (lambda () (add-hard-link-cmd owner pkg maj min path)) actions)))
|
||||
|
||||
(("-u" "--unassociate")
|
||||
owner pkg maj min
|
||||
""
|
||||
"Remove any development link associated with the specified package"
|
||||
(set! actions (cons (lambda () (remove-hard-link-cmd owner pkg maj min)) actions)))
|
||||
|
||||
;; unimplemented so far:
|
||||
#;(("-u" "--unlink")
|
||||
module
|
||||
|
|
@ -156,8 +170,17 @@ PLANNED FEATURES:
|
|||
(current-linkage)
|
||||
(lambda (a b) (string<? (symbol->string a) (symbol->string b))))))
|
||||
|
||||
(define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
|
||||
(let* ([maj (read-from-string majstr)]
|
||||
[min (read-from-string minstr)]
|
||||
[path (string->path pathstr)])
|
||||
(add-hard-link ownerstr pkgstr maj min path)))
|
||||
|
||||
|
||||
(define (remove-hard-link-cmd ownerstr pkgstr majstr minstr)
|
||||
(let* ([maj (read-from-string majstr)]
|
||||
[min (read-from-string minstr)])
|
||||
(remove-hard-link ownerstr pkgstr maj min)))
|
||||
|
||||
|
||||
;; ------------------------------------------------------------
|
||||
;; Utility
|
||||
|
|
|
|||
|
|
@ -9,8 +9,6 @@ Various common pieces of code that both the client and server need to access
|
|||
(require (lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "port.ss")
|
||||
(prefix srfi1: (lib "1.ss" "srfi"))
|
||||
(lib "match.ss")
|
||||
(lib "file.ss")
|
||||
"../config.ss")
|
||||
|
||||
|
|
@ -83,37 +81,96 @@ Various common pieces of code that both the client and server need to access
|
|||
|
||||
; hard-links : FULL-PKG-SPEC -> (listof assoc-table-row)
|
||||
(define (hard-links pkg)
|
||||
|
||||
(filter
|
||||
(λ (row)
|
||||
(and (equal? (assoc-table-row->name row) (pkg-spec-name pkg))
|
||||
(equal? (assoc-table-row->path row) (pkg-spec-path pkg))))
|
||||
(get-hard-link-table)))
|
||||
|
||||
;; verify-well-formed-hard-link-parameter! : -> void
|
||||
;; pitches a fit if the hard link table parameter isn't set right
|
||||
(define (verify-well-formed-hard-link-parameter!)
|
||||
(unless (and (absolute-path? (HARD-LINK-FILE)) (path-only (HARD-LINK-FILE)))
|
||||
(raise (make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(format
|
||||
"The HARD-LINK-FILE setting must be an absolute path name specifying a file; given ~s"
|
||||
(HARD-LINK-FILE)))
|
||||
(current-continuation-marks))))
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; get-hard-link-table : -> assoc-table
|
||||
(define (get-hard-link-table)
|
||||
(verify-well-formed-hard-link-parameter!)
|
||||
(if (file-exists? (HARD-LINK-FILE))
|
||||
(map
|
||||
(lambda (item) (update-element 4 bytes->path item))
|
||||
(with-input-from-file (HARD-LINK-FILE) read-all))
|
||||
'()))
|
||||
|
||||
;; row-for-package? : row string (listof string) num num -> boolean
|
||||
;; determines if the row associates the given package with a dir
|
||||
(define (points-to? row name path maj min)
|
||||
(and (equal? name (assoc-table-row->name row))
|
||||
(equal? path (assoc-table-row->path row))
|
||||
(equal? maj (assoc-table-row->maj row))
|
||||
(equal? min (assoc-table-row->min row))))
|
||||
|
||||
;; save-hard-link-table : assoc-table -> void
|
||||
;; saves the given table, overwriting any file that might be there
|
||||
(define (save-hard-link-table table)
|
||||
(verify-well-formed-hard-link-parameter!)
|
||||
(with-output-to-file (HARD-LINK-FILE)
|
||||
(lambda ()
|
||||
(display "")
|
||||
(for-each
|
||||
(lambda (row)
|
||||
(write (update-element 4 path->bytes row))
|
||||
(newline))
|
||||
table))
|
||||
'truncate))
|
||||
|
||||
;; add-hard-link! string (listof string) num num path -> void
|
||||
;; adds the given hard link, clearing any previous ones already in place
|
||||
;; for the same package
|
||||
(define (add-hard-link! name path maj min dir)
|
||||
(let* ([original-table (get-hard-link-table)]
|
||||
[new-table (cons
|
||||
(list name path maj min dir)
|
||||
(filter
|
||||
(lambda (row) (not (points-to? row name path maj min)))
|
||||
original-table))])
|
||||
(save-hard-link-table new-table)))
|
||||
|
||||
;; filter-link-table! : (row -> boolean) -> void
|
||||
;; removes all rows from the link table that don't match the given predicate
|
||||
(define (filter-link-table! f)
|
||||
(save-hard-link-table (filter f (get-hard-link-table))))
|
||||
|
||||
;; update-element : number (x -> y) (listof any [x in position number]) -> (listof any [y in position number])
|
||||
(define (update-element n f l)
|
||||
(cond
|
||||
[(null? l) (error 'update-element "Index too large")]
|
||||
[(zero? n) (cons (f (car l)) (cdr l))]
|
||||
[else (cons (car l) (update-element (sub1 n) f (cdr l)))]))
|
||||
|
||||
(let ((link-table
|
||||
(if (file-exists? (HARD-LINK-FILE))
|
||||
(with-input-from-file (HARD-LINK-FILE) read)
|
||||
'())))
|
||||
(srfi1:filter-map
|
||||
(λ (row)
|
||||
(match row
|
||||
[`(,(? (λ (name) (equal? name (pkg-spec-name pkg))))
|
||||
,(? (λ (path) (equal? path (pkg-spec-path pkg))))
|
||||
,maj ,min ,(? bytes? dir))
|
||||
(list maj min (bytes->path dir))]
|
||||
[_ #f]))
|
||||
link-table)))
|
||||
|
||||
; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
|
||||
(define add-to-table append)
|
||||
|
||||
; assoc-table-row->{maj,min,dir} : assoc-table-row -> {num,num,path}
|
||||
; retrieve the {major version, minor version, directory} of the given row
|
||||
(define assoc-table-row->maj car)
|
||||
(define assoc-table-row->min cadr)
|
||||
(define assoc-table-row->dir caddr)
|
||||
;; first-n-list-selectors : number -> (values (listof x -> x) ...)
|
||||
;; returns n list selectors for the first n elements of a list
|
||||
;; (useful for defining meaningful names to list-structured data)
|
||||
(define (first-n-list-selectors n)
|
||||
(apply values (build-list n (lambda (m) (lambda (row) (list-ref row m))))))
|
||||
|
||||
;; assoc-table-row->{name,path,maj,min,dir} : assoc-table-row -> {string,(listof string),num,num,path}
|
||||
;; retrieve the {package name, "package path", major version, minor version, directory}
|
||||
;; of the given row
|
||||
(define-values (assoc-table-row->name
|
||||
assoc-table-row->path
|
||||
assoc-table-row->maj
|
||||
assoc-table-row->min
|
||||
assoc-table-row->dir)
|
||||
(first-n-list-selectors 5))
|
||||
|
||||
; get-best-match/t : assoc-table FULL-PKG-SPEC -> PKG | #f
|
||||
(define (get-best-match/t table spec)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,9 @@
|
|||
make-planet-archive
|
||||
get-installed-planet-archives
|
||||
remove-pkg
|
||||
unlink-all)
|
||||
unlink-all
|
||||
add-hard-link
|
||||
remove-hard-link)
|
||||
|
||||
;; current-cache-contents : -> ((string ((string ((nat (nat ...)) ...)) ...)) ...)
|
||||
;; returns the packages installed in the local PLaneT cache
|
||||
|
|
@ -148,4 +150,22 @@
|
|||
'file
|
||||
#f
|
||||
#f))
|
||||
(normalize-path archive-name)])))
|
||||
(normalize-path archive-name)]))
|
||||
|
||||
;; add-hard-link : string string num num path -> void
|
||||
;; adds an entry in the hard-links table associating the given
|
||||
;; require spec to the given path
|
||||
(define (add-hard-link owner pkg-name maj min path)
|
||||
(unless (directory-exists? path)
|
||||
(if (file-exists? path)
|
||||
(error 'add-hard-link "Hard links must point to directories, not files")
|
||||
(fprintf (current-error-port)
|
||||
"Warning: directory ~a does not exist\n"
|
||||
(path->string path))))
|
||||
(add-hard-link! pkg-name (list owner) maj min path))
|
||||
|
||||
;; remove-hard-link : string string num num -> void
|
||||
;; removes any development association from the given package spec
|
||||
(define (remove-hard-link owner pkg-name maj min)
|
||||
(filter-link-table!
|
||||
(lambda (row) (not (points-to? row pkg-name (list owner) maj min))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user