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

Fix for PR8884

Browse Source 
svn: r7141
This commit is contained in:
Jacob Matthews 2007-08-22 06:51:06 +00:00
parent fb9b192516
commit 8d769c151c
1 changed files with 32 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
collects/planet/util.ss
View File

@ -94,13 +94,41 @@
[cache-file (build-path (PLANET-DIR) "cache.ss")]) [cache-file (build-path (PLANET-DIR) "cache.ss")])
(when (file-exists? cache-file) (when (file-exists? cache-file)
(let ([cache-lines (with-input-from-file cache-file read)]) (let ([cache-lines (with-input-from-file cache-file read)])
(with-output-to-file cache-file (call-with-output-file cache-file
(lambda () (λ (op)
(if (pair? cache-lines) (if (pair? cache-lines)
(write (filter (lambda (line) (not (and (pair? line) (equal? (car line) pathbytes)))) cache-lines)) (write (filter
(printf "\n"))) (λ (line)
(not
(and
(pair? line)
(or (not (directory-exists? (bytes->path (car line))))
(subpath? path (bytes->path (car line)))))))
cache-lines)
op)
(fprintf op "\n")))
'truncate/replace))))) 'truncate/replace)))))
;; subpath? : path path -> boolean
;; determines if p1 is a subpath of p2. Both paths must actually exist on the filesystem
(define (subpath? p1 p2)
(let ([full-p1 (explode-path (normalize-path p1))]
[full-p2 (explode-path (normalize-path p2))])
(sublist? full-p1 full-p2 (o2 bytes=? path->bytes))))
;; o2 : (X X -> Y) (Z -> X) -> (Z Z -> Y)
;; "compose-two"
(define (o2 a b) (λ (x y) (a (b x) (b y))))
;; sublist? : (listof X) (listof X) (X X -> boolean) -> boolean
;; determine if l1 is a sublist of l2, using = as the comparison operator for elements
(define (sublist? l1 l2 =)
(cond
[(null? l1) #t]
[(null? l2) #f]
[(= (car l1) (car l2)) (sublist? (cdr l1) (cdr l2) =)]
[else #f]))
(define (erase-pkg owner name maj min) (define (erase-pkg owner name maj min)
(let* ([uninstalled-pkg-dir (let* ([uninstalled-pkg-dir
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))] (build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]