676 lines
29 KiB
Racket
676 lines
29 KiB
Racket
#lang racket/base
|
|
(require "path.rkt"
|
|
(for-syntax racket/base
|
|
setup/path-to-relative))
|
|
|
|
(provide delete-directory/files
|
|
copy-directory/files
|
|
make-directory*
|
|
make-temporary-file
|
|
|
|
get-preference
|
|
put-preferences
|
|
preferences-lock-file-mode
|
|
make-handle-get-preference-locked
|
|
make-lock-file-name
|
|
call-with-file-lock/timeout
|
|
|
|
fold-files
|
|
find-files
|
|
pathlist-closure
|
|
|
|
file->string
|
|
file->bytes
|
|
file->value
|
|
file->lines
|
|
file->bytes-lines
|
|
file->list
|
|
display-to-file
|
|
write-to-file
|
|
display-lines-to-file
|
|
|
|
user-read-bit
|
|
user-write-bit
|
|
user-execute-bit
|
|
group-read-bit
|
|
group-write-bit
|
|
group-execute-bit
|
|
other-read-bit
|
|
other-write-bit
|
|
other-execute-bit)
|
|
|
|
(require "private/portlines.rkt")
|
|
|
|
;; 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))
|
|
|
|
(define (delete-directory/files path)
|
|
(unless (path-string? path)
|
|
(raise-argument-error 'delete-directory/files "path-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-syntax (make-temporary-file stx)
|
|
(with-syntax ([app (datum->syntax stx #'#%app stx)])
|
|
(syntax-case stx ()
|
|
[x (identifier? #'x) #'make-temporary-file/proc]
|
|
[(_)
|
|
(let ()
|
|
(define line (syntax-line stx))
|
|
(define col (syntax-column stx))
|
|
(define source (syntax-source stx))
|
|
(define pos (syntax-position stx))
|
|
(define str-src
|
|
(cond [(path? source)
|
|
(regexp-replace #rx"^<(.*?)>(?=/)"
|
|
(path->relative-string/library source)
|
|
(lambda (_ s) (string-upcase s)))]
|
|
[(string? source) source]
|
|
[else #f]))
|
|
(define str-loc
|
|
(cond [(and line col) (format "-~a-~a" line col)]
|
|
[pos (format "--~a" pos)]
|
|
[else ""]))
|
|
(define combined-str (string-append (or str-src "rkttmp") str-loc))
|
|
(define sanitized-str (regexp-replace* #rx"[<>:\"/\\|]" combined-str "-"))
|
|
(define max-len 50) ;; must be even
|
|
(define not-too-long-str
|
|
(cond [(< max-len (string-length sanitized-str))
|
|
(string-append (substring sanitized-str 0 (- (/ max-len 2) 2))
|
|
"----"
|
|
(substring sanitized-str
|
|
(- (string-length sanitized-str)
|
|
(- (/ max-len 2) 2))))]
|
|
[else sanitized-str]))
|
|
#`(app make-temporary-file/proc
|
|
#,(string-append not-too-long-str "_~a")))]
|
|
[(_ . whatever)
|
|
#'(app make-temporary-file/proc . whatever)])))
|
|
|
|
(define make-temporary-file/proc
|
|
(let ()
|
|
(define (make-temporary-file [template "rkttmp~a"] [copy-from #f] [base-dir #f])
|
|
(with-handlers ([exn:fail:contract?
|
|
(lambda (x)
|
|
(raise-arguments-error 'make-temporary-file
|
|
"format string does not expect 1 argument"
|
|
"format string" template))])
|
|
(format template void))
|
|
(unless (or (not copy-from)
|
|
(path-string? copy-from)
|
|
(eq? copy-from 'directory))
|
|
(raise-argument-error 'make-temporary-file
|
|
"(or/c path-string? 'directory #f)"
|
|
copy-from))
|
|
(unless (or (not base-dir) (path-string? base-dir))
|
|
(raise-argument-error 'make-temporary-file
|
|
"(or/c path-string? #f)"
|
|
base-dir))
|
|
(let ([tmpdir (find-system-path 'temp-dir)])
|
|
(let loop ([s (current-seconds)]
|
|
[ms (inexact->exact (truncate (current-inexact-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))
|
|
(close-output-port (open-output-file name)))
|
|
name)))))
|
|
make-temporary-file))
|
|
|
|
(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 DrRacket-pref problem
|
|
[print-box #t]
|
|
[print-vector-length #t]
|
|
[current-readtable #f])
|
|
(thunk)))
|
|
|
|
(define pref-cache (make-weak-box #f))
|
|
|
|
(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-hasheq))])
|
|
(hash-set! 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 (make-pathless-lock-file-name name)
|
|
(bytes->path-element
|
|
(bytes-append
|
|
(if (eq? 'windows (system-type))
|
|
#"_"
|
|
#".")
|
|
#"LOCK"
|
|
(path-element->bytes name))))
|
|
|
|
(define make-lock-file-name
|
|
(case-lambda
|
|
[(path)
|
|
(unless (path-string? path)
|
|
(raise-argument-error 'make-lock-file-name "path-string?" path))
|
|
(let-values ([(dir name dir?) (split-path path)])
|
|
(if (eq? dir 'relative)
|
|
(make-pathless-lock-file-name name)
|
|
(make-lock-file-name dir name)))]
|
|
[(dir name)
|
|
(unless (path-string? dir)
|
|
(raise-argument-error 'make-lock-file-name "path-string?" dir))
|
|
(unless (path-element? name)
|
|
(raise-argument-error 'make-lock-file-name "path-element?" name))
|
|
(build-path dir
|
|
(make-pathless-lock-file-name name))]))
|
|
|
|
(define (preferences-lock-file-mode)
|
|
(case (system-type)
|
|
[(windows) 'file-lock]
|
|
[else 'exists]))
|
|
|
|
(define (call-with-file-lock/timeout fn kind thunk failure-thunk
|
|
#:lock-file [lock-file #f]
|
|
#:delay [delay 0.01]
|
|
#:max-delay [max-delay 0.2])
|
|
|
|
(unless (or (path-string? fn) (eq? fn #f))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(or/c path-string? #f)" fn))
|
|
(unless (or (eq? kind 'shared) (eq? kind 'exclusive))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(or/c 'shared 'exclusive)" kind))
|
|
(unless (and (procedure? thunk) (= (procedure-arity thunk) 0))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(-> any)" thunk))
|
|
(unless (and (procedure? thunk) (= (procedure-arity failure-thunk) 0))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(-> any)" failure-thunk))
|
|
(unless (or (not lock-file) (path-string? lock-file))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(or/c path-string? #f)" lock-file))
|
|
(unless (and (real? delay) (not (negative? delay)))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(>=/c 0.0)" delay))
|
|
(unless (and (real? max-delay) (not (negative? max-delay)))
|
|
(raise-argument-error 'call-with-file-lock/timeout "(>=/c 0.0)" max-delay))
|
|
|
|
(define real-lock-file (or lock-file (make-lock-file-name fn)))
|
|
(let loop ([delay delay])
|
|
(call-with-file-lock
|
|
kind
|
|
real-lock-file
|
|
thunk
|
|
(lambda ()
|
|
(if (delay . < . max-delay)
|
|
(begin
|
|
(sleep delay)
|
|
(loop (* 2 delay)))
|
|
(failure-thunk))))))
|
|
|
|
(define (call-with-preference-file-lock who kind get-lock-file thunk lock-there)
|
|
(define lock-style (preferences-lock-file-mode))
|
|
(define lock-file (get-lock-file))
|
|
(define failure-thunk
|
|
(if lock-there
|
|
(lambda () (lock-there lock-file))
|
|
(lambda ()
|
|
(case lock-style
|
|
[(file-lock) (error who
|
|
"~a ~a: ~e"
|
|
"some other process has a lock"
|
|
"on the preferences lock file"
|
|
lock-file)]
|
|
[else (error who
|
|
"~a, ~a: ~e"
|
|
"some other process has the preference-file lock"
|
|
"as indicated by the existence of the lock file"
|
|
lock-file)]))))
|
|
|
|
(call-with-file-lock kind lock-file thunk failure-thunk #:lock-style lock-style))
|
|
|
|
(define (call-with-file-lock kind lock-file thunk failure-thunk #:lock-style [lock-style 'file-lock])
|
|
(case lock-style
|
|
[(file-lock)
|
|
;; Create the lock file if it doesn't exist:
|
|
(unless (file-exists? lock-file)
|
|
(with-handlers ([exn:fail:filesystem:exists? (lambda (exn) 'ok)])
|
|
(close-output-port (open-output-file lock-file #:exists 'error))))
|
|
(((if (eq? kind 'exclusive)
|
|
(lambda (fn proc) (call-with-output-file fn proc #:exists 'update))
|
|
call-with-input-file*)
|
|
lock-file
|
|
(lambda (p)
|
|
(if (port-try-file-lock? p kind)
|
|
;; got lock:
|
|
(let ([v (dynamic-wind
|
|
void
|
|
thunk
|
|
(lambda ()
|
|
(port-file-unlock p)))])
|
|
(lambda () v))
|
|
;; didn't get lock:
|
|
(lambda () (failure-thunk))))))]
|
|
[else ; = 'exists
|
|
;; Only a write lock is needed, and the file lock
|
|
;; is implemented by the presence of the file:
|
|
(case kind
|
|
[(shared) (thunk)]
|
|
[(exclusive)
|
|
(with-handlers ([exn:fail:filesystem:exists?
|
|
(lambda (x) (failure-thunk))])
|
|
;; Grab lock:
|
|
(close-output-port (open-output-file lock-file #:exists 'error)))
|
|
(dynamic-wind
|
|
void
|
|
thunk
|
|
(lambda ()
|
|
;; Release lock:
|
|
(delete-file lock-file)))])]))
|
|
|
|
(define (get-prefs flush-mode filename use-lock? lock-there)
|
|
(define (read-prefs default-pref-file)
|
|
(with-handlers ([exn:fail:filesystem? (lambda (x) null)])
|
|
(let-values ([(pref-file use-lock?)
|
|
(if filename
|
|
(values filename use-lock?)
|
|
(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.
|
|
(values f use-lock?)
|
|
;; Look for old PLT Scheme pref file:
|
|
(let ([alt-f
|
|
(case (system-type)
|
|
[(windows)
|
|
(build-path (find-system-path 'pref-dir)
|
|
'up "PLT Scheme" "plt-prefs.ss")]
|
|
[(macosx)
|
|
(build-path (find-system-path 'pref-dir)
|
|
"org.plt-scheme.prefs.ss")]
|
|
[(unix)
|
|
(expand-user-path "~/.plt-scheme/plt-prefs.ss")])])
|
|
(if (file-exists? alt-f)
|
|
(values alt-f #f)
|
|
;; Last chance: check for a "defaults" collection:
|
|
;; (error here in case there's no "defaults"
|
|
;; bails out through above `with-handlers')
|
|
(values
|
|
(collection-file-path "racket-prefs.rktd"
|
|
"defaults")
|
|
#f))))))])
|
|
(let ([prefs (with-pref-params
|
|
(lambda ()
|
|
(with-handlers ([exn:fail:read? (lambda (exn)
|
|
(log-error
|
|
(format "error reading preferences: ~a"
|
|
(exn-message exn)))
|
|
null)])
|
|
(if use-lock?
|
|
(call-with-preference-file-lock
|
|
'get-preference
|
|
'shared
|
|
(lambda ()
|
|
(make-lock-file-name pref-file))
|
|
(lambda ()
|
|
(with-input-from-file pref-file read))
|
|
lock-there)
|
|
(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)
|
|
(symbol? (car x))
|
|
(pair? (cdr x))
|
|
(null? (cddr x))))
|
|
prefs))
|
|
prefs
|
|
(begin
|
|
(log-error "preference file content is not a list of symbol--value lists")
|
|
null))))))
|
|
(let* ([fn (path->complete-path
|
|
(or filename
|
|
(find-system-path 'pref-file)))]
|
|
[cache (let ([table (weak-box-value pref-cache)])
|
|
(and table (hash-ref 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 (make-handle-get-preference-locked delay
|
|
name
|
|
[fail-thunk (lambda () #f)]
|
|
[refresh-cache? 'timestamp]
|
|
[filename #f]
|
|
#:lock-there [lock-there #f]
|
|
#:max-delay [max-delay 0.2])
|
|
(lambda (lock-filename)
|
|
(sleep delay)
|
|
(get-preference name fail-thunk refresh-cache? filename
|
|
#:lock-there (let ([new-delay (* 2 delay)])
|
|
(if (new-delay . < . max-delay)
|
|
(make-handle-get-preference-locked
|
|
new-delay
|
|
name fail-thunk refresh-cache? filename
|
|
#:lock-there lock-there
|
|
#:max-delay max-delay)
|
|
lock-there)))))
|
|
|
|
(define (get-preference name [fail-thunk (lambda () #f)]
|
|
[refresh-cache? 'timestamp]
|
|
[filename #f]
|
|
#:timeout-lock-there [timeout-lock-there #f]
|
|
#:lock-there [lock-there
|
|
(make-handle-get-preference-locked
|
|
0.01
|
|
name
|
|
fail-thunk
|
|
refresh-cache?
|
|
filename
|
|
#:lock-there timeout-lock-there)]
|
|
#:use-lock? [use-lock? #t])
|
|
(unless (symbol? name)
|
|
(raise-argument-error 'get-preference "symbol?" name))
|
|
(unless (and (procedure? fail-thunk)
|
|
(procedure-arity-includes? fail-thunk 0))
|
|
(raise-argument-error 'get-preference "(-> any)" fail-thunk))
|
|
((let/ec esc
|
|
(let ([f (get-prefs refresh-cache? filename use-lock?
|
|
(and lock-there
|
|
(lambda (file)
|
|
(esc (lambda () (lock-there file))))))])
|
|
(lambda ()
|
|
(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-argument-error 'put-preferences "(listof symbol?)" names))
|
|
(unless (list? vals)
|
|
(raise-argument-error 'put-preferences "list?" vals))
|
|
(unless (= (length names) (length vals))
|
|
(raise-arguments-error
|
|
'put-preferences
|
|
"the length of the name list does not match the length of the value list"
|
|
"name list length" (length names)
|
|
"value list length" (length vals)
|
|
"name list" names
|
|
"value list" 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
|
|
(make-lock-file-name dir name)
|
|
dir))))])
|
|
(call-with-preference-file-lock
|
|
'put-preferences
|
|
'exclusive
|
|
(lambda () lock-file)
|
|
(lambda ()
|
|
(let ([f (get-prefs #t filename #f #f)])
|
|
(set! f (let loop ([f f][a null])
|
|
(cond
|
|
[(null? f) (reverse
|
|
(append (map list names vals)
|
|
a))]
|
|
[else (if (memq (caar f) names)
|
|
(loop (cdr f) a)
|
|
(loop (cdr f) (cons (car f) a)))])))
|
|
;; To write the file, copy the old one to a temporary name
|
|
;; (preserves permissions, etc), write to the temp file,
|
|
;; then move (atomicly) the temp file to the normal name.
|
|
(let ([tmp-file (make-temporary-file
|
|
"TMPPREF~a"
|
|
(and (file-exists? pref-file) pref-file)
|
|
pref-dir)])
|
|
;; If something goes wrong, try to delete the temp file.
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(with-handlers ([exn:fail:filesystem? void])
|
|
(delete-file tmp-file))
|
|
(raise exn))])
|
|
;; Write to temp file...
|
|
(with-output-to-file tmp-file
|
|
#:exists 'truncate/replace
|
|
(lambda ()
|
|
(with-pref-params
|
|
(lambda ()
|
|
;; If a pref value turns out to be unreadable, raise
|
|
;; an exception instead of creating a bad pref file.
|
|
(parameterize ([print-unreadable #f])
|
|
;; Poor man's pretty-print: one line per entry.
|
|
(printf "(\n")
|
|
(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)))
|
|
f)
|
|
(printf ")\n"))))))
|
|
;; Install the new table in the cache. It's possible that this
|
|
;; cache entry will be replaced by a reading thread before we
|
|
;; move the file, but that's ok. It just means that a future
|
|
;; reading thread will have to read again.
|
|
(pref-cache-install! (path->complete-path
|
|
(or filename
|
|
(find-system-path 'pref-file)))
|
|
tmp-file
|
|
f)
|
|
(rename-file-or-directory tmp-file pref-file #t)))))
|
|
lock-there)))
|
|
|
|
;; fold-files : (pathname sym alpha -> alpha) alpha pathname/#f -> alpha
|
|
(define (fold-files f init [path #f] [follow-links? #t])
|
|
(define-syntax-rule (keep-fst e)
|
|
(call-with-values (lambda () e) (case-lambda [(v) v] [(v _) v])))
|
|
(define (do-path path acc)
|
|
(cond [(and (not follow-links?) (link-exists? path))
|
|
(keep-fst (f path 'link acc))]
|
|
[(directory-exists? path)
|
|
(call-with-values (lambda () (f path 'dir acc))
|
|
(lambda (acc [descend? #t])
|
|
(if descend?
|
|
(do-paths (map (lambda (p) (build-path path p))
|
|
(sorted-dirlist path))
|
|
acc)
|
|
acc)))]
|
|
[(file-exists? path) (keep-fst (f path 'file acc))]
|
|
[(link-exists? path) (keep-fst (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))]))
|
|
(define (to-path s) (if (path? s) s (string->path s)))
|
|
(if path (do-path (to-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 (pathlist-closure paths)
|
|
(let loop ([paths
|
|
(map (lambda (p)
|
|
(simplify-path
|
|
(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)
|
|
#f))
|
|
paths)]
|
|
[r '()])
|
|
(if (null? paths)
|
|
(reverse r)
|
|
(let loop2 ([path (car paths)]
|
|
[new (cond [(file-exists? (car paths))
|
|
(list (car paths))]
|
|
[(directory-exists? (car paths))
|
|
(find-files void (car paths))]
|
|
[else (error 'pathlist-closure
|
|
"file/directory not found: ~a"
|
|
(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))))))))
|
|
|
|
(define (check-path who f)
|
|
(unless (path-string? f)
|
|
(raise-argument-error who "path-string?" f)))
|
|
|
|
(define (check-file-mode who file-mode)
|
|
(unless (memq file-mode '(binary text))
|
|
(raise-argument-error who "(or/c 'binary 'text)" file-mode)))
|
|
|
|
(define (file->x who f file-mode read-x x-append)
|
|
(check-path who f)
|
|
(check-file-mode who file-mode)
|
|
(let ([sz (file-size f)])
|
|
(call-with-input-file* f #:mode file-mode
|
|
(lambda (in)
|
|
;; There's a good chance that `file-size' gets all the data:
|
|
(let ([s (read-x sz in)])
|
|
;; ... but double-check:
|
|
(let ([more (let loop ()
|
|
(let ([l (read-x 4096 in)])
|
|
(if (eof-object? l) null (cons l (loop)))))])
|
|
(if (null? more) s (apply x-append (cons s more)))))))))
|
|
|
|
(define (file->string f #:mode [mode 'binary])
|
|
(file->x 'file->string f mode read-string string-append))
|
|
|
|
(define (file->bytes f #:mode [mode 'binary])
|
|
(file->x 'file->bytes f mode read-bytes bytes-append))
|
|
|
|
(define (file->value f #:mode [file-mode 'binary])
|
|
(check-path 'file->value f)
|
|
(check-file-mode 'file->value file-mode)
|
|
(call-with-input-file* f #:mode file-mode read))
|
|
|
|
(define (file->list f [r read] #:mode [file-mode 'binary])
|
|
(check-path 'file->list f)
|
|
(check-file-mode 'file->list file-mode)
|
|
(unless (and (procedure? r) (procedure-arity-includes? r 1))
|
|
(raise-argument-error 'file->list "(procedure-arity-includes/c 1)" r))
|
|
(call-with-input-file* f #:mode file-mode
|
|
(lambda (p) (for/list ([v (in-port r p)]) v))))
|
|
|
|
(define (file->x-lines who f line-mode file-mode read-line)
|
|
(check-path who f)
|
|
(check-mode who line-mode)
|
|
(check-file-mode who file-mode)
|
|
(call-with-input-file* f #:mode file-mode
|
|
(lambda (p) (port->x-lines who p line-mode read-line))))
|
|
|
|
(define (file->lines f #:line-mode [line-mode 'any] #:mode [file-mode 'binary])
|
|
(file->x-lines 'file->lines f line-mode file-mode read-line))
|
|
|
|
(define (file->bytes-lines f #:line-mode [line-mode 'any] #:mode [file-mode 'binary])
|
|
(file->x-lines 'file->bytes-lines f line-mode file-mode read-bytes-line))
|
|
|
|
(define (->file who f mode exists write)
|
|
(unless (path-string? f)
|
|
(raise-argument-error who "path-string?" f))
|
|
(unless (memq mode '(binary text))
|
|
(raise-argument-error who "(or/c 'binary 'text)" mode))
|
|
(unless (memq exists '(error append update replace truncate truncate/replace))
|
|
(raise-argument-error who "(or/c 'error 'append 'update 'replace 'truncate 'truncate/replace)" exists))
|
|
(call-with-output-file* f #:mode mode #:exists exists write))
|
|
|
|
(define (display-to-file s f #:mode [mode 'binary] #:exists [exists 'error])
|
|
(->file 'display-to-file f mode exists (lambda (p) (display s p))))
|
|
|
|
(define (write-to-file s f #:mode [mode 'binary] #:exists [exists 'error])
|
|
(->file 'write-to-file f mode exists (lambda (p) (write s p))))
|
|
|
|
(define (display-lines-to-file l f
|
|
#:mode [mode 'binary]
|
|
#:exists [exists 'error]
|
|
#:separator [newline #"\n"])
|
|
(unless (list? l)
|
|
(raise-argument-error 'display-lines-to-file "list?" l))
|
|
(->file 'display-lines-to-file f mode exists
|
|
(lambda (p) (do-lines->port l p newline))))
|
|
|
|
(define user-read-bit #o400)
|
|
(define user-write-bit #o200)
|
|
(define user-execute-bit #o100)
|
|
(define group-read-bit #o040)
|
|
(define group-write-bit #o020)
|
|
(define group-execute-bit #o010)
|
|
(define other-read-bit #o004)
|
|
(define other-write-bit #o002)
|
|
(define other-execute-bit #o001)
|