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

split part of scheme/file into scheme/path, document them

Browse Source 
svn: r7938
This commit is contained in:
Matthew Flatt 2007-12-10 17:59:26 +00:00
parent 3fa9f2bd5c
commit ca5a7c5560
24 changed files with 777 additions and 415 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/browser/private/hyper.ss
View File

@ -32,6 +32,7 @@ A test case:
(require (lib "class.ss")
"sig.ss"
scheme/path
scheme/file
(lib "url-sig.ss" "net")
(lib "url-structs.ss" "net")

1
collects/compiler/distribute.ss
View File

@ -1,6 +1,7 @@
(module distribute scheme/base
(require scheme/file
scheme/path
(lib "dirs.ss" "setup")
(lib "list.ss")
(lib "variant.ss" "setup")

3
collects/compiler/embed-unit.ss
View File

@ -1,7 +1,8 @@
(module embed-unit scheme/base
(require scheme/unit
scheme/file
scheme/path
scheme/file
scheme/port
syntax/moddep
xml/plist

2
collects/drscheme/private/main.ss
View File

@ -11,7 +11,7 @@
(prefix-in print-convert: (lib "pconvert.ss"))
(lib "include.ss")
(lib "list.ss")
scheme/file
scheme/path
(lib "external.ss" "browser")
(lib "plt-installer.ss" "setup"))

1
collects/drscheme/private/multi-file-search.ss
View File

@ -4,6 +4,7 @@
(lib "class.ss")
(lib "mred.ss" "mred")
scheme/file
scheme/path
(lib "thread.ss")
(lib "async-channel.ss")
(lib "string-constant.ss" "string-constants")

2
collects/drscheme/private/unit.ss
View File

@ -15,7 +15,7 @@ module browser threading seems wrong.
(require scheme/contract
scheme/unit
scheme/class
scheme/file
scheme/path
scheme/port
scheme/list
(only-in (lib "etc.ss") compose)

2
collects/framework/private/editor.ss
View File

@ -7,7 +7,7 @@
"../gui-utils.ss"
(lib "etc.ss")
(lib "mred-sig.ss" "mred")
scheme/file)
scheme/path)
(import mred^
[prefix autosave: framework:autosave^]

2
collects/framework/private/finder.ss
View File

@ -5,7 +5,7 @@
"../preferences.ss"
(lib "mred-sig.ss" "mred")
(lib "string.ss")
scheme/file
scheme/path
(lib "etc.ss"))

2
collects/framework/private/frame.ss
View File

@ -8,7 +8,7 @@
"bday.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
scheme/file
scheme/path
(lib "etc.ss"))
(import mred^

2
collects/framework/private/group.ss
View File

@ -7,7 +7,7 @@
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
(lib "list.ss")
scheme/file)
scheme/path)
(import mred^
[prefix application: framework:application^]

2
collects/framework/private/handler.ss
View File

@ -7,7 +7,7 @@
"../preferences.ss"
"../gui-utils.ss"
(lib "mred-sig.ss" "mred")
scheme/file
scheme/path
(lib "string-constant.ss" "string-constants"))

2
collects/framework/private/text.ss
View File

@ -9,7 +9,7 @@ WARNING: printf is rebound in the body of the unit to always
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")
(lib "match.ss")
scheme/file
scheme/path
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"

3
collects/launcher/launcher-unit.ss
View File

@ -1,7 +1,8 @@
#lang scheme/unit
(require scheme/file
(require scheme/path
scheme/file
(lib "compile-sig.ss" "dynext")
(lib "link-sig.ss" "dynext")

10
collects/mzlib/file.ss
View File

@ -1,5 +1,6 @@
(module file scheme/base
(require scheme/file
scheme/path
(prefix-in mz: (only-in mzscheme
open-input-file
open-output-file)))
@ -27,6 +28,15 @@
find-files
pathlist-closure)
(define (build-relative-path p . args)
(if (relative-path? p)
(apply build-path p args)
(error 'build-relative-path "base path ~s is absolute" p)))
(define (build-absolute-path p . args)
(if (relative-path? p)
(error 'build-absolute-path "base path ~s is relative" p)
(apply build-path p args)))
(define (find-library name . cp)
(let ([dir (with-handlers ([exn:fail:filesystem? (lambda (exn) #f)])

627
collects/scheme/file.ss
View File

@ -1,305 +1,138 @@
(module file scheme/base
(provide find-relative-path
explode-path
normalize-path
build-absolute-path
build-relative-path
filename-extension
file-name-from-path
path-only
delete-directory/files
copy-directory/files
make-directory*
make-temporary-file
#lang scheme/base
get-preference
put-preferences
(provide delete-directory/files
copy-directory/files
make-directory*
make-temporary-file
fold-files
find-files
pathlist-closure)
get-preference
put-preferences
(define (build-relative-path p . args)
(if (relative-path? p)
(apply build-path p args)
(error 'build-relative-path "base path ~s is absolute" p)))
fold-files
find-files
pathlist-closure)
(define (build-absolute-path p . args)
(if (relative-path? p)
(error 'build-absolute-path "base path ~s is relative" p)
(apply build-path p args)))
;; utility: sorted dirlist so functions are deterministic
(define (sorted-dirlist [dir (current-directory)])
(let* ([ps (directory-list dir)]
[ps (map (lambda (p) (cons (path->string p) p)) ps)]
[ps (sort ps (lambda (p1 p2) (string<? (car p1) (car p2))))]
[ps (map cdr ps)])
ps))
;; Note that normalize-path does not normalize the case
(define normalize-path
(letrec ([resolve-all
(lambda (path wrt)
(let ([orig-path (if (and wrt (not (complete-path? path)))
(path->complete-path path wrt)
path)])
(let loop ([full-path orig-path][seen-paths (list orig-path)])
(let ([resolved (resolve-path full-path)])
(if (equal? resolved full-path)
(do-normalize-path resolved #f)
(let ([path (if (relative-path? resolved)
(build-path
(let-values ([(base name dir?) (split-path full-path)])
base)
resolved)
resolved)])
(if (member path seen-paths)
(error 'normalize-path "circular reference at ~s" path)
(let ([spath
;; Use simplify-path to get rid of ..s, which can
;; allow the path to grow indefinitely in a cycle.
;; An exception must mean a cycle of links.
(with-handlers ([exn:fail:filesystem?
(lambda (x)
(error 'normalize-path "circular reference at ~s" path))])
(simplify-path path))])
(loop spath (cons path seen-paths))))))))))]
[resolve
(lambda (path)
(if (equal? path (resolve-path path))
path
(resolve-all path #f)))]
[normalize-path
(case-lambda
[(orig-path) (do-normalize-path orig-path (current-directory))]
[(orig-path wrt)
(unless (complete-path? wrt)
(raise-type-error 'normalize-path "complete path" wrt))
(do-normalize-path orig-path wrt)])]
[error-not-a-dir
(lambda (path)
(error 'normalize-path
"~s (within the input path) is not a directory or does not exist"
path))]
[do-normalize-path
(lambda (orig-path wrt)
(let normalize ([path (cleanse-path orig-path)])
(let-values ([(base name dir?) (split-path path)])
(cond
[(eq? name 'up)
(let up ([base (if (eq? base 'relative)
wrt
(resolve-all base wrt))])
(if (directory-exists? base)
(let-values ([(prev name dir?) (split-path base)])
(cond
[(not prev)
(error 'normalize-path
"root has no parent directory: ~s"
orig-path)]
[else
(let ([prev
(if (eq? prev 'relative)
wrt
(normalize prev))])
(cond
[(eq? name 'same) (up prev)]
[(eq? name 'up) (up (up prev))]
[else prev]))]))
(error-not-a-dir base)))]
[(eq? name 'same)
(cond
[(eq? base 'relative) wrt]
[else (let ([n (normalize base)])
(if (directory-exists? n)
n
(error-not-a-dir n)))])]
[(not base) (path->complete-path path)]
[else
(let* ([base (if (eq? base 'relative)
(normalize wrt)
(normalize base))]
[path (if (directory-exists? base)
(build-path base name)
(error-not-a-dir base))]
[resolved (cleanse-path (resolve path))])
(cond
[(relative-path? resolved)
(normalize (build-path base resolved))]
[(complete-path? resolved)
resolved]
[else (path->complete-path resolved base)]))]))))])
normalize-path))
(define (delete-directory/files path)
(unless (path-string? path)
(raise-type-error 'delete-directory/files "path or string" path))
(cond
[(or (link-exists? path) (file-exists? path))
(delete-file path)]
[(directory-exists? path)
(for-each (lambda (e) (delete-directory/files (build-path path e)))
(sorted-dirlist path))
(delete-directory path)]
[else (error 'delete-directory/files
"encountered ~a, neither a file nor a directory"
path)]))
;; Argument must be in normal form
(define (do-explode-path who orig-path)
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(when (or (and base (not (path? base)))
(not (path? name)))
(raise-type-error who "path in normal form" orig-path))
(if base
(loop base (cons name rest))
(cons name rest)))))
(define (copy-directory/files src dest)
(cond [(file-exists? src)
(copy-file src dest)]
[(directory-exists? src)
(make-directory dest)
(for-each (lambda (e)
(copy-directory/files (build-path src e)
(build-path dest e)))
(sorted-dirlist src))]
[else (error 'copy-directory/files
"encountered ~a, neither a file nor a directory"
src)]))
(define (explode-path orig-path)
(unless (path-string? orig-path)
(raise-type-error 'explode-path "path or string" orig-path))
(do-explode-path 'explode-path orig-path))
(define (make-directory* dir)
(let-values ([(base name dir?) (split-path dir)])
(when (and (path? base)
(not (directory-exists? base)))
(make-directory* base))
(unless (directory-exists? dir)
(make-directory dir))))
;; Arguments must be in normal form
(define (find-relative-path directory filename)
(let ([dir (do-explode-path 'find-relative-path directory)]
[file (do-explode-path 'find-relative-path filename)])
(if (equal? (car dir) (car file))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond [(null? dir) (if (null? file) filename (apply build-path file))]
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(equal? (car dir) (car file))
(loop (cdr dir) (cdr file))]
[else
(apply build-path (append (map (lambda (x) 'up) dir) file))]))
filename)))
(define (file-name who name)
(unless (path-string? name)
(raise-type-error who "path or string" name))
(let-values ([(base file dir?) (split-path name)])
(and (not dir?) (path? file) file)))
(define (file-name-from-path name)
(file-name 'file-name-from-path name))
(define (path-only name)
(unless (path-string? name)
(raise-type-error 'path-only "path or string" name))
(let-values ([(base file dir?) (split-path name)])
(cond [dir? name]
[(path? base) base]
[else #f])))
;; name can be any string; we just look for a dot
(define (filename-extension name)
(let* ([name (file-name 'filename-extension name)]
[name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
[else #f])))
;; utility: sorted dirlist so functions are deterministic
(define (sorted-dirlist . args)
(let* ([ps (apply directory-list args)]
[ps (map (lambda (p) (cons (path->string p) p)) ps)]
[ps (sort ps (lambda (p1 p2) (string<? (car p1) (car p2))))]
[ps (map cdr ps)])
ps))
(define (delete-directory/files path)
(unless (path-string? path)
(raise-type-error 'delete-directory/files "path or string" path))
(cond
[(or (link-exists? path) (file-exists? path))
(delete-file path)]
[(directory-exists? path)
(for-each (lambda (e) (delete-directory/files (build-path path e)))
(sorted-dirlist path))
(delete-directory path)]
[else (error 'delete-directory/files
"encountered ~a, neither a file nor a directory"
path)]))
(define (copy-directory/files src dest)
(cond [(file-exists? src)
(copy-file src dest)]
[(directory-exists? src)
(make-directory dest)
(for-each (lambda (e)
(copy-directory/files (build-path src e)
(build-path dest e)))
(sorted-dirlist src))]
[else (error 'copy-directory/files
"encountered ~a, neither a file nor a directory"
src)]))
(define (make-directory* dir)
(let-values ([(base name dir?) (split-path dir)])
(when (and (path? base)
(not (directory-exists? base)))
(make-directory* base))
(unless (directory-exists? dir)
(make-directory dir))))
(define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
(with-handlers ([exn:fail:contract?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
template))])
(format template void))
(unless (or (not copy-from)
(path-string? copy-from)
(eq? copy-from 'directory))
(raise-type-error 'make-temporary-file
"path, valid-path string, 'directory, or #f"
copy-from))
(unless (or (not base-dir) (path-string? base-dir))
(raise-type-error 'make-temporary-file
"path, valid-path, string, or #f"
base-dir))
(let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)][ms (current-milliseconds)])
(let ([name (let ([n (format template (format "~a~a" s ms))])
(cond [base-dir (build-path base-dir n)]
[(relative-path? n) (build-path tmpdir n)]
[else n]))])
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
;; try again with a new name
(loop (- s (random 10))
(+ ms (random 10))))])
(if copy-from
(define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f])
(with-handlers ([exn:fail:contract?
(lambda (x)
(raise-type-error 'make-temporary-file
"format string for 1 argument"
template))])
(format template void))
(unless (or (not copy-from)
(path-string? copy-from)
(eq? copy-from 'directory))
(raise-type-error 'make-temporary-file
"path, valid-path string, 'directory, or #f"
copy-from))
(unless (or (not base-dir) (path-string? base-dir))
(raise-type-error 'make-temporary-file
"path, valid-path, string, or #f"
base-dir))
(let ([tmpdir (find-system-path 'temp-dir)])
(let loop ([s (current-seconds)][ms (current-milliseconds)])
(let ([name (let ([n (format template (format "~a~a" s ms))])
(cond [base-dir (build-path base-dir n)]
[(relative-path? n) (build-path tmpdir n)]
[else n]))])
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
;; try again with a new name
(loop (- s (random 10))
(+ ms (random 10))))])
(if copy-from
(if (eq? copy-from 'directory)
(make-directory name)
(copy-file copy-from name))
(make-directory name)
(copy-file copy-from name))
(close-output-port (open-output-file name)))
name)))))
name)))))
(define (with-pref-params thunk)
(parameterize ([read-case-sensitive #f]
[read-square-bracket-as-paren #t]
[read-curly-brace-as-paren #t]
[read-accept-box #t]
[read-accept-compiled #f]
[read-accept-bar-quote #t]
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-infix-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #f]
[print-struct #f]
[print-graph #f] ; <--- FIXME: temporary solution to DrScheme-pref problem
[print-box #t]
[print-vector-length #t]
[current-readtable #f])
(thunk)))
(define (with-pref-params thunk)
(parameterize ([read-case-sensitive #f]
[read-square-bracket-as-paren #t]
[read-curly-brace-as-paren #t]
[read-accept-box #t]
[read-accept-compiled #f]
[read-accept-bar-quote #t]
[read-accept-graph #t]
[read-decimal-as-inexact #t]
[read-accept-dot #t]
[read-accept-infix-dot #t]
[read-accept-quasiquote #t]
[read-accept-reader #f]
[print-struct #f]
[print-graph #f] ; <--- FIXME: temporary solution to DrScheme-pref problem
[print-box #t]
[print-vector-length #t]
[current-readtable #f])
(thunk)))
(define pref-cache (make-weak-box #f))
(define pref-cache (make-weak-box #f))
(define (path->key p)
(string->symbol (bytes->string/latin-1 (path->bytes p))))
(define (path->key p)
(string->symbol (bytes->string/latin-1 (path->bytes p))))
(define (pref-cache-install! fn-key fn-date f)
(let ([table (or (weak-box-value pref-cache)
(make-hash-table))])
(hash-table-put! table
(path->key fn-key)
(cons
(file-or-directory-modify-seconds fn-date #f (lambda () -inf.0))
f))
(unless (eq? table (weak-box-value pref-cache))
(set! pref-cache (make-weak-box table)))))
(define (pref-cache-install! fn-key fn-date f)
(let ([table (or (weak-box-value pref-cache)
(make-hash-table))])
(hash-table-put! table
(path->key fn-key)
(cons
(file-or-directory-modify-seconds fn-date #f (lambda () -inf.0))
f))
(unless (eq? table (weak-box-value pref-cache))
(set! pref-cache (make-weak-box table)))))
(define (get-prefs flush-mode filename)
(define (read-prefs default-pref-file)
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(let* ([pref-file
(or filename
(let ([f default-pref-file])
(if (file-exists? f)
(define (get-prefs flush-mode filename)
(define (read-prefs default-pref-file)
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
(let* ([pref-file
(or filename
(let ([f default-pref-file])
(if (file-exists? f)
;; Using `file-exists?' means there's technically a
;; race condition, but something has gone really wrong
;; if the file disappears.
@ -307,84 +140,84 @@
;; Error here bails out through above `with-handlers'
(build-path (collection-path "defaults")
"plt-prefs.ss"))))]
[prefs (with-pref-params
(lambda ()
(with-input-from-file pref-file read)))])
;; Make sure file content had the right shape:
(if (and (list? prefs)
(andmap (lambda (x)
(and (pair? x) (pair? (cdr x)) (null? (cddr x))))
prefs))
[prefs (with-pref-params
(lambda ()
(with-input-from-file pref-file read)))])
;; Make sure file content had the right shape:
(if (and (list? prefs)
(andmap (lambda (x)
(and (pair? x) (pair? (cdr x)) (null? (cddr x))))
prefs))
prefs
null))))
(let* ([fn (path->complete-path
(or filename
(find-system-path 'pref-file)))]
[cache (let ([table (weak-box-value pref-cache)])
(and table (hash-table-get table (path->key fn) #f)))])
(if (and cache
(or (not flush-mode)
(and (eq? flush-mode 'timestamp)
(= (car cache)
(file-or-directory-modify-seconds fn #f (lambda () -inf.0))))))
(cdr cache)
(let ([ts (file-or-directory-modify-seconds fn #f (lambda () -inf.0))]
[f (read-prefs fn)])
(pref-cache-install! fn fn f)
f))))
(let* ([fn (path->complete-path
(or filename
(find-system-path 'pref-file)))]
[cache (let ([table (weak-box-value pref-cache)])
(and table (hash-table-get table (path->key fn) #f)))])
(if (and cache
(or (not flush-mode)
(and (eq? flush-mode 'timestamp)
(= (car cache)
(file-or-directory-modify-seconds fn #f (lambda () -inf.0))))))
(cdr cache)
(let ([ts (file-or-directory-modify-seconds fn #f (lambda () -inf.0))]
[f (read-prefs fn)])
(pref-cache-install! fn fn f)
f))))
(define (get-preference name [fail-thunk (lambda () #f)]
[refresh-cache? 'timestamp]
[filename #f])
(unless (symbol? name)
(raise-type-error 'get-preference "symbol" name))
(unless (and (procedure? fail-thunk)
(procedure-arity-includes? fail-thunk 0))
(raise-type-error 'get-preference "procedure (arity 0)" fail-thunk))
(let ([f (get-prefs refresh-cache? filename)])
(let ([m (assq name f)])
(if m (cadr m) (fail-thunk)))))
(define (get-preference name [fail-thunk (lambda () #f)]
[refresh-cache? 'timestamp]
[filename #f])
(unless (symbol? name)
(raise-type-error 'get-preference "symbol" name))
(unless (and (procedure? fail-thunk)
(procedure-arity-includes? fail-thunk 0))
(raise-type-error 'get-preference "procedure (arity 0)" fail-thunk))
(let ([f (get-prefs refresh-cache? filename)])
(let ([m (assq name f)])
(if m (cadr m) (fail-thunk)))))
(define (put-preferences names vals [lock-there #f] [filename #f])
(unless (and (list? names) (andmap symbol? names))
(raise-type-error 'put-preferences "list of symbols" names))
(unless (list? vals)
(raise-type-error 'put-preferences "list" vals))
(unless (= (length names) (length vals))
(raise-mismatch-error
'put-preferences
(format "the size of the name list (~a) does not match the size of the value list (~a): "
(length names) (length vals))
vals))
(let-values ([(pref-file lock-file pref-dir)
(let ([filename (or filename (find-system-path 'pref-file))])
(let-values ([(base name dir?) (split-path filename)])
(let ([dir (if (symbol? base)
(define (put-preferences names vals [lock-there #f] [filename #f])
(unless (and (list? names) (andmap symbol? names))
(raise-type-error 'put-preferences "list of symbols" names))
(unless (list? vals)
(raise-type-error 'put-preferences "list" vals))
(unless (= (length names) (length vals))
(raise-mismatch-error
'put-preferences
(format "the size of the name list (~a) does not match the size of the value list (~a): "
(length names) (length vals))
vals))
(let-values ([(pref-file lock-file pref-dir)
(let ([filename (or filename (find-system-path 'pref-file))])
(let-values ([(base name dir?) (split-path filename)])
(let ([dir (if (symbol? base)
(current-directory)
base)])
(unless (directory-exists? dir)
(make-directory* dir))
(values
filename
(build-path dir
(bytes->path-element
(bytes-append
(if (eq? 'windows (system-type))
(unless (directory-exists? dir)
(make-directory* dir))
(values
filename
(build-path dir
(bytes->path-element
(bytes-append
(if (eq? 'windows (system-type))
#"_"
#".")
#"LOCK"
(path-element->bytes name))))
dir))))])
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
(if lock-there
#"LOCK"
(path-element->bytes name))))
dir))))])
(with-handlers ([exn:fail:filesystem:exists?
(lambda (x)
(if lock-there
(lock-there lock-file)
(error 'put-preferences
"some other process has the preference-file lock, as indicated by the existence of the lock file: ~e"
lock-file)))])
;; Grab lock:
(close-output-port (open-output-file lock-file #:exists 'error))
(dynamic-wind
;; Grab lock:
(close-output-port (open-output-file lock-file #:exists 'error))
(dynamic-wind
void
(lambda ()
(let ([f (get-prefs #t filename)])
@ -422,11 +255,11 @@
(for-each (lambda (a)
(if (and (list? (cadr a))
(< 4 (length (cadr a))))
(begin
(printf " (~s\n (\n" (car a))
(for-each (lambda (i) (printf " ~s\n" i)) (cadr a))
(printf " ))\n"))
(printf " ~s\n" a)))
(begin
(printf " (~s\n (\n" (car a))
(for-each (lambda (i) (printf " ~s\n" i)) (cadr a))
(printf " ))\n"))
(printf " ~s\n" a)))
f)
(printf ")\n"))))))
;; Install the new table in the cache. It's possible that this
@ -443,39 +276,47 @@
;; Release lock:
(delete-file lock-file))))))
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
(define (fold-files f init [path #f] [follow-links? #t])
(define (do-path path acc)
(cond [(and (not follow-links?) (link-exists? path)) (f path 'link acc)]
[(directory-exists? path)
(call-with-values (lambda () (f path 'dir acc))
(letrec ([descend
(case-lambda
[(acc)
(do-paths (map (lambda (p) (build-path path p))
(sorted-dirlist path))
acc)]
[(acc descend?)
(if descend? (descend acc) acc)])])
descend))]
[(file-exists? path) (f path 'file acc)]
[(link-exists? path) (f path 'link acc)] ; dangling links
[else (error 'fold-files "path disappeared: ~e" path)]))
(define (do-paths paths acc)
(cond [(null? paths) acc]
[else (do-paths (cdr paths) (do-path (car paths) acc))]))
(if path (do-path path init) (do-paths (sorted-dirlist) init)))
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
(define (fold-files f init [path #f] [follow-links? #t])
(define (do-path path acc)
(cond [(and (not follow-links?) (link-exists? path)) (f path 'link acc)]
[(directory-exists? path)
(call-with-values (lambda () (f path 'dir acc))
(letrec ([descend
(case-lambda
[(acc)
(do-paths (map (lambda (p) (build-path path p))
(sorted-dirlist path))
acc)]
[(acc descend?)
(if descend? (descend acc) acc)])])
descend))]
[(file-exists? path) (f path 'file acc)]
[(link-exists? path) (f path 'link acc)] ; dangling links
[else (error 'fold-files "path disappeared: ~e" path)]))
(define (do-paths paths acc)
(cond [(null? paths) acc]
[else (do-paths (cdr paths) (do-path (car paths) acc))]))
(if path (do-path path init) (do-paths (sorted-dirlist) init)))
(define (find-files f [path #f])
(reverse
(fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
null path)))
(define (find-files f [path #f])
(reverse
(fold-files (lambda (path kind acc) (if (f path) (cons path acc) acc))
null path)))
(define (pathlist-closure paths)
(let loop ([paths (map (lambda (p) (simplify-path (resolve-path p) #f))
paths)]
[r '()])
(if (null? paths)
(define (pathlist-closure paths)
(let loop ([paths (map (lambda (p)
(let ([p2 (if (link-exists? p)
(let ([p2 (resolve-path p)])
(if (relative-path? p2)
(let-values ([(base name dir?) (split-path p)])
(build-path base p2))
p2))
p)])
(simplify-path p2 #f)))
paths)]
[r '()])
(if (null? paths)
(reverse r)
(let loop2 ([path (car paths)]
[new (cond [(file-exists? (car paths))
@ -487,8 +328,6 @@
(car paths))])])
(let-values ([(base name dir?) (split-path path)])
(if (path? base)
(loop2 base (if (or (member base r) (member base paths))
new (cons base new)))
(loop (cdr paths) (append (reverse new) r))))))))
)
(loop2 base (if (or (member base r) (member base paths))
new (cons base new)))
(loop (cdr paths) (append (reverse new) r))))))))

6
collects/scheme/main.ss
View File

@ -9,6 +9,8 @@
scheme/tcp
scheme/udp
scheme/list
scheme/path
scheme/file
(for-syntax scheme/base))
(provide (all-from-out scheme/contract
@ -21,5 +23,7 @@
scheme/base
scheme/tcp
scheme/udp
scheme/list)
scheme/list
scheme/path
scheme/file)
(for-syntax (all-from-out scheme/base))))

167
collects/scheme/path.ss Normal file
View File

@ -0,0 +1,167 @@
#lang scheme/base
(provide find-relative-path
explode-path
simple-form-path
normalize-path
filename-extension
file-name-from-path
path-only)
(define (simple-form-path p)
(unless (path-string? p)
(raise-type-error 'simple-form-path "path or string" p))
(simplify-path (path->complete-path p)))
;; Note that normalize-path does not normalize the case
(define normalize-path
(letrec ([resolve-all
(lambda (path wrt)
(let ([orig-path (if (and wrt (not (complete-path? path)))
(path->complete-path path wrt)
path)])
(let loop ([full-path orig-path][seen-paths (list orig-path)])
(let ([resolved (resolve-path full-path)])
(if (equal? resolved full-path)
(do-normalize-path resolved #f)
(let ([path (if (relative-path? resolved)
(build-path
(let-values ([(base name dir?) (split-path full-path)])
base)
resolved)
resolved)])
(if (member path seen-paths)
(error 'normalize-path "circular reference at ~s" path)
(let ([spath
;; Use simplify-path to get rid of ..s, which can
;; allow the path to grow indefinitely in a cycle.
;; An exception must mean a cycle of links.
(with-handlers ([exn:fail:filesystem?
(lambda (x)
(error 'normalize-path "circular reference at ~s" path))])
(simplify-path path))])
(loop spath (cons path seen-paths))))))))))]
[resolve
(lambda (path)
(if (equal? path (resolve-path path))
path
(resolve-all path #f)))]
[normalize-path
(case-lambda
[(orig-path) (do-normalize-path orig-path (current-directory))]
[(orig-path wrt)
(unless (complete-path? wrt)
(raise-type-error 'normalize-path "complete path" wrt))
(do-normalize-path orig-path wrt)])]
[error-not-a-dir
(lambda (path)
(error 'normalize-path
"~s (within the input path) is not a directory or does not exist"
path))]
[do-normalize-path
(lambda (orig-path wrt)
(let normalize ([path (cleanse-path orig-path)])
(let-values ([(base name dir?) (split-path path)])
(cond
[(eq? name 'up)
(let up ([base (if (eq? base 'relative)
wrt
(resolve-all base wrt))])
(if (directory-exists? base)
(let-values ([(prev name dir?) (split-path base)])
(cond
[(not prev)
(error 'normalize-path
"root has no parent directory: ~s"
orig-path)]
[else
(let ([prev
(if (eq? prev 'relative)
wrt
(normalize prev))])
(cond
[(eq? name 'same) (up prev)]
[(eq? name 'up) (up (up prev))]
[else prev]))]))
(error-not-a-dir base)))]
[(eq? name 'same)
(cond
[(eq? base 'relative) wrt]
[else (let ([n (normalize base)])
(if (directory-exists? n)
n
(error-not-a-dir n)))])]
[(not base) (path->complete-path path)]
[else
(let* ([base (if (eq? base 'relative)
(normalize wrt)
(normalize base))]
[path (if (directory-exists? base)
(build-path base name)
(error-not-a-dir base))]
[resolved (cleanse-path (resolve path))])
(cond
[(relative-path? resolved)
(normalize (build-path base resolved))]
[(complete-path? resolved)
resolved]
[else (path->complete-path resolved base)]))]))))])
normalize-path))
;; Argument must be in simple form
(define (do-explode-path who orig-path simple?)
(let loop ([path orig-path][rest '()])
(let-values ([(base name dir?) (split-path path)])
(when simple?
(when (or (and base (not (path? base)))
(not (path? name)))
(raise-type-error who
"path in simple form (absolute, complete, and with no same- or up-directory indicators)"
orig-path)))
(if (path? base)
(loop base (cons name rest))
(cons name rest)))))
(define (explode-path orig-path)
(unless (path-string? orig-path)
(raise-type-error 'explode-path "path or string" orig-path))
(do-explode-path 'explode-path orig-path #f))
;; Arguments must be in simple form
(define (find-relative-path directory filename)
(let ([dir (do-explode-path 'find-relative-path directory #t)]
[file (do-explode-path 'find-relative-path filename #t)])
(if (equal? (car dir) (car file))
(let loop ([dir (cdr dir)]
[file (cdr file)])
(cond [(null? dir) (if (null? file) filename (apply build-path file))]
[(null? file) (apply build-path (map (lambda (x) 'up) dir))]
[(equal? (car dir) (car file))
(loop (cdr dir) (cdr file))]
[else
(apply build-path (append (map (lambda (x) 'up) dir) file))]))
filename)))
(define (file-name who name)
(unless (path-string? name)
(raise-type-error who "path or string" name))
(let-values ([(base file dir?) (split-path name)])
(and (not dir?) (path? file) file)))
(define (file-name-from-path name)
(file-name 'file-name-from-path name))
(define (path-only name)
(unless (path-string? name)
(raise-type-error 'path-only "path or string" name))
(let-values ([(base file dir?) (split-path name)])
(cond [dir? name]
[(path? base) base]
[else #f])))
;; name can be any string; we just look for a dot
(define (filename-extension name)
(let* ([name (file-name 'filename-extension name)]
[name (and name (path->bytes name))])
(cond [(and name (regexp-match #rx#"[.]([^.]+)$" name)) => cadr]
[else #f])))

3
collects/scribble/base-render.ss
View File

@ -3,7 +3,8 @@
(require "struct.ss"
mzlib/class
mzlib/serialize
scheme/file)
scheme/file
scheme/path)
(provide render%)

1
collects/scribble/html-render.ss
View File

@ -2,6 +2,7 @@
(module html-render scheme/base
(require "struct.ss"
scheme/class
scheme/path
scheme/file
mzlib/runtime-path
setup/main-doc

35
collects/scribble/manual.ss
View File

@ -510,6 +510,23 @@
"bad argument form"
#'arg)]))
(define-syntax (arg-default stx)
(syntax-case stx (... ...+ _...superclass-args...)
[(_ [id contract])
(identifier? #'id)
#'#f]
[(_ [id contract val])
(identifier? #'id)
#'(schemeblock0 val)]
[(_ [kw id contract])
(keyword? (syntax-e #'kw))
#'#f]
[(_ [kw id contract val])
(keyword? (syntax-e #'kw))
#'(schemeblock0 val)]
[else
#'#f]))
(define-syntax defproc
(syntax-rules ()
[(_ (id arg ...) result desc ...)
@ -523,6 +540,7 @@
(list (quote-syntax/loc id) ...)
'[(id arg ...) ...]
(list (list (lambda () (arg-contract arg)) ...) ...)
(list (list (lambda () (arg-default arg)) ...) ...)
(list (lambda () (schemeblock0 result)) ...)
(lambda () (list desc ...)))]))
(define-syntax defstruct
@ -745,7 +763,7 @@
(or (get-exporting-libraries render part ri) null)))))
(define (*defproc mode within-id
stx-ids prototypes arg-contractss result-contracts content-thunk)
stx-ids prototypes arg-contractss arg-valss result-contracts content-thunk)
(let ([spacer (hspace 1)]
[has-optional? (lambda (arg)
(and (pair? arg)
@ -803,7 +821,7 @@
(apply
append
(map
(lambda (stx-id prototype arg-contracts result-contract first?)
(lambda (stx-id prototype arg-contracts arg-vals result-contract first?)
(let*-values ([(required optional more-required)
(let loop ([a (cdr prototype)][r-accum null])
(if (or (null? a)
@ -992,7 +1010,7 @@
(list end)))))
null)
(apply append
(map (lambda (v arg-contract)
(map (lambda (v arg-contract arg-val)
(cond
[(pair? v)
(let* ([v (if (keyword? (car v))
@ -1001,8 +1019,9 @@
[arg-cont (arg-contract)]
[base-len (+ 5 (string-length (symbol->string (car v)))
(flow-element-width arg-cont))]
[arg-val (and arg-val (arg-val))]
[def-len (if (has-optional? v)
(string-length (format "~a" (caddr v)))
(flow-element-width arg-val)
0)]
[base-list
(list
@ -1028,7 +1047,7 @@
(to-flow spacer)
(to-flow "=")
(to-flow spacer)
(to-flow (to-element (caddr v)))))))
(make-flow (list arg-val))))))
(make-table-if-necessary
"argcontract"
(list
@ -1039,14 +1058,16 @@
(list (to-flow spacer)
(to-flow "=")
(to-flow spacer)
(to-flow (to-element (caddr v))))
(make-flow (list arg-val)))
null)))))))))]
[else null]))
(cdr prototype)
arg-contracts)))))
arg-contracts
arg-vals)))))
stx-ids
prototypes
arg-contractss
arg-valss
result-contracts
(let loop ([ps prototypes][accum null])
(cond

249
collects/scribblings/reference/filesystem.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@require["mz.ss"]
@(require "mz.ss"
(for-label framework/preferences))
@title{Filesystem}
@ -362,3 +363,249 @@ start with @litchar["\\\\?\\REL\\\\"].}
Returns a list of all current root directories. Obtaining this list
can be particularly slow under Windows.}
@;------------------------------------------------------------------------
@section{More File and Directory Utilities}
@note-lib[scheme/file]
@defproc[(copy-directory/files [src path-string?][dest path-string?])
void?]{
Copies the file or directory @scheme[src] to @scheme[dest], raising
@scheme[exn:fail:filesystem] if the file or directory cannot be
copied, possibly because @scheme[dest] exists already. If @scheme[src]
is a directory, the copy applies recursively to the directory's
content. If a source is a link, the target of the link is copied
rather than the link itself.}
@defproc[(delete-directory/files [path path-string?])
void?]{
Deletes the file or directory specified by @scheme[path], raising
@scheme[exn:fail:filesystem] if the file or directory cannot be
deleted. If @scheme[path] is a directory, then
@scheme[delete-directory/files] is first applied to each file and
directory in @scheme[path] before the directory is deleted.}
@defproc[(find-files [predicate (path? . -> . any/c)]
[start-path (or/c path-string? false/c) #f])
(listof path?)]{
Traverses the filesystem starting at @scheme[start-path] and creates a
list of all files and directories for which @scheme[predicate] returns
true. If @scheme[start-path] is @scheme[#f], then the traversal starts
from @scheme[(current-directory)]. In the resulting list, each
directory precedes its content.
The @scheme[predicate] procedure is called with a single argument for
each file or directory. If @scheme[start-path] is @scheme[#f], the
argument is a pathname string that is relative to the current
directory. Otherwise, it is a path building on
@scheme[start-path]. Consequently, supplying
@scheme[(current-directory)] for @scheme[start-path] is different from
supplying @scheme[#f], because @scheme[predicate] receives complete
paths in the former case and relative paths in the latter. Another
difference is that @scheme[predicate] is not called for the current
directory when @scheme[start-path] is @scheme[#f].
The @scheme[find-files] traversal follows soft links. To avoid
following links, use the more general @scheme[fold-files] procedure.
If @scheme[start-path] does not refer to an existing file or
directory, then @scheme[predicate] will be called exactly once with
@scheme[start-path] as the argument.}
@defproc[(pathlist-closure [path-list (listof path-string?)])
(listof path?)]{
Given a list of paths, either absolute or relative to the current
directory, returns a list such that
@itemize{
@item{if a nested path is given, all of its ancestors are also
included in the result (but the same ancestor is not added
twice);}
@item{if a path refers to directory, all of its descendants are also
included in the result;}
@item{ancestor directories appear before their descendants in the
result list.}
}}
@defproc[(fold-files [proc (and/c (path? (one-of/c 'file 'dir 'link) any/c
. -> . any/c)
(or/c procedure?
((path? (one-of/c 'dir) any/c)
. ->* . (any/c any/c))))]
[init-val any/c]
[start-path (or/c path-string? false/c) #f]
[follow-links? any/c #t])
any]{
Traverses the filesystem starting at @scheme[start-path], calling
@scheme[proc] on each discovered file, directory, and link. If
@scheme[start-path] is @scheme[#f], then the traversal starts from
@scheme[(current-directory)].
The @scheme[proc] procedure is called with three arguments for each
file, directory, or link:
@itemize{
@item{If @scheme[start-path] is @scheme[#f], the first argument is a
pathname string that is relative to the current directory. Otherwise,
the first argument is a pathname that starts with
@scheme[start-path]. Consequently, supplying
@scheme[(current-directory)] for @scheme[start-path] is different
from supplying @scheme[#f], because @scheme[proc] receives complete
paths in the former case and relative paths in the latter. Another
difference is that @scheme[proc] is not called for the current
directory when @scheme[start-path] is @scheme[#f].}
@item{The second argument is a symbol, either @scheme['file],
@scheme['dir], or @scheme['link]. The second argument can be
@scheme['link] when @scheme[follow-links?] is @scheme[#f],
in which case the filesystem traversal does not follow links. If
@scheme[follow-links?] is @scheme[#t], then @scheme[proc]
will only get a @scheme['link] as a second argument when it
encounters a dangling symbolic link (one that does not resolve to an
existing file or directory).}
@item{The third argument is the accumulated result. For the first
call to @scheme[proc], the third argument is @scheme[init-val]. For the
second call to @scheme[proc] (if any), the third argument is the result
from the first call, and so on. The result of the last call to
@scheme[proc] is the result of @scheme[fold-files].}
}
The @scheme[proc] argument is used in an analogous way to the
procedure argument of @scheme[foldl], where its result is used as the
new accumulated result. There is an exception for the case of a
directory (when the second argument is @scheme['dir]): in this case
the procedure may return two values, the second indicating whether the
recursive scan should include the given directory or not. If it
returns a single value, the directory is scanned.
An error is signaled if the @scheme[start-path] is provided but no
such path exists, or if paths disappear during the scan.}
@defproc[(make-directory* [path path-string?]) void?]{
Creates directory specified by @scheme[path], creating intermediate
directories as necessary.}
@defproc[(make-temporary-file [template string? "mztmp~a"]
[copy-from-filename (or/c path-string? false/c (one-of/c 'directory)) #f]
[directory (or/c path-string? false/c) #f])
path?]{
Creates a new temporary file and returns a pathname string for the
file. Instead of merely generating a fresh file name, the file is
actually created; this prevents other threads or processes from
picking the same temporary name.
The @scheme[template] argument must be a format string suitable
for use with @scheme[format] and one additional string argument (where
the string contains only digits). If the resulting string is a
relative path, it is combined with the result of
@scheme[(find-system-path 'temp-dir)], unless @scheme[directory] is
provided and non-@scheme[#f], in which case the
file name generated from @scheme[template] is combined with
@scheme[directory] to obtain a full path.
If @scheme[copy-from-filename] is provided as path, the temporary file
is created as a copy of the named file (using @scheme[copy-file]). If
@scheme[copy-from-filename] is @scheme[#f], the temporary file is
created as empty. If @scheme[copy-from-filename] is
@scheme['directory], then the temporary ``file'' is created as a
directory.
When a temporary file is created, it is not opened for reading or
writing when the pathname is returned. The client program calling
@scheme[make-temporary-file] is expected to open the file with the
desired access and flags (probably using the @scheme['truncate] flag;
see @scheme[open-output-file]) and to delete it when it is no longer
needed.}
@defproc[(get-preference [name symbol?]
[failure-thunk (-> any) (lambda () #f)]
[flush-mode any/c 'timestamp]
[filename (or/c string-path? false/c) #f])
any]{
Extracts a preference value from the file designated by
@scheme[(find-system-path 'pref-file)], or by @scheme[filename] if it
is provided and is not @scheme[#f]. In the former case, if the
preference file doesn't exist, @scheme[get-preferences] attempts to
read a @filepath{plt-prefs.ss} file in the @filepath{defaults}
collection, instead. If neither file exists, the preference set is
empty.
The preference file should contain a symbol-keyed association list
(written to the file with the default parameter settings). Keys
starting with @scheme[mzscheme:], @scheme[mred:], and @scheme[plt:] in
any letter case are reserved for use by PLT.
The result of @scheme[get-preference] is the value associated with
@scheme[name] if it exists in the association list, or the result of
calling @scheme[failure-thunk] otherwise.
Preference settings are cached (weakly) across calls to
@scheme[get-preference], using @scheme[(path->complete-path filename)]
as a cache key. If @scheme[flush-mode] is provided as @scheme[#f], the
cache is used instead of the re-consulting the preferences file. If
@scheme[flush-mode] is provided as @scheme['timestamp] (the default),
then the cache is used only if the file has a timestamp that is the
same as the last time the file was read. Otherwise, the file is
re-consulted.
See also @scheme[put-preferences]. For a more elaborate preference
system, see @scheme[preferences:get].}
@defproc[(put-preferences [names (listof symbol?)]
[vals list?]
[locked-proc (path? . -> . any) (lambda (p) (error ....))]
[filename (or/c false/c path-string?) #f])
void?]{
Installs a set of preference values and writes all current values to
the preference file designated by @scheme[(find-system-path
'pref-file)], or @scheme[filename] if it is supplied and not
@scheme[#f].
The @scheme[names] argument supplies the preference names, and
@scheme[vals] must have the same length as @scheme[names]. Each
element of @scheme[vals] must be an instance of a built-in data type
whose @scheme[write] output is @scheme[read]able (i.e., the
@scheme[print-unreadable] parameter is set to @scheme[#f] while
writing preferences).
Current preference values are read from the preference file before
updating, and an update ``lock'' is held starting before the file
read, and lasting until after the preferences file is updated. The
lock is implemented by the existence of a file in the same directory
as the preference file. If the directory of the preferences file does
not already exist, it is created.
If the update lock is already held (i.e., the lock file exists), then
@scheme[locked] is called with a single argument: the path of the lock
file. The default @scheme[locked] reports an error; an alternative
thunk might wait a while and try again, or give the user the choice to
delete the lock file (in case a previous update attempt encountered
disaster).
If @scheme[filename] is @scheme[#f] or not supplied, and the
preference file does not already exist, then values read from the
@filepath{defaults} collection (if any) are written for preferences
that are not mentioned in @scheme[names].}

66
collects/scribblings/reference/paths.scrbl
View File

@ -483,6 +483,72 @@ end of the path element. The @scheme[path] argument can be a path for
any platform, and the result is for the same platform. If
@scheme[path] represents a root, the @exnraise[exn:fail:contract].}
@;------------------------------------------------------------------------
@section{More Path Utilities}
@note-lib[scheme/path]
@defproc[(explode-path [path path-string?])
(listof (or/c path? (one-of/c 'up 'same)))]{
Returns the list of path element that constitute @scheme[path]. If
@scheme[path] is simplified in the sense of @scheme[simple-form-path],
then the result is always a list of paths, and the first element of
the list is a root.}
@defproc[(file-name-from-path [path path-string?]) (or/c path? false/c)]{
Returns the last element of @scheme[path]. If @scheme[path]
syntactically a directory path (see @scheme[split-path]), then then
result is @scheme[#f].}
@defproc[(filename-extension [path path-string?])
(or/c bytes? false/c)]{
Returns a byte string that is the extension part of the filename in
@scheme[path] without the @litchar{.} separator. If @scheme[path] is
syntactically a directory (see @scheme[split-path]) or if the path has
no extension, @scheme[#f] is returned.}
@defproc[(find-relative-path [base path-string?][path path-string?]) path?]{
Finds a relative pathname with respect to @scheme[basepath] that names
the same file or directory as @scheme[path]. Both @scheme[basepath]
and @scheme[path] must be simplified in the sense of
@scheme[simple-form-path]. If @scheme[path] is not a proper subpath
of @scheme[basepath] (i.e., a subpath that is strictly longer),
@scheme[path] is returned.}
@defproc[(normalize-path [path path-string?]
[wrt (and/c path-string? complete-path?)
(current-directory)])
path?]{
Returns a normalized, complete version of @scheme[path], expanding the
path and resolving all soft links. If @scheme[path] is relative, then
@scheme[wrt] is used as the base path.
Letter case is @italic{not} normalized by @scheme[normalize-path]. For
this and other reasons, such as whether the path is syntactically a
directory, the result of @scheme[normalize-path] is not suitable for
comparisons that determine whether two paths refer to the same file or
directory (i.e., the comparison may produce false negatives).
An error is signaled by @scheme[normalize-path] if the input
path contains an embedded path for a non-existent directory,
or if an infinite cycle of soft links is detected.}
@defproc[(path-only [path path-string?]) (or/c path? false/c)]{
If @scheme[path] is a filename, the file's path is returned. If
@scheme[path] is syntactically a directory, @scheme[#f] is returned.}
@defproc[(simple-form-path [path path-string?]) path?]{
Returns @scheme[(simplify-path (path->complete-path path))], which
ensures that the result is a complete path containing no up- or
same-directory indicators.}
@;------------------------------------------------------------------------
@include-section["unix-paths.scrbl"]
@include-section["windows-paths.scrbl"]

2
collects/setup/scribble-index.ss
View File

@ -9,7 +9,7 @@
setup/getinfo
setup/dirs
mzlib/serialize
scheme/file)
scheme/path)
(provide load-xref
xref-render

1
collects/slideshow/viewer.ss
View File

@ -4,6 +4,7 @@
scheme/unit
scheme/contract
scheme/list
scheme/path
scheme/file
mred
(lib "mrpict.ss" "texpict")