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

finally restored check-again-all, using file-or-directory-identity

Browse Source 
svn: r16548
This commit is contained in:
Eli Barzilay 2009-11-04 20:57:13 +00:00
parent c49b22fa2c
commit eb3dacaac5
1 changed files with 22 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
collects/setup/setup-unit.ss
View File

@ -305,90 +305,28 @@
subs))))
(define (check-again-all given-ccs)
;; the function below has two parts: the first (doubly) commented part is
;; od code that relies on having an identity for a directory, and cannot be
;; used as explained there. The solution was to put "marker" files to
;; identify directories, but that doesn't work out too, since it requires
;; writing into the directories which might not be possible and not needed.
;; Specifically, installing planet libraries calls setup on
;; scribblings/main/user -- but there's no need to write in there. (This
;; is especially bad on vista which creates a virtual user directory...)
;; So the whole thing is disabled for now, and we plan to add a new new
;; system level function for getting the identity of a file or a directory
;; and use the original code here.
given-ccs)
#;
(define (check-again-all given-ccs)
#|
;; This code is better than using marker files, but an older version of it
;; relied on the obligatory existence of an "info.ss" file to implement
;; `file-or-directory-identity'. That is no longer required, so it needs
;; to identify directories and that is currently not available. So use the
;; code below it instead. Perhaps there will be some robust way to do this
;; in the future, eg -- for directories, use the identity of their first
;; file.
(define all-cc+ids
(map (lambda (cc)
(cons cc (file-or-directory-identity (cc-path cc))))
(plt-collection-closure all-collections)))
(for ([cc given-ccs])
(define given-id
(file-or-directory-identity (cc-path cc)))
(for ([found-cc+id all-cc+ids]
#:when (not (same-collection-name? cc (car found-cc+id))))
(when (eq? (cdr found-cc+id) given-id)
(error 'setup-plt
"given collection path: ~e refers to the same info file as another path: ~e"
(apply build-path (cc-collection cc))
(apply build-path (cc-collection (car found-cc+id)))))))
|#
;; Note: this is not a locking mechanism; specifically, if we find a marker
;; file we assume that we generated it rather than another setup-plt
;; process
(define all-ccs (plt-collection-closure all-collections))
(define (cc->name cc)
(string-join (map path->string (cc-collection cc)) "/"))
(define all-names (map cc->name all-ccs))
(define given-names (map cc->name given-ccs))
(define (cc-mark cc) (build-path (cc-path cc) ".setup-plt-marker"))
(define (complain-about-mark name mark)
(let ([given (with-handlers ([void (lambda (_) '???)])
(with-input-from-file mark read-line))])
(error 'setup-plt
"given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\""
name given)))
;; For cleanup: try to remove all files, be silent
(define (cleanup)
(for ([cc (append given-ccs all-ccs)])
(let ([mark (cc-mark cc)])
(when (file-exists? mark)
(with-handlers ([void void]) (delete-file mark))))))
;; First remove all marker files if any, let it fail if we can't remove it
(define (remove-markers)
(for ([cc given-ccs])
(let ([mark (cc-mark cc)])
(when (file-exists? mark)
(setup-printf "WARNING"
"found a marker file, deleting: ~a"
(path->name mark))
(delete-file mark)))))
;; Now create all marker files, signalling an error if duplicate
(define (put-markers)
(for ([cc given-ccs] [name given-names])
(let ([mark (cc-mark cc)])
(if (file-exists? mark)
(complain-about-mark name mark)
(with-output-to-file mark (lambda () (printf "~a\n" name)))))))
;; Finally scan all ccs and look for duplicates
(define (scan-all)
(for ([cc all-ccs] [name all-names])
(when (and (not (member name given-names))
(file-exists? (cc-mark cc)))
(complain-about-mark name (cc-mark cc)))))
(dynamic-wind
void
(lambda () (remove-markers) (put-markers) (scan-all) given-ccs)
cleanup))
(define (cc->cc+name+id cc)
(list cc
(string-join (map path->string (cc-collection cc)) "/")
(file-or-directory-identity (cc-path cc))))
(define all-ccs+names+ids
(map cc->cc+name+id (plt-collection-closure all-collections)))
(define given-ccs+names+ids
(remove-duplicates
(map cc->cc+name+id (plt-collection-closure given-ccs))
(lambda (x y) (equal? (cadr x) (cadr y)))))
(for ([given-cc+name+id (in-list given-ccs+names+ids)])
(cond
[(ormap (lambda (cc+name+id)
(and (not (equal? (cadr cc+name+id) (cadr given-cc+name+id)))
(equal? (caddr cc+name+id) (caddr given-cc+name+id))
(cadr cc+name+id)))
all-ccs+names+ids)
=> (lambda (bad)
(error 'setup-plt
"given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\""
(cadr given-cc+name+id) bad))]))
(map car given-ccs+names+ids))
(define (sort-collections ccs)
(sort ccs string<? #:key cc-name))