suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adding a few helpers that let packages know their names and version numbers

Browse Source 
svn: r7506
This commit is contained in:
Jacob Matthews 2007-10-16 00:29:53 +00:00
parent d78bfca30d
commit a4c853d32a
2 changed files with 89 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/planet/doc.txt
View File

@ -209,6 +209,23 @@ planet require specification. This function downloads and installs the
specified package if necessary, but does not verify that the actual
file within it actually exists.
> (this-package-version) :: SYNTAX
> (this-package-version-name) :: SYNTAX
> (this-package-version-owner) :: SYNTAX
> (this-package-version-maj) :: SYNTAX
> (this-package-version-min) :: SYNTAX
Macros that expand into expressions that evaluate to information about
the name, owner, and version number of the package in which they
appear. this-package-version returns a list consisting of a string
naming the package's owner, a string naming the package, a number
indicating the package major version and a number indicating the
package minor version, or #f if the expression appears outside the
context of a package. The others are just convenience macros that
select out the relevant field, or return #f if the expression
appears outside the context of a PLaneT package.
_The PLaneT search order_
-------------------------

74
collects/planet/util.ss
View File

@ -14,7 +14,8 @@
(lib "pack.ss" "setup")
(lib "plt-single-installer.ss" "setup")
(lib "getinfo.ss" "setup")
(lib "unpack.ss" "setup"))
(lib "unpack.ss" "setup")
(lib "etc.ss"))
#| The util collection provides a number of useful functions for interacting with the PLaneT system. |#
@ -436,4 +437,73 @@
(lambda (row)
(let ([p (row->package row)])
(when p
(erase-metadata p)))))))
(erase-metadata p))))))
;; ============================================================
;; VERSION INFO
(provide this-package-version
this-package-version-name
this-package-version-owner
this-package-version-maj
this-package-version-min)
(define-syntax (this-package-version stx)
(syntax-case stx ()
[(_)
#`(this-package-version/proc
#,(datum->syntax-object stx `(,#'this-expression-source-directory)))]))
(define-syntax define-getters
(syntax-rules ()
[(define-getters (name position) ...)
(begin
(define-syntax (name stx)
(syntax-case stx ()
[(name)
#`(let ([p #,(datum->syntax-object stx `(,#'this-package-version))])
(and p (position p)))]))
...)]))
(define-getters
(this-package-version-name pd->name)
(this-package-version-owner pd->owner)
(this-package-version-maj pd->maj)
(this-package-version-min pd->min))
;; ----------------------------------------
(define (this-package-version/proc srcdir)
(let* ([package-roots (get-all-planet-packages)]
[thepkg (ormap (predicate->projection (contains-dir? srcdir))
package-roots)])
(and thepkg (archive-retval->simple-retval thepkg))))
;; predicate->projection : #f \not\in X ==> (X -> boolean) -> (X -> X)
(define (predicate->projection pred) (λ (x) (if (pred x) x #f)))
;; contains-dir? : path -> pkg -> boolean
(define ((contains-dir? srcdir) alleged-superdir-pkg)
(let* ([nsrcdir (normalize-path srcdir)]
[nsuperdir (normalize-path (car alleged-superdir-pkg))]
[nsrclist (explode-path nsrcdir)]
[nsuperlist (explode-path nsuperdir)])
(list-prefix? nsuperlist nsrclist)))
(define (list-prefix? sup sub)
(let loop ([sub sub]
[sup sup])
(cond
[(null? sup) #t]
[(equal? (car sup) (car sub))
(loop (cdr sub) (cdr sup))]
[else #f])))
(define (archive-retval->simple-retval p)
(list-refs p '(1 2 4 5)))
(define-values (pd->owner pd->name pd->maj pd->min)
(apply values (map (λ (n) (λ (l) (list-ref l n))) '(0 1 2 3))))
(define (list-refs p ns)
(map (λ (n) (list-ref p n)) ns)))