move '#%utils implementation into "collects/racket/private".
For now, this copies the code of "startup.rktl". The intent is that "startup.rktl" will go away with a new bootstrap process.
This commit is contained in:
Matthew Flatt
parent
94c636fe2b
commit
c1c427a281
507
racket/collects/racket/private/collect.rkt
Normal file
507
racket/collects/racket/private/collect.rkt
Normal file
|
|
@ -0,0 +1,507 @@
|
|||
(module collect '#%kernel
|
||||
(#%require '#%paramz ; for `exception-handler-key`
|
||||
"qq-and-or.rkt"
|
||||
"define-et-al.rkt"
|
||||
"cond.rkt"
|
||||
"path.rkt"
|
||||
"path-list.rkt"
|
||||
"reading-param.rkt"
|
||||
"config.rkt")
|
||||
|
||||
(#%provide find-col-file
|
||||
collection-path
|
||||
collection-file-path
|
||||
find-library-collection-paths
|
||||
find-library-collection-links)
|
||||
|
||||
(define-values (-check-relpath)
|
||||
(lambda (who s)
|
||||
(unless (path-string? s)
|
||||
(raise-argument-error who "path-string?" s))
|
||||
(unless (relative-path? s)
|
||||
(raise-arguments-error who
|
||||
"invalid relative path"
|
||||
"path" s))))
|
||||
|
||||
(define-values (-check-collection)
|
||||
(lambda (who collection collection-path)
|
||||
(-check-relpath who collection)
|
||||
(for-each (lambda (p) (-check-relpath who p)) collection-path)))
|
||||
|
||||
(define-values (-check-fail)
|
||||
(lambda (who fail)
|
||||
(unless (and (procedure? fail)
|
||||
(procedure-arity-includes? fail 1))
|
||||
(raise-argument-error who "(any/c . -> . any)" fail))))
|
||||
|
||||
(define-values (collection-path)
|
||||
(lambda (fail collection collection-path)
|
||||
(-check-collection 'collection-path collection collection-path)
|
||||
(-check-fail 'collection-path fail)
|
||||
(find-col-file fail
|
||||
collection collection-path
|
||||
#f
|
||||
#f)))
|
||||
|
||||
(define-values (collection-file-path)
|
||||
(lambda (fail check-compiled? file-name collection collection-path)
|
||||
(-check-relpath 'collection-file-path file-name)
|
||||
(-check-collection 'collection-file-path collection collection-path)
|
||||
(-check-fail 'collection-file-path fail)
|
||||
(find-col-file fail
|
||||
collection collection-path
|
||||
file-name
|
||||
check-compiled?)))
|
||||
|
||||
(define-values (get-config-table)
|
||||
(lambda (d)
|
||||
(let ([p (and d (build-path d "config.rktd"))])
|
||||
(or (and p
|
||||
(file-exists? p)
|
||||
(with-input-from-file p
|
||||
(lambda ()
|
||||
(let ([v (call-with-default-reading-parameterization read)])
|
||||
(and (hash? v)
|
||||
v)))))
|
||||
#hash()))))
|
||||
|
||||
(define-values (get-installation-name)
|
||||
(lambda (config-table)
|
||||
(hash-ref config-table
|
||||
'installation-name
|
||||
(version))))
|
||||
|
||||
(define-values (coerce-to-path)
|
||||
(lambda (p)
|
||||
(cond
|
||||
[(string? p) (collects-relative-path->complete-path (string->path p))]
|
||||
[(bytes? p) (collects-relative-path->complete-path (bytes->path p))]
|
||||
[(path? p) (collects-relative-path->complete-path p)]
|
||||
[else p])))
|
||||
|
||||
(define-values (collects-relative-path->complete-path)
|
||||
(lambda (p)
|
||||
(cond
|
||||
[(complete-path? p) p]
|
||||
[else
|
||||
(path->complete-path p (or (find-main-collects)
|
||||
;; If we get here, then something is configured wrong,
|
||||
;; and making up paths relative to the current directory
|
||||
;; is not great --- but we have to come up with some
|
||||
;; path at this point.
|
||||
(current-directory)))])))
|
||||
|
||||
(define-values (add-config-search)
|
||||
(lambda (ht key orig-l)
|
||||
(let ([l (hash-ref ht key #f)])
|
||||
(if l
|
||||
(let loop ([l l])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(not (car l)) (append orig-l (loop (cdr l)))]
|
||||
[else (cons (coerce-to-path (car l)) (loop (cdr l)))]))
|
||||
orig-l))))
|
||||
|
||||
(define-values (find-library-collection-links)
|
||||
(lambda ()
|
||||
(let* ([ht (get-config-table (find-main-config))]
|
||||
[lf (coerce-to-path
|
||||
(or (hash-ref ht 'links-file #f)
|
||||
(build-path (or (hash-ref ht 'share-dir #f)
|
||||
(build-path 'up "share"))
|
||||
"links.rktd")))])
|
||||
(append
|
||||
;; `#f' means `current-library-collection-paths':
|
||||
(list #f)
|
||||
;; user-specific
|
||||
(if (and (use-user-specific-search-paths)
|
||||
(use-collection-link-paths))
|
||||
(list (build-path (find-system-path 'addon-dir)
|
||||
(get-installation-name ht)
|
||||
"links.rktd"))
|
||||
null)
|
||||
;; installation-wide:
|
||||
(if (use-collection-link-paths)
|
||||
(add-config-search
|
||||
ht
|
||||
'links-search-files
|
||||
(list lf))
|
||||
null)))))
|
||||
|
||||
;; map from link-file names to cached information:
|
||||
(define-values (links-cache) (make-weak-hash))
|
||||
|
||||
;; used for low-level except abort below:
|
||||
(define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp))
|
||||
|
||||
(define-values (file->stamp)
|
||||
(lambda (path old-stamp)
|
||||
;; Using just the file's modification date almost works as a stamp,
|
||||
;; but 1-second granularity isn't fine enough. A stamp is therefore
|
||||
;; the file content paired with a filesystem-change event (where
|
||||
;; supported), and the event lets us recycle the old stamp almost
|
||||
;; always.
|
||||
(cond
|
||||
[(and old-stamp
|
||||
(cdr old-stamp)
|
||||
(not (sync/timeout 0 (cdr old-stamp))))
|
||||
old-stamp]
|
||||
[else
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(lambda (exn)
|
||||
(abort-current-continuation
|
||||
stamp-prompt-tag
|
||||
(if (exn:fail:filesystem? exn)
|
||||
(lambda () #f)
|
||||
(lambda () (raise exn)))))
|
||||
(let ([dir-evt
|
||||
(and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ?
|
||||
(let loop ([path path])
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(and (path? base)
|
||||
(if (directory-exists? base)
|
||||
(filesystem-change-evt base (lambda () #f))
|
||||
(loop base))))))])
|
||||
(if (not (file-exists? path))
|
||||
(cons #f dir-evt)
|
||||
(let ([evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ?
|
||||
(filesystem-change-evt path (lambda () #f)))])
|
||||
(when dir-evt (filesystem-change-evt-cancel dir-evt))
|
||||
(cons
|
||||
(let ([p (open-input-file path)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (and (bytes? bstr)
|
||||
((bytes-length bstr) . >= . 8192))
|
||||
(apply
|
||||
bytes-append
|
||||
(cons
|
||||
bstr
|
||||
(let loop ()
|
||||
(let ([bstr (read-bytes 8192 p)])
|
||||
(if (eof-object? bstr)
|
||||
null
|
||||
(cons bstr (loop)))))))
|
||||
bstr)))
|
||||
(lambda () (close-input-port p))))
|
||||
evt))))))
|
||||
stamp-prompt-tag)])))
|
||||
|
||||
(define-values (no-file-stamp?)
|
||||
(lambda (a)
|
||||
(or (not a)
|
||||
(not (car a)))))
|
||||
|
||||
(define-values (get-linked-collections)
|
||||
(lambda (links-path)
|
||||
;; Use/save information in `links-cache', relying on filesystem-change events
|
||||
;; or a copy of the file to detect when the cache is stale.
|
||||
(call-with-escape-continuation
|
||||
(lambda (esc)
|
||||
(define-values (make-handler)
|
||||
(lambda (ts)
|
||||
(lambda (exn)
|
||||
(if (exn:fail? exn)
|
||||
(let ([l (current-logger)])
|
||||
(when (log-level? l 'error)
|
||||
(log-message l 'error
|
||||
(format
|
||||
"error reading collection links file ~s: ~a"
|
||||
links-path
|
||||
(exn-message exn))
|
||||
(current-continuation-marks))))
|
||||
(void))
|
||||
(when ts
|
||||
(hash-set! links-cache links-path (cons ts #hasheq())))
|
||||
(if (exn:fail? exn)
|
||||
(esc (make-hasheq))
|
||||
;; re-raise the exception (which is probably a break)
|
||||
exn))))
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(make-handler #f)
|
||||
(let* ([links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))]
|
||||
[a-links-stamp (car links-stamp+cache)]
|
||||
[ts (file->stamp links-path a-links-stamp)])
|
||||
(if (not (equal? ts a-links-stamp))
|
||||
(with-continuation-mark
|
||||
exception-handler-key
|
||||
(make-handler ts)
|
||||
(call-with-default-reading-parameterization
|
||||
(lambda ()
|
||||
(let ([v (if (no-file-stamp? ts)
|
||||
null
|
||||
(let ([p (open-input-file links-path 'binary)])
|
||||
(dynamic-wind
|
||||
void
|
||||
(lambda ()
|
||||
(begin0
|
||||
(read p)
|
||||
(unless (eof-object? (read p))
|
||||
(error "expected a single S-expression"))))
|
||||
(lambda () (close-input-port p)))))])
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (p)
|
||||
(and (list? p)
|
||||
(or (= 2 (length p))
|
||||
(= 3 (length p)))
|
||||
(or (string? (car p))
|
||||
(eq? 'root (car p))
|
||||
(eq? 'static-root (car p)))
|
||||
(path-string? (cadr p))
|
||||
(or (null? (cddr p))
|
||||
(regexp? (caddr p)))))
|
||||
v))
|
||||
(error "ill-formed content"))
|
||||
(let ([ht (make-hasheq)]
|
||||
[dir (let-values ([(base name dir?) (split-path links-path)])
|
||||
base)])
|
||||
(for-each
|
||||
(lambda (p)
|
||||
(when (or (null? (cddr p))
|
||||
(regexp-match? (caddr p) (version)))
|
||||
(let ([dir (simplify-path
|
||||
(path->complete-path (cadr p) dir))])
|
||||
(cond
|
||||
[(eq? (car p) 'static-root)
|
||||
;; multi-collection, constant content:
|
||||
(for-each
|
||||
(lambda (sub)
|
||||
(when (directory-exists? (build-path dir sub))
|
||||
(let ([k (string->symbol (path->string sub))])
|
||||
(hash-set! ht k (cons dir (hash-ref ht k null))))))
|
||||
(directory-list dir))]
|
||||
[(eq? (car p) 'root)
|
||||
;; multi-collection, dynamic content:
|
||||
;; Add directory to the #f mapping, and also
|
||||
;; add to every existing table element (to keep
|
||||
;; the choices in order)
|
||||
(unless (hash-ref ht #f #f)
|
||||
(hash-set! ht #f null))
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v)
|
||||
(hash-set! ht k (cons dir v))))]
|
||||
[else
|
||||
;; single collection:
|
||||
(let ([s (string->symbol (car p))])
|
||||
(hash-set! ht s (cons (box dir)
|
||||
(hash-ref ht s null))))]))))
|
||||
v)
|
||||
;; reverse all lists:
|
||||
(hash-for-each
|
||||
ht
|
||||
(lambda (k v) (hash-set! ht k (reverse v))))
|
||||
;; save table & file content:
|
||||
(hash-set! links-cache links-path (cons ts ht))
|
||||
ht)))))
|
||||
(cdr links-stamp+cache))))))))
|
||||
|
||||
(define-values (normalize-collection-reference)
|
||||
(lambda (collection collection-path)
|
||||
;; make sure that `collection' is a top-level collection name,
|
||||
(cond
|
||||
[(string? collection)
|
||||
(let ([m (regexp-match-positions #rx"/+" collection)])
|
||||
(if m
|
||||
(cond
|
||||
[(= (caar m) (sub1 (string-length collection)))
|
||||
(values (substring collection 0 (caar m)) collection-path)]
|
||||
[else
|
||||
(values (substring collection 0 (caar m))
|
||||
(cons (substring collection (cdar m))
|
||||
collection-path))])
|
||||
(values collection collection-path)))]
|
||||
[else
|
||||
(let-values ([(base name dir?) (split-path collection)])
|
||||
(if (eq? base 'relative)
|
||||
(values name collection-path)
|
||||
(normalize-collection-reference base (cons name collection-path))))])))
|
||||
|
||||
(define-values (find-col-file)
|
||||
(lambda (fail collection collection-path file-name check-compiled?)
|
||||
(let-values ([(collection collection-path)
|
||||
(normalize-collection-reference collection collection-path)])
|
||||
(let ([all-paths (let ([sym (string->symbol
|
||||
(if (path? collection)
|
||||
(path->string collection)
|
||||
collection))])
|
||||
(let loop ([l (current-library-collection-links)])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(not (car l))
|
||||
;; #f is the point where we try the old parameter:
|
||||
(append
|
||||
(current-library-collection-paths)
|
||||
(loop (cdr l)))]
|
||||
[(hash? (car l))
|
||||
;; A hash table maps a collection-name symbol
|
||||
;; to a list of paths. We need to wrap each path
|
||||
;; in a box, because that's how the code below
|
||||
;; knows that it's a single collection's directory.
|
||||
;; A hash table can also map #f to a list of paths
|
||||
;; for directories that hold collections.
|
||||
(append
|
||||
(map box (hash-ref (car l) sym null))
|
||||
(hash-ref (car l) #f null)
|
||||
(loop (cdr l)))]
|
||||
[else
|
||||
(let ([ht (get-linked-collections (car l))])
|
||||
(append
|
||||
;; Table values are lists of paths and (box path)s,
|
||||
;; where a (box path) is a collection directory
|
||||
;; (instead of a directory containing collections).
|
||||
(hash-ref ht sym null)
|
||||
(hash-ref ht #f null)
|
||||
(loop (cdr l))))])))])
|
||||
(define-values (done)
|
||||
(lambda (p)
|
||||
(if file-name (build-path p file-name) p)))
|
||||
(define-values (*build-path-rep)
|
||||
(lambda (p c)
|
||||
(if (path? p)
|
||||
(build-path p c)
|
||||
;; box => from links table for c
|
||||
(unbox p))))
|
||||
(define-values (*directory-exists?)
|
||||
(lambda (orig p)
|
||||
(if (path? orig)
|
||||
(directory-exists? p)
|
||||
;; orig is box => from links table
|
||||
#t)))
|
||||
(define-values (to-string) (lambda (p) (if (path? p) (path->string p) p)))
|
||||
(let cloop ([paths all-paths] [found-col #f])
|
||||
(if (null? paths)
|
||||
(if found-col
|
||||
(done found-col)
|
||||
(let ([rest-coll
|
||||
(if (null? collection-path)
|
||||
""
|
||||
(apply
|
||||
string-append
|
||||
(let loop ([cp collection-path])
|
||||
(if (null? (cdr cp))
|
||||
(list (to-string (car cp)))
|
||||
(list* (to-string (car cp)) "/" (loop (cdr cp)))))))])
|
||||
(define-values (filter)
|
||||
(lambda (f l)
|
||||
(if (null? l)
|
||||
null
|
||||
(if (f (car l))
|
||||
(cons (car l) (filter f (cdr l)))
|
||||
(filter f (cdr l))))))
|
||||
(fail
|
||||
(format "collection not found\n collection: ~s\n in collection directories:~a~a"
|
||||
(if (null? collection-path)
|
||||
(to-string collection)
|
||||
(string-append (to-string collection) "/" rest-coll))
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (p)
|
||||
(format "\n ~a ~a" " " p))
|
||||
(let ([len (length all-paths)]
|
||||
[clen (length (current-library-collection-paths))])
|
||||
(if ((- len clen) . < . 5)
|
||||
all-paths
|
||||
(append (current-library-collection-paths)
|
||||
(list (format "... [~a additional linked and package directories]"
|
||||
(- len clen))))))))
|
||||
(if (ormap box? all-paths)
|
||||
(format "\n sub-collection: ~s\n in parent directories:~a"
|
||||
rest-coll
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (p)
|
||||
(format "\n ~a" (unbox p)))
|
||||
(filter box? all-paths))))
|
||||
"")))))
|
||||
(let ([dir (*build-path-rep (car paths) collection)])
|
||||
(if (*directory-exists? (car paths) dir)
|
||||
(let ([cpath (apply build-path dir collection-path)])
|
||||
(if (if (null? collection-path)
|
||||
#t
|
||||
(directory-exists? cpath))
|
||||
(if file-name
|
||||
(if (or (file-exists?/maybe-compiled cpath file-name
|
||||
check-compiled?)
|
||||
(let ([alt-file-name
|
||||
(let* ([file-name (if (path? file-name)
|
||||
(path->string file-name)
|
||||
file-name)]
|
||||
[len (string-length file-name)])
|
||||
(and (len . >= . 4)
|
||||
(string=? ".rkt" (substring file-name (- len 4)))
|
||||
(string-append (substring file-name 0 (- len 4)) ".ss")))])
|
||||
(and alt-file-name
|
||||
(file-exists?/maybe-compiled cpath alt-file-name
|
||||
check-compiled?))))
|
||||
(done cpath)
|
||||
;; Look further for specific file, but remember
|
||||
;; first found directory
|
||||
(cloop (cdr paths) (or found-col cpath)))
|
||||
;; Just looking for dir; found it:
|
||||
(done cpath))
|
||||
;; sub-collection not here; try next instance
|
||||
;; of the top-level collection
|
||||
(cloop (cdr paths) found-col)))
|
||||
(cloop (cdr paths) found-col)))))))))
|
||||
|
||||
(define-values (file-exists?/maybe-compiled)
|
||||
(lambda (dir path check-compiled?)
|
||||
(or (file-exists? (build-path dir path))
|
||||
(and check-compiled?
|
||||
(let ([try-path (path-add-extension path #".zo")]
|
||||
[modes (use-compiled-file-paths)]
|
||||
[roots (current-compiled-file-roots)])
|
||||
(ormap (lambda (d)
|
||||
(ormap (lambda (mode)
|
||||
(file-exists?
|
||||
(let ([p (build-path dir mode try-path)])
|
||||
(cond
|
||||
[(eq? d 'same) p]
|
||||
[(relative-path? d) (build-path p d)]
|
||||
[else (reroot-path p d)]))))
|
||||
modes))
|
||||
roots))))))
|
||||
|
||||
(define-values (find-library-collection-paths)
|
||||
(case-lambda
|
||||
[() (find-library-collection-paths null null)]
|
||||
[(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)]
|
||||
[(extra-collects-dirs post-collects-dirs)
|
||||
(let ([user-too? (use-user-specific-search-paths)]
|
||||
[cons-if (lambda (f r) (if f (cons f r) r))]
|
||||
[config-table (get-config-table (find-main-config))])
|
||||
(path-list-string->path-list
|
||||
(if user-too?
|
||||
(let ([c (environment-variables-ref (current-environment-variables)
|
||||
#"PLTCOLLECTS")])
|
||||
(if c
|
||||
(bytes->string/locale c #\?)
|
||||
""))
|
||||
"")
|
||||
(add-config-search
|
||||
config-table
|
||||
'collects-search-dirs
|
||||
(cons-if
|
||||
(and user-too?
|
||||
(build-path (find-system-path 'addon-dir)
|
||||
(get-installation-name config-table)
|
||||
"collects"))
|
||||
(let loop ([l (append
|
||||
extra-collects-dirs
|
||||
(list (find-system-path 'collects-dir))
|
||||
post-collects-dirs)])
|
||||
(if (null? l)
|
||||
null
|
||||
(let* ([collects-path (car l)]
|
||||
[v (exe-relative-path->complete-path collects-path)])
|
||||
(if v
|
||||
(cons (simplify-path (path->complete-path v (current-directory)))
|
||||
(loop (cdr l)))
|
||||
(loop (cdr l))))))))))])))
|
||||
43
racket/collects/racket/private/config.rkt
Normal file
43
racket/collects/racket/private/config.rkt
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
(module config '#%kernel
|
||||
(#%require '#%paramz ; for cache-configuration
|
||||
"cond.rkt"
|
||||
"qq-and-or.rkt"
|
||||
"executable-path.rkt")
|
||||
|
||||
(#%provide find-main-collects
|
||||
find-main-config
|
||||
|
||||
exe-relative-path->complete-path)
|
||||
|
||||
(define-values (find-main-collects)
|
||||
(lambda ()
|
||||
;; Recorded once and for all (per place), which helps avoid
|
||||
;; sandbox problems:
|
||||
(cache-configuration
|
||||
0
|
||||
(lambda ()
|
||||
(exe-relative-path->complete-path (find-system-path 'collects-dir))))))
|
||||
|
||||
(define-values (find-main-config)
|
||||
(lambda ()
|
||||
;; Also recorded once and for all (per place):
|
||||
(cache-configuration
|
||||
1
|
||||
(lambda ()
|
||||
(exe-relative-path->complete-path (find-system-path 'config-dir))))))
|
||||
|
||||
(define-values (exe-relative-path->complete-path)
|
||||
(lambda (collects-path)
|
||||
(cond
|
||||
[(complete-path? collects-path) (simplify-path collects-path)]
|
||||
[(absolute-path? collects-path)
|
||||
;; This happens only under Windows; add a drive
|
||||
;; specification to make the path complete
|
||||
(let ([exec (path->complete-path
|
||||
(find-executable-path (find-system-path 'exec-file))
|
||||
(find-system-path 'orig-dir))])
|
||||
(let-values ([(base name dir?) (split-path exec)])
|
||||
(simplify-path (path->complete-path collects-path base))))]
|
||||
[else
|
||||
(let ([p (find-executable-path (find-system-path 'exec-file) collects-path #t)])
|
||||
(and p (simplify-path p)))]))))
|
||||
62
racket/collects/racket/private/executable-path.rkt
Normal file
62
racket/collects/racket/private/executable-path.rkt
Normal file
|
|
@ -0,0 +1,62 @@
|
|||
(module path-list '#%kernel
|
||||
(#%require "qq-and-or.rkt"
|
||||
"cond.rkt"
|
||||
"define-et-al.rkt"
|
||||
"path.rkt"
|
||||
"path-list.rkt")
|
||||
|
||||
(#%provide find-executable-path)
|
||||
|
||||
(define-values (find-executable-path)
|
||||
(case-lambda
|
||||
[(program libpath reverse?)
|
||||
(unless (path-string? program)
|
||||
(raise-argument-error 'find-executable-path "path-string?" program))
|
||||
(unless (or (not libpath) (and (path-string? libpath)
|
||||
(relative-path? libpath)))
|
||||
(raise-argument-error 'find-executable-path "(or/c #f (and/c path-string? relative-path?))" libpath))
|
||||
(letrec ([found-exec
|
||||
(lambda (exec-name)
|
||||
(if libpath
|
||||
(let-values ([(base name isdir?) (split-path exec-name)])
|
||||
(let ([next
|
||||
(lambda ()
|
||||
(let ([resolved (resolve-path exec-name)])
|
||||
(cond
|
||||
[(equal? resolved exec-name) #f]
|
||||
[(relative-path? resolved)
|
||||
(found-exec (build-path base resolved))]
|
||||
[else (found-exec resolved)])))])
|
||||
(or (and reverse? (next))
|
||||
(if (path? base)
|
||||
(let ([lib (build-path base libpath)])
|
||||
(and (or (directory-exists? lib)
|
||||
(file-exists? lib))
|
||||
lib))
|
||||
#f)
|
||||
(and (not reverse?) (next)))))
|
||||
exec-name))])
|
||||
(if (and (relative-path? program)
|
||||
(let-values ([(base name dir?) (split-path program)])
|
||||
(eq? base 'relative)))
|
||||
(let ([paths-str (environment-variables-ref (current-environment-variables)
|
||||
#"PATH")]
|
||||
[win-add (lambda (s) (if (eq? (system-type) 'windows)
|
||||
(cons (bytes->path #".") s)
|
||||
s))])
|
||||
(let loop ([paths (win-add
|
||||
(if paths-str
|
||||
(path-list-string->path-list (bytes->string/locale paths-str #\?)
|
||||
null)
|
||||
null))])
|
||||
(if (null? paths)
|
||||
#f
|
||||
(let* ([base (path->complete-path (car paths))]
|
||||
[name (build-path base program)])
|
||||
(if (file-exists? name)
|
||||
(found-exec name)
|
||||
(loop (cdr paths)))))))
|
||||
(let ([p (path->complete-path program)])
|
||||
(and (file-exists? p) (found-exec p)))))]
|
||||
[(program libpath) (find-executable-path program libpath #f)]
|
||||
[(program) (find-executable-path program #f #f)])))
|
||||
35
racket/collects/racket/private/load.rkt
Normal file
35
racket/collects/racket/private/load.rkt
Normal file
|
|
@ -0,0 +1,35 @@
|
|||
(module load '#%kernel
|
||||
(#%require "qq-and-or.rkt"
|
||||
"more-scheme.rkt"
|
||||
"define-et-al.rkt"
|
||||
"executable-path.rkt")
|
||||
|
||||
(#%provide load/use-compiled
|
||||
embedded-load)
|
||||
|
||||
(define-values (load/use-compiled)
|
||||
(lambda (f) ((current-load/use-compiled) f #f)))
|
||||
|
||||
;; used for the -k command-line argument:
|
||||
(define-values (embedded-load)
|
||||
(lambda (start end str)
|
||||
(let* ([s (if str
|
||||
str
|
||||
(let* ([sp (find-system-path 'exec-file)]
|
||||
[exe (find-executable-path sp #f)]
|
||||
[start (or (string->number start) 0)]
|
||||
[end (or (string->number end) 0)])
|
||||
(with-input-from-file exe
|
||||
(lambda ()
|
||||
(file-position (current-input-port) start)
|
||||
(read-bytes (max 0 (- end start)))))))]
|
||||
[p (open-input-bytes s)])
|
||||
(let loop ()
|
||||
(let ([e (parameterize ([read-accept-compiled #t]
|
||||
[read-accept-reader #t]
|
||||
[read-accept-lang #t]
|
||||
[read-on-demand-source #t])
|
||||
(read p))])
|
||||
(unless (eof-object? e)
|
||||
((current-eval) e)
|
||||
(loop))))))))
|
||||
|
|
@ -3,8 +3,9 @@
|
|||
;; #%misc : file utilities, etc. - remaining functions
|
||||
|
||||
(module misc '#%kernel
|
||||
(#%require '#%utils ; built into racket
|
||||
"small-scheme.rkt" "define.rkt" "path.rkt"
|
||||
(#%require "small-scheme.rkt" "define.rkt" "path.rkt" "old-path.rkt"
|
||||
"path-list.rkt" "executable-path.rkt" "collect.rkt"
|
||||
"reading-param.rkt" "load.rkt"
|
||||
(for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
|
||||
|
||||
;; -------------------------------------------------------------------------
|
||||
|
|
|
|||
70
racket/collects/racket/private/old-path.rkt
Normal file
70
racket/collects/racket/private/old-path.rkt
Normal file
|
|
@ -0,0 +1,70 @@
|
|||
;; Old variants of `path-replace-extension` and
|
||||
;; `path-add-extension` that do the wrong thing with
|
||||
;; file names that start "."
|
||||
(module path '#%kernel
|
||||
(#%require "qq-and-or.rkt" "define-et-al.rkt")
|
||||
|
||||
(#%provide path-replace-suffix
|
||||
path-add-suffix)
|
||||
|
||||
(define-values (path-string?)
|
||||
(lambda (s)
|
||||
(or (path? s)
|
||||
(and (string? s)
|
||||
(or (relative-path? s)
|
||||
(absolute-path? s))))))
|
||||
|
||||
(define-values (check-suffix-call)
|
||||
(lambda (s sfx who)
|
||||
(unless (or (path-for-some-system? s)
|
||||
(path-string? s))
|
||||
(raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx))
|
||||
(unless (or (string? sfx) (bytes? sfx))
|
||||
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
|
||||
(let-values ([(base name dir?) (split-path s)])
|
||||
(when (not base)
|
||||
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
|
||||
(values base name))))
|
||||
|
||||
(define-values (path-adjust-suffix)
|
||||
(lambda (name sep rest-bytes s sfx)
|
||||
(let-values ([(base name) (check-suffix-call s sfx name)])
|
||||
(-define bs (path-element->bytes name))
|
||||
(-define finish
|
||||
(lambda (i sep i2)
|
||||
(bytes->path-element
|
||||
(let ([res (bytes-append
|
||||
(subbytes bs 0 i)
|
||||
sep
|
||||
(rest-bytes bs i2)
|
||||
(if (string? sfx)
|
||||
(string->bytes/locale sfx (char->integer #\?))
|
||||
sfx))])
|
||||
(if (zero? (bytes-length res))
|
||||
(raise-arguments-error 'path-replace-suffix
|
||||
"removing suffix makes path element empty"
|
||||
"given path" s)
|
||||
res))
|
||||
(if (path-for-some-system? s)
|
||||
(path-convention-type s)
|
||||
(system-path-convention-type)))))
|
||||
(let ([new-name (letrec-values ([(loop)
|
||||
(lambda (i)
|
||||
(if (zero? i)
|
||||
(finish (bytes-length bs) #"" (bytes-length bs))
|
||||
(let-values ([(i) (sub1 i)])
|
||||
(if (eq? (char->integer #\.) (bytes-ref bs i))
|
||||
(finish i sep (add1 i))
|
||||
(loop i)))))])
|
||||
(loop (bytes-length bs)))])
|
||||
(if (path-for-some-system? base)
|
||||
(build-path base new-name)
|
||||
new-name)))))
|
||||
|
||||
(define-values (path-replace-suffix)
|
||||
(lambda (s sfx)
|
||||
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
|
||||
|
||||
(define-values (path-add-suffix)
|
||||
(lambda (s sfx)
|
||||
(path-adjust-suffix 'path-add-suffix #"_" subbytes s sfx))))
|
||||
33
racket/collects/racket/private/path-list.rkt
Normal file
33
racket/collects/racket/private/path-list.rkt
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
(module path-list '#%kernel
|
||||
(#%require "qq-and-or.rkt" "define-et-al.rkt")
|
||||
|
||||
(#%provide path-list-string->path-list)
|
||||
|
||||
(define-values (path-list-string->path-list)
|
||||
(let ((r (byte-regexp (string->bytes/utf-8
|
||||
(let ((sep (if (eq? (system-type) 'windows)
|
||||
";"
|
||||
":")))
|
||||
(format "([^~a]*)~a(.*)" sep sep)))))
|
||||
(cons-path (lambda (default s l)
|
||||
(let ([s (if (eq? (system-type) 'windows)
|
||||
(regexp-replace* #rx#"\"" s #"")
|
||||
s)])
|
||||
(if (bytes=? s #"")
|
||||
(append default l)
|
||||
(cons (bytes->path s)
|
||||
l))))))
|
||||
(lambda (s default)
|
||||
(unless (or (bytes? s)
|
||||
(string? s))
|
||||
(raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s))
|
||||
(unless (and (list? default)
|
||||
(andmap path? default))
|
||||
(raise-argument-error 'path-list-string->path-list "(listof path?)" default))
|
||||
(let loop ([s (if (string? s)
|
||||
(string->bytes/utf-8 s)
|
||||
s)])
|
||||
(let ([m (regexp-match r s)])
|
||||
(if m
|
||||
(cons-path default (cadr m) (loop (caddr m)))
|
||||
(cons-path default s null))))))))
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
;; Old variants of `path-replace-extension` and
|
||||
;; `path-add-extension` that do the wrong thing with
|
||||
;; file names that start "."
|
||||
(module path '#%kernel
|
||||
(#%require '#%min-stx)
|
||||
(#%require "qq-and-or.rkt" "cond.rkt" "define-et-al.rkt")
|
||||
|
||||
(#%provide path-replace-suffix
|
||||
path-add-suffix)
|
||||
(#%provide path-string?
|
||||
normal-case-path
|
||||
path-replace-extension
|
||||
path-add-extension
|
||||
reroot-path)
|
||||
|
||||
(define-values (path-string?)
|
||||
(lambda (s)
|
||||
|
|
@ -14,7 +14,38 @@
|
|||
(or (relative-path? s)
|
||||
(absolute-path? s))))))
|
||||
|
||||
(define-values (check-suffix-call)
|
||||
(define-values (bsbs) (string #\u5C #\u5C))
|
||||
|
||||
(define-values (normal-case-path)
|
||||
(lambda (s)
|
||||
(unless (or (path-for-some-system? s)
|
||||
(path-string? s))
|
||||
(raise-argument-error 'normal-path-case "(or/c path-for-some-system? path-string?)" s))
|
||||
(cond
|
||||
[(if (path-for-some-system? s)
|
||||
(eq? (path-convention-type s) 'windows)
|
||||
(eq? (system-type) 'windows))
|
||||
(let ([str (if (string? s) s (bytes->string/locale (path->bytes s)))])
|
||||
(if (regexp-match? #rx"^[\u5C][\u5C][?][\u5C]" str)
|
||||
(if (string? s)
|
||||
(string->path s)
|
||||
s)
|
||||
(let ([s (string-locale-downcase str)])
|
||||
(bytes->path
|
||||
(string->bytes/locale
|
||||
(regexp-replace* #rx"/"
|
||||
(if (regexp-match? #rx"[/\u5C][. ]+[/\u5C]*$" s)
|
||||
;; Just "." or ".." in last path element - don't remove
|
||||
s
|
||||
(regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1"))
|
||||
bsbs))
|
||||
'windows))))]
|
||||
[(string? s) (string->path s)]
|
||||
[else s])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-values (check-extension-call)
|
||||
(lambda (s sfx who)
|
||||
(unless (or (path-for-some-system? s)
|
||||
(path-string? s))
|
||||
|
|
@ -23,28 +54,23 @@
|
|||
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
|
||||
(let-values ([(base name dir?) (split-path s)])
|
||||
(when (not base)
|
||||
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
|
||||
(raise-mismatch-error who "cannot add an extension to a root path: " s))
|
||||
(values base name))))
|
||||
|
||||
(define-values (path-adjust-suffix)
|
||||
(define-values (path-adjust-extension)
|
||||
(lambda (name sep rest-bytes s sfx)
|
||||
(let-values ([(base name) (check-suffix-call s sfx name)])
|
||||
(define bs (path-element->bytes name))
|
||||
(define finish
|
||||
(let-values ([(base name) (check-extension-call s sfx name)])
|
||||
(-define bs (path-element->bytes name))
|
||||
(-define finish
|
||||
(lambda (i sep i2)
|
||||
(bytes->path-element
|
||||
(let ([res (bytes-append
|
||||
(bytes-append
|
||||
(subbytes bs 0 i)
|
||||
sep
|
||||
(rest-bytes bs i2)
|
||||
(if (string? sfx)
|
||||
(string->bytes/locale sfx (char->integer #\?))
|
||||
sfx))])
|
||||
(if (zero? (bytes-length res))
|
||||
(raise-arguments-error 'path-replace-suffix
|
||||
"removing suffix makes path element empty"
|
||||
"given path" s)
|
||||
res))
|
||||
sfx))
|
||||
(if (path-for-some-system? s)
|
||||
(path-convention-type s)
|
||||
(system-path-convention-type)))))
|
||||
|
|
@ -53,7 +79,8 @@
|
|||
(if (zero? i)
|
||||
(finish (bytes-length bs) #"" (bytes-length bs))
|
||||
(let-values ([(i) (sub1 i)])
|
||||
(if (eq? (char->integer #\.) (bytes-ref bs i))
|
||||
(if (and (not (zero? i))
|
||||
(eq? (char->integer #\.) (bytes-ref bs i)))
|
||||
(finish i sep (add1 i))
|
||||
(loop i)))))])
|
||||
(loop (bytes-length bs)))])
|
||||
|
|
@ -61,10 +88,65 @@
|
|||
(build-path base new-name)
|
||||
new-name)))))
|
||||
|
||||
(define-values (path-replace-suffix)
|
||||
(define-values (path-replace-extension)
|
||||
(lambda (s sfx)
|
||||
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
|
||||
(path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx)))
|
||||
|
||||
(define-values (path-add-suffix)
|
||||
(define-values (path-add-extension)
|
||||
(lambda (s sfx)
|
||||
(path-adjust-suffix 'path-add-suffix #"_" subbytes s sfx))))
|
||||
(path-adjust-extension 'path-add-extension #"_" subbytes s sfx)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
||||
|
||||
(define-values (reroot-path)
|
||||
(lambda (p root)
|
||||
(unless (or (path-string? p) (path-for-some-system? p))
|
||||
(raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 0 p root))
|
||||
(unless (or (path-string? root) (path-for-some-system? root))
|
||||
(raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 1 p root))
|
||||
(-define conv (if (path-for-some-system? p)
|
||||
(path-convention-type p)
|
||||
(system-path-convention-type)))
|
||||
(unless (or (complete-path? p)
|
||||
(eq? (system-path-convention-type) conv))
|
||||
(raise-arguments-error 'reroot-path
|
||||
"path is not complete and not the platform's convention"
|
||||
"path" p
|
||||
"platform convention type" (system-path-convention-type)))
|
||||
(unless (eq? (if (path-for-some-system? root)
|
||||
(path-convention-type root)
|
||||
(system-path-convention-type))
|
||||
conv)
|
||||
(raise-arguments-error 'reroot-path
|
||||
"given paths use different conventions"
|
||||
"path" p
|
||||
"root path" root))
|
||||
(-define c-p (normal-case-path (cleanse-path (if (complete-path? p)
|
||||
p
|
||||
(path->complete-path p)))))
|
||||
(-define bstr (path->bytes c-p))
|
||||
(cond
|
||||
[(eq? conv 'unix)
|
||||
(if (bytes=? bstr #"/")
|
||||
(if (path-for-some-system? root)
|
||||
root
|
||||
(string->path root))
|
||||
(build-path root (bytes->path (subbytes (path->bytes c-p) 1) conv)))]
|
||||
[(eq? conv 'windows)
|
||||
(build-path
|
||||
root
|
||||
(bytes->path
|
||||
(cond
|
||||
((regexp-match? #rx"^\\\\\\\\[?]\\\\[a-z]:" bstr)
|
||||
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4 5) #"\\" (subbytes bstr 6)))
|
||||
((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
|
||||
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
|
||||
((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
|
||||
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
|
||||
((regexp-match? #rx"^\\\\\\\\" bstr)
|
||||
(bytes-append #"UNC\\" (subbytes bstr 2)))
|
||||
((regexp-match? #rx"^[a-z]:" bstr)
|
||||
(bytes-append (subbytes bstr 0 1) (subbytes bstr 2))))
|
||||
conv))]))))
|
||||
|
|
|
|||
29
racket/collects/racket/private/reading-param.rkt
Normal file
29
racket/collects/racket/private/reading-param.rkt
Normal file
|
|
@ -0,0 +1,29 @@
|
|||
(module reading-params '#%kernel
|
||||
(#%require "more-scheme.rkt" "qq-and-or.rkt")
|
||||
(#%provide call-with-default-reading-parameterization)
|
||||
|
||||
(define-values (call-with-default-reading-parameterization)
|
||||
(lambda (thunk)
|
||||
(if (and (procedure? thunk)
|
||||
(procedure-arity-includes? thunk 0))
|
||||
(parameterize ([read-case-sensitive #t]
|
||||
[read-square-bracket-as-paren #t]
|
||||
[read-curly-brace-as-paren #t]
|
||||
[read-square-bracket-with-tag #f]
|
||||
[read-curly-brace-with-tag #f]
|
||||
[read-accept-box #t]
|
||||
[read-accept-compiled #f]
|
||||
[read-accept-bar-quote #t]
|
||||
[read-accept-graph #t]
|
||||
[read-decimal-as-inexact #t]
|
||||
[read-cdot #f]
|
||||
[read-accept-dot #t]
|
||||
[read-accept-infix-dot #t]
|
||||
[read-accept-quasiquote #t]
|
||||
[read-accept-reader #f]
|
||||
[read-accept-lang #t]
|
||||
[current-readtable #f])
|
||||
(thunk))
|
||||
(raise-argument-error 'call-with-default-reading-parameterization
|
||||
"(procedure-arity-includes/c 0)"
|
||||
thunk)))))
|
||||
Loading…
Reference in New Issue
Block a user