diff --git a/collects/browser/private/hyper.ss b/collects/browser/private/hyper.ss index 2e4b9fcc82..700bed7061 100644 --- a/collects/browser/private/hyper.ss +++ b/collects/browser/private/hyper.ss @@ -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") diff --git a/collects/compiler/distribute.ss b/collects/compiler/distribute.ss index b2d49d4b39..a10cf3ce51 100644 --- a/collects/compiler/distribute.ss +++ b/collects/compiler/distribute.ss @@ -1,6 +1,7 @@ (module distribute scheme/base (require scheme/file + scheme/path (lib "dirs.ss" "setup") (lib "list.ss") (lib "variant.ss" "setup") diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 1604bdbc1d..aced50c93e 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -1,7 +1,8 @@ (module embed-unit scheme/base (require scheme/unit - scheme/file + scheme/path + scheme/file scheme/port syntax/moddep xml/plist diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 806adc5dcc..19c525da2e 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -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")) diff --git a/collects/drscheme/private/multi-file-search.ss b/collects/drscheme/private/multi-file-search.ss index 8b12fc944b..846c9a2287 100644 --- a/collects/drscheme/private/multi-file-search.ss +++ b/collects/drscheme/private/multi-file-search.ss @@ -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") diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 79b05ab4fa..b162929030 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -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) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index aad7d6b94f..2a83d23915 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -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^] diff --git a/collects/framework/private/finder.ss b/collects/framework/private/finder.ss index 801fc8184d..c71eb1de20 100644 --- a/collects/framework/private/finder.ss +++ b/collects/framework/private/finder.ss @@ -5,7 +5,7 @@ "../preferences.ss" (lib "mred-sig.ss" "mred") (lib "string.ss") - scheme/file + scheme/path (lib "etc.ss")) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 4763a0f744..332bc27caf 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -8,7 +8,7 @@ "bday.ss" (lib "mred-sig.ss" "mred") (lib "list.ss") - scheme/file + scheme/path (lib "etc.ss")) (import mred^ diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index 1d0adab4f9..61e103702e 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -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^] diff --git a/collects/framework/private/handler.ss b/collects/framework/private/handler.ss index c4eed5add8..08382d1746 100644 --- a/collects/framework/private/handler.ss +++ b/collects/framework/private/handler.ss @@ -7,7 +7,7 @@ "../preferences.ss" "../gui-utils.ss" (lib "mred-sig.ss" "mred") - scheme/file + scheme/path (lib "string-constant.ss" "string-constants")) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 0097c50997..ff542f7071 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -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" diff --git a/collects/launcher/launcher-unit.ss b/collects/launcher/launcher-unit.ss index 095dcdec15..72bbfbd98a 100644 --- a/collects/launcher/launcher-unit.ss +++ b/collects/launcher/launcher-unit.ss @@ -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") diff --git a/collects/mzlib/file.ss b/collects/mzlib/file.ss index 3901693da6..2a6aa56293 100644 --- a/collects/mzlib/file.ss +++ b/collects/mzlib/file.ss @@ -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)]) diff --git a/collects/scheme/file.ss b/collects/scheme/file.ss index bb7125e6a1..1c6db0adb4 100644 --- a/collects/scheme/file.ss +++ b/collects/scheme/file.ss @@ -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) (stringcomplete-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) (stringkey 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)))))))) diff --git a/collects/scheme/main.ss b/collects/scheme/main.ss index 80174c9797..9a2be3f5cb 100644 --- a/collects/scheme/main.ss +++ b/collects/scheme/main.ss @@ -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)))) diff --git a/collects/scheme/path.ss b/collects/scheme/path.ss new file mode 100644 index 0000000000..d093181713 --- /dev/null +++ b/collects/scheme/path.ss @@ -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]))) diff --git a/collects/scribble/base-render.ss b/collects/scribble/base-render.ss index 9d4589a90e..5006a34503 100644 --- a/collects/scribble/base-render.ss +++ b/collects/scribble/base-render.ss @@ -3,7 +3,8 @@ (require "struct.ss" mzlib/class mzlib/serialize - scheme/file) + scheme/file + scheme/path) (provide render%) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index d66f6562f8..2780d33af5 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -2,6 +2,7 @@ (module html-render scheme/base (require "struct.ss" scheme/class + scheme/path scheme/file mzlib/runtime-path setup/main-doc diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 6738aa2bb5..79cdb894f8 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -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 diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 70b781cd65..e54876c0db 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/collects/scribblings/reference/filesystem.scrbl @@ -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].} + diff --git a/collects/scribblings/reference/paths.scrbl b/collects/scribblings/reference/paths.scrbl index 09591508ae..4c82a6f2e5 100644 --- a/collects/scribblings/reference/paths.scrbl +++ b/collects/scribblings/reference/paths.scrbl @@ -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"] diff --git a/collects/setup/scribble-index.ss b/collects/setup/scribble-index.ss index 5038e82ce4..4dad3984a6 100644 --- a/collects/setup/scribble-index.ss +++ b/collects/setup/scribble-index.ss @@ -9,7 +9,7 @@ setup/getinfo setup/dirs mzlib/serialize - scheme/file) + scheme/path) (provide load-xref xref-render diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss index 6753ba8e43..162b34e0f9 100644 --- a/collects/slideshow/viewer.ss +++ b/collects/slideshow/viewer.ss @@ -4,6 +4,7 @@ scheme/unit scheme/contract scheme/list + scheme/path scheme/file mred (lib "mrpict.ss" "texpict")