From e9b8eda96430dfe553b20fef6be2b13bf36381cd Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Fri, 20 Jan 2006 22:48:29 +0000 Subject: [PATCH] .Added support for creating and deleting development links to the planet cmd-line tool. svn: r1906 --- collects/planet/config.ss | 11 ++- collects/planet/doc.txt | 44 +++++++++- collects/planet/planet.ss | 25 +++++- collects/planet/private/planet-shared.ss | 103 ++++++++++++++++++----- collects/planet/util.ss | 24 +++++- 5 files changed, 174 insertions(+), 33 deletions(-) diff --git a/collects/planet/config.ss b/collects/planet/config.ss index bbd3211e4b..dbbd41d7ac 100644 --- a/collects/planet/config.ss +++ b/collects/planet/config.ss @@ -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)) diff --git a/collects/planet/doc.txt b/collects/planet/doc.txt index 3261f423e9..01c1ef6bb5 100644 --- a/collects/planet/doc.txt +++ b/collects/planet/doc.txt @@ -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 + +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 + +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_ ----------------------------------- diff --git a/collects/planet/planet.ss b/collects/planet/planet.ss index bfa7eaf6df..355928fd68 100644 --- a/collects/planet/planet.ss +++ b/collects/planet/planet.ss @@ -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) (stringstring 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 diff --git a/collects/planet/private/planet-shared.ss b/collects/planet/private/planet-shared.ss index 6c75bc643f..9a76c9d2d8 100644 --- a/collects/planet/private/planet-shared.ss +++ b/collects/planet/private/planet-shared.ss @@ -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) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 0da9c6a3a4..01932f86fd 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -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)]))) \ No newline at end of file + (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))))))