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

Rackety

Browse Source
This commit is contained in:
Robby Findler 2011-02-05 20:59:58 -06:00
parent 1ed1396d95
commit 5017801659
12 changed files with 101 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
collects/planet/cachepath.rkt
View File

@ -1,14 +1,13 @@
(module cachepath mzscheme
#lang racket/base
(require "config.rkt")
(provide get-planet-cache-path)
(require "config.rkt")
(provide get-planet-cache-path)
;; get-planet-cache-path : -> path[absolute, file]
;; the path to the cache.rktd file for the planet installation
;; (n.b. this used to have the side effect of creating the path
;; if it didn't exist, but since this function may be run at
;; setup time and setup-time programs must not create this sort
;; of directory, it doesn't do that anymore)
(define (get-planet-cache-path)
(let ((path (build-path (PLANET-DIR) "cache.rktd")))
path)))
;; get-planet-cache-path : -> path[absolute, file]
;; the path to the cache.rktd file for the planet installation
;; (n.b. this used to have the side effect of creating the path
;; if it didn't exist, but since this function may be run at
;; setup time and setup-time programs must not create this sort
;; of directory, it doesn't do that anymore)
(define (get-planet-cache-path)
(let ((path (build-path (PLANET-DIR) "cache.rktd")))
path))

2
collects/planet/lang/reader.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require syntax/module-reader
"../resolver.ss")

2
collects/planet/parsereq.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require mzlib/match
"private/short-syntax-helpers.ss"

117
collects/planet/planet-archives.rkt
View File

@ -1,60 +1,57 @@
(module planet-archives mzscheme
(require "private/planet-shared.ss"
mzlib/file
"config.ss"
"cachepath.ss")
(provide repository-tree
get-installed-planet-archives
get-hard-linked-packages
get-all-planet-packages
get-planet-cache-path)
(define (repository-tree)
(define (id x) x)
(filter-tree-by-pattern
(directory->tree
(CACHE-DIR)
(lambda (x)
(not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x))))
4)
(list id id id string->number string->number)))
;; get-installed-planet-dirs : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all normally-installed planet archives [excluding hard links]
(define (get-installed-planet-archives)
(with-handlers ((exn:fail:filesystem:no-directory? (lambda (e) '())))
(tree-apply
(lambda (rep-name owner package maj min)
(let ((x (list
(build-path (CACHE-DIR) owner package (number->string maj) (number->string min))
owner
package
'()
maj
min)))
x))
(repository-tree)
3)))
;; get-hard-linked-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all hard-linked packages
(define (get-hard-linked-packages)
(map
(lambda (row)
(map (lambda (f) (f row))
(list assoc-table-row->dir
(lambda (r) (car (assoc-table-row->path r)))
assoc-table-row->name
(lambda (r) (cdr (assoc-table-row->path r)))
assoc-table-row->maj
assoc-table-row->min)))
(get-hard-link-table)))
;; get-all-planet-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; get every planet package, regardless of origin
(define (get-all-planet-packages)
(append (get-installed-planet-archives)
(get-hard-linked-packages)))
)
#lang racket/base
(require "private/planet-shared.ss"
"config.ss"
"cachepath.ss")
(provide repository-tree
get-installed-planet-archives
get-hard-linked-packages
get-all-planet-packages
get-planet-cache-path)
(define (repository-tree)
(define (id x) x)
(filter-tree-by-pattern
(directory->tree
(CACHE-DIR)
(lambda (x)
(not (regexp-match? #rx"/(?:[.]git.*|[.]svn|CVS)$" (path->string x))))
4)
(list id id id string->number string->number)))
;; get-installed-planet-dirs : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all normally-installed planet archives [excluding hard links]
(define (get-installed-planet-archives)
(with-handlers ((exn:fail:filesystem:no-directory? (lambda (e) '())))
(tree-apply
(lambda (rep-name owner package maj min)
(let ((x (list
(build-path (CACHE-DIR) owner package (number->string maj) (number->string min))
owner
package
'()
maj
min)))
x))
(repository-tree)
3)))
;; get-hard-linked-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; directories of all hard-linked packages
(define (get-hard-linked-packages)
(map
(lambda (row)
(map (lambda (f) (f row))
(list assoc-table-row->dir
(lambda (r) (car (assoc-table-row->path r)))
assoc-table-row->name
(lambda (r) (cdr (assoc-table-row->path r)))
assoc-table-row->maj
assoc-table-row->min)))
(get-hard-link-table)))
;; get-all-planet-packages : -> listof (list path[absolute, dir] string string (listof string) nat nat)
;; get every planet package, regardless of origin
(define (get-all-planet-packages)
(append (get-installed-planet-archives)
(get-hard-linked-packages)))

2
collects/planet/planet.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "private/cmdline-tool.rkt")
(with-handlers ([exn:fail?

26
collects/planet/private/cmdline-tool.rkt
View File

@ -1,18 +1,17 @@
(module planet mzscheme
#|
#lang racket/base
#|
This module contains code that implements the `planet' command-line tool.
PLANNED FEATURES:
* Disable a package without removing it (disabling meaning
that if it's a tool it won't start w/ DrRacket, etc)
|#
(require mzlib/string
mzlib/file
(only racket/path simple-form-path)
(only mzlib/list sort)
(require (only-in racket/path simple-form-path)
net/url
mzlib/match
racket/file
racket/match
raco/command-name
(only-in mzlib/string read-from-string)
"../config.rkt"
"planet-shared.rkt"
@ -160,7 +159,7 @@ This command does not unpack or install the named .plt file."
(when (file-exists? pkg)
(fail "Cannot download, there is a file named ~a in the way" pkg))
(match (download-package full-pkg-spec)
[(#t path maj min)
[(list #t path maj min)
(copy-file path pkg)
(printf "Downloaded ~a package version ~a.~a\n" pkg maj min)]
[_
@ -214,7 +213,9 @@ This command does not unpack or install the named .plt file."
(for-each
(lambda (l) (apply printf " ~a \t~a \t~a ~a\n" l))
(sort-by-criteria
(map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages)
(map (lambda (x) (match x [(list _ owner pkg _ maj min)
(list owner pkg maj min)]))
normal-packages)
(list string<? string=?)
(list string<? string=?)
(list < =)
@ -226,7 +227,8 @@ This command does not unpack or install the named .plt file."
(lambda (l) (apply printf " ~a\t~a\t~a ~a\n --> ~a\n" l))
(sort-by-criteria
(map
(lambda (x) (match x [(dir owner pkg _ maj min) (list owner pkg maj min (path->string dir))]))
(lambda (x) (match x [(list dir owner pkg _ maj min)
(list owner pkg maj min (path->string dir))]))
devel-link-packages)
(list string<? string=?)
(list string<? string=?)
@ -252,7 +254,7 @@ This command does not unpack or install the named .plt file."
(for-each
(lambda (link) (apply printf " ~a\t~a\t~a ~a\n" link))
(cdr module)))
(sort (current-linkage) (lambda (a b) (string<? (car a) (car b))))))
(sort (current-linkage) string<? #:key car)))
(define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
(let* ([maj (read-from-string majstr)]
@ -300,4 +302,4 @@ This command does not unpack or install the named .plt file."
[(null? a) #f]
[((caar c) (car a) (car b)) #t]
[(not ((cadar c) (car a) (car b))) #f]
[else (loop (cdr a) (cdr b) (cdr c))]))))))
[else (loop (cdr a) (cdr b) (cdr c))])))))

8
collects/planet/private/command.rkt
View File

@ -1,11 +1,11 @@
#lang scheme/base
#lang racket/base
(require "prefix-dispatcher.ss"
scheme/cmdline
(for-syntax scheme/base))
racket/cmdline
(for-syntax racket/base))
(provide svn-style-command-line)
;; implements an "svn-style" command-line interface as a wrapper around scheme/cmdline. At the moment,
;; implements an "svn-style" command-line interface as a wrapper around racket/cmdline. At the moment,
;; it is light on error-checking and makes choices that are somewhat specific to the PLaneT commandline
;; tool, thus its inclusion in planet/private rather than somewhere more visible. The idea is that you
;; write

10
collects/planet/private/planet-shared.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
#| planet-shared.ss -- shared client/server utility functions
Various common pieces of code that both the client and server need to access
@ -125,7 +125,7 @@ Various common pieces of code that both the client and server need to access
empty-table))
; the link table format:
; (listof (list string[name] (listof string[path]) num num bytes[directory] (union string[mzscheme version] #f))
; (listof (list string[name] (listof string[path]) num num bytes[directory] (union string[racket version] #f))
; hard-links : FULL-PKG-SPEC -> (listof assoc-table-row)
(define (hard-links pkg)
@ -302,8 +302,8 @@ Various common pieces of code that both the client and server need to access
;; version<= : mz-version mz-version -> boolean
;; determines if a is the version string of an earlier mzscheme release than b
;; [n.b. this relies on a guarantee from Matthew that mzscheme version
;; determines if a is the version string of an earlier racket release than b
;; [n.b. this relies on a guarantee from Matthew that racket version
;; x1.y1 is older than version x2.y2 iff x1<x2 or x1=x2 and y1<y2]
(define (version<= a b)
(or (<= (mz-version-major a) (mz-version-major b))
@ -425,7 +425,7 @@ Various common pieces of code that both the client and server need to access
(loop (cdr l) (add1 n))])))
; nat? : TST -> bool
; determines if the given scheme value is a natural number
; determines if the given value is a natural number
(define (nat? obj) (and (integer? obj) (>= obj 0)))
; read-n-chars-to-file : Nat input-port string[filename] -> void

4
collects/planet/private/prefix-dispatcher.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base))
(require (for-syntax racket/base))
(provide (all-defined-out))
;; ============================================================

2
collects/planet/private/short-syntax-helpers.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide (all-defined-out))

2
collects/planet/raco.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "private/cmdline-tool.rkt")
(with-handlers ([exn:fail?

4
collects/planet/terse-info.rkt
View File

@ -3,11 +3,11 @@
#|
This file is shared between the original
namespace that drscheme first starts with
namespace that drracket first starts with
any other namespaces that it loads,
so it keeps the requirements low (it could
be in the '#%kernel language, but
drscheme already shares mred/mred, so there
drracket already shares mred/mred, so there
seems little point to that).
|#