racket/serialize: refinements for relative paths
Allow selection of relative-path encoding for paths in data independent of whether deserializer module paths are recorded as relative.
This commit is contained in:
Matthew Flatt
parent
c2c04711a3
commit
652a0ad0d1
|
|
@ -17,11 +17,18 @@ See @racket[serialize] for an enumeration of serializable values.}
|
|||
@; ----------------------------------------------------------------------
|
||||
|
||||
@defproc[(serialize [v serializable?]
|
||||
[#:relative-directory relative-to (or/c (and/c path? complete-path?)
|
||||
[#:relative-directory relative-to
|
||||
(or/c (and/c path? complete-path?)
|
||||
(cons/c (and/c path? complete-path?)
|
||||
(and/c path? complete-path?))
|
||||
#f)
|
||||
#f])
|
||||
#f]
|
||||
[#:deserialize-relative-directory deserialize-relative-to
|
||||
(or/c (and/c path? complete-path?)
|
||||
(cons/c (and/c path? complete-path?)
|
||||
(and/c path? complete-path?))
|
||||
#f)
|
||||
relative-to])
|
||||
any]{
|
||||
|
||||
Returns a value that encapsulates the value @racket[v]. This value
|
||||
|
|
@ -71,9 +78,16 @@ are all reachable from each other), then @racket[v] can be serialized
|
|||
only if the cycle includes a mutable value, where a @tech{prefab}
|
||||
structure counts as mutable only if all of its fields are mutable.
|
||||
|
||||
If @racket[relative-to] is not @racket[#f], than the
|
||||
deserializer paths will be relative. See
|
||||
@racket[current-write-relative-path].
|
||||
If @racket[relative-to] is not @racket[#f], then paths to serialize
|
||||
that extend the path in @racket[relative-to] are recorded in relative
|
||||
and platform-independent form. The possible values and treatment of
|
||||
@racket[relative-to] are the same as for @racket[current-write-relative-directory].
|
||||
|
||||
If @racket[deserialize-relative-to] is not @racket[#f], then any paths
|
||||
to deserializers as extracted via @racket[prop:serializable] are
|
||||
recorded in relative form. Note that @racket[relative-to] and
|
||||
@racket[deserialize-relative-to] are independent, but
|
||||
@racket[deserialize-relative-to] defaults to @racket[relative-to].
|
||||
|
||||
@margin-note{The @racket[serialize] and @racket[deserialize] functions
|
||||
currently do not handle certain cyclic values that @racket[read] and
|
||||
|
|
@ -82,8 +96,9 @@ currently do not handle certain cyclic values that @racket[read] and
|
|||
See @racket[deserialize] for information on the format of serialized
|
||||
data.
|
||||
|
||||
@history[#:changed "6.5.0.4" @elem{Added keywords and regexp values as serializable}
|
||||
#:changed "7.0.0.6" @elem{Added @racket[#:relative-directory] argument}]}
|
||||
@history[#:changed "6.5.0.4" @elem{Added keywords and regexp values as serializable.}
|
||||
#:changed "7.0.0.6" @elem{Added the @racket[#:relative-directory] and
|
||||
@racket[#:deserialize-relative-directory] arguments.}]}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
@ -98,12 +113,15 @@ elements:
|
|||
|
||||
@itemize[
|
||||
|
||||
@item{An optional list @racket['(1)], @racket['(2)], or @racket['(3)] that represents
|
||||
@item{An optional list @racket['(1)], @racket['(2)], @racket['(3)],
|
||||
or @racket['(4)] that represents
|
||||
the version of the serialization format. If the first element
|
||||
of a representation is not a list, then the version is
|
||||
@racket[0]. Version 1 adds support for mutable pairs,
|
||||
version 2 adds support for @tech{unreadable symbols},
|
||||
and version 3 adds support for @racket[date*] structures.}
|
||||
version 3 adds support for @racket[date*] structures,
|
||||
and version 4 adds support for paths that are meant to
|
||||
be relative to the deserialization directory.}
|
||||
|
||||
@item{A non-negative exact integer @racket[_s-count] that represents the
|
||||
number of distinct structure types represented in the
|
||||
|
|
@ -119,9 +137,11 @@ elements:
|
|||
for a module that exports the structure's deserialization
|
||||
information, or a relative path element list for a module to
|
||||
be resolved with respect to
|
||||
@racket[current-load-relative-directory] (seen when using
|
||||
the @racket[#:relative-directory] keyword with
|
||||
@racket[serialize]). The @racket[cdr] of the pair is the
|
||||
@racket[current-load-relative-directory] or (as a fallback)
|
||||
@racket[current-directory]; the list-of-relative-elements
|
||||
form is produced by @racket[serialize] when
|
||||
the @racket[#:deserialize-relative-directory] argument is
|
||||
not @racket[#f]. The @racket[cdr] of the pair is the
|
||||
name of a binding (at the top level or exported from a
|
||||
module) for deserialization information, either a symbol or
|
||||
a string representing an @tech{unreadable symbol}. These two
|
||||
|
|
@ -266,6 +286,12 @@ elements:
|
|||
@racket[system-path-convention-type]; it represents a
|
||||
path using the specified convention.}
|
||||
|
||||
@item{a pair whose @racket[car] is @racket['p*] and whose
|
||||
@racket[cdr] is a list of byte strings represents a
|
||||
relative path; it will be converted by deserialization
|
||||
based on @racket[current-load-relative-directory],
|
||||
falling back to @racket[current-directory].}
|
||||
|
||||
@item{a pair whose @racket[car] is @racket['c] and whose
|
||||
@racket[cdr] is a pair of serials; it represents an
|
||||
immutable pair.}
|
||||
|
|
|
|||
|
|
@ -606,6 +606,10 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(let ([fn (make-temporary-file)])
|
||||
(define (try rel-mode #:fail-rel? [fail-rel? #t])
|
||||
(define ns (current-namespace))
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(namespace-attach-module ns 'racket/serialize )
|
||||
(with-output-to-file fn
|
||||
#:exists 'truncate
|
||||
(lambda () (display
|
||||
|
|
@ -615,23 +619,45 @@
|
|||
" (provide s foo?)\n"
|
||||
" (serializable-struct foo (bar))\n"
|
||||
" (define s (serialize (foo 49)\n"
|
||||
" #:relative-directory (find-system-path\n"
|
||||
" 'temp-dir))))\n"))))
|
||||
" #:" rel-mode "relative-directory"
|
||||
" (find-system-path 'temp-dir))))\n"))))
|
||||
(define s (dynamic-require `(submod ,fn main) 's))
|
||||
(define foo? (dynamic-require `(submod ,fn main) 'foo?))
|
||||
(parameterize ([current-load-relative-directory (find-system-path 'temp-dir)])
|
||||
(test #t 'relative-dir (foo? (deserialize s))))
|
||||
(test 'correct-error 'unrelative-dir
|
||||
(test (if fail-rel? 'correct-error 'worked)
|
||||
'unrelative-dir
|
||||
(with-handlers ([exn:fail:contract?
|
||||
(λ (e) 'correct-error)])
|
||||
(deserialize s)))
|
||||
(λ (e) (log-error "~s" e) 'correct-error)])
|
||||
(and (deserialize s)
|
||||
'worked))))
|
||||
(delete-file fn))
|
||||
(try "")
|
||||
(try "deserialize-")
|
||||
(try "deserialize-relative-directory #f #:" #:fail-rel? #f))
|
||||
|
||||
(test (build-path "/" "home" "hotdogs")
|
||||
;; serialize as relative
|
||||
(test (build-path (or (current-load-relative-directory)
|
||||
(current-directory))
|
||||
"hotdogs")
|
||||
'path-data
|
||||
(deserialize
|
||||
(serialize (build-path "/" "home" "hotdogs")
|
||||
#:relative-directory (build-path "/" "home"))))
|
||||
(serialize (build-path (find-system-path 'temp-dir) "home" "hotdogs")
|
||||
#:relative-directory (build-path (find-system-path 'temp-dir) "home"))))
|
||||
|
||||
;; don't serialize as relative
|
||||
(test (build-path (find-system-path 'temp-dir) "home" "hotdogs")
|
||||
'path-data
|
||||
(deserialize
|
||||
(serialize (build-path (find-system-path 'temp-dir) "home" "hotdogs")
|
||||
#:deserialize-relative-directory (build-path (find-system-path 'temp-dir) "work"))))
|
||||
|
||||
;; also don't serialize as relative
|
||||
(test (build-path (find-system-path 'temp-dir) "home" "hotdogs")
|
||||
'path-data
|
||||
(deserialize
|
||||
(serialize (build-path (find-system-path 'temp-dir) "home" "hotdogs")
|
||||
#:deserialize-relative-directory (build-path (find-system-path 'temp-dir) "home"))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -127,9 +127,8 @@
|
|||
[(prefab-struct-key v)
|
||||
(loop (struct->vector v))]
|
||||
[else (void)]))
|
||||
(define exploded-base-dir (box 'not-ready))
|
||||
(define exploded-wrt-rel-dir (box 'not-ready))
|
||||
(define (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
|
||||
(define path->relative-path-elements (make-path->relative-path-elements))
|
||||
;; The fasl formal prefix:
|
||||
(write-bytes fasl-prefix o)
|
||||
;; Write content to a string, so we can measure it
|
||||
|
|
@ -208,9 +207,7 @@
|
|||
(write-fasl-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o)
|
||||
(write-fasl-bytes v o)]
|
||||
[(path-for-some-system? v)
|
||||
(define rel-elems (path->relative-path-elements v
|
||||
#:exploded-base-dir exploded-base-dir
|
||||
#:exploded-wrt-rel-dir exploded-wrt-rel-dir))
|
||||
(define rel-elems (path->relative-path-elements v))
|
||||
(cond
|
||||
[rel-elems
|
||||
(write-byte fasl-relative-path-type o)
|
||||
|
|
@ -230,9 +227,7 @@
|
|||
(define new-src
|
||||
(cond
|
||||
[(and (path? src)
|
||||
(not (path->relative-path-elements src
|
||||
#:exploded-base-dir exploded-base-dir
|
||||
#:exploded-wrt-rel-dir exploded-wrt-rel-dir)))
|
||||
(not (path->relative-path-elements src)))
|
||||
;; Convert to a string
|
||||
(truncate-path src)]
|
||||
[else src]))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide relative-path-elements->path
|
||||
path->relative-path-elements)
|
||||
make-path->relative-path-elements)
|
||||
|
||||
(define (relative-path-elements->path elems)
|
||||
(define wrt-dir (current-load-relative-directory))
|
||||
|
|
@ -12,29 +12,45 @@
|
|||
[(null? rel-elems) (build-path 'same)]
|
||||
[else (apply build-path rel-elems)]))
|
||||
|
||||
(define (path->relative-path-elements v
|
||||
#:write-relative-directory [write-relative-directory #f]
|
||||
#:exploded-base-dir [exploded-base-dir (box 'not-ready)]
|
||||
#:exploded-wrt-rel-dir [exploded-wrt-rel-dir (box 'not-ready)])
|
||||
(when (and (eq? (unbox exploded-base-dir) 'not-ready)
|
||||
(define (make-path->relative-path-elements [wr-dir (current-write-relative-directory)]
|
||||
#:who [who #f])
|
||||
(when who
|
||||
(unless (or (not wr-dir)
|
||||
(and (path-string? wr-dir) (complete-path? wr-dir))
|
||||
(and (pair? wr-dir)
|
||||
(path-string? (car wr-dir)) (complete-path? (car wr-dir))
|
||||
(path-string? (cdr wr-dir)) (complete-path? (cdr wr-dir))))
|
||||
(raise-argument-error who
|
||||
(string-append
|
||||
"(or/c (and/c path-string? complete-path?)\n"
|
||||
" (cons/c (and/c path-string? complete-path?)\n"
|
||||
" (and/c path-string? complete-path?))\n"
|
||||
" #f)")
|
||||
wr-dir)))
|
||||
(cond
|
||||
[(not wr-dir) (lambda (v) #f)]
|
||||
[else
|
||||
(define exploded-base-dir 'not-ready)
|
||||
(define exploded-wrt-rel-dir 'not-ready)
|
||||
(lambda (v)
|
||||
(when (and (eq? exploded-base-dir 'not-ready)
|
||||
(path? v))
|
||||
(define wr-dir (or write-relative-directory (current-write-relative-directory)))
|
||||
(define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir)))
|
||||
(define base-dir (and wr-dir (if (pair? wr-dir) (cdr wr-dir) wr-dir)))
|
||||
(set-box! exploded-base-dir (and base-dir (explode-path base-dir)))
|
||||
(set-box! exploded-wrt-rel-dir
|
||||
(set! exploded-base-dir (and base-dir (explode-path base-dir)))
|
||||
(set! exploded-wrt-rel-dir
|
||||
(if (eq? base-dir wrt-dir)
|
||||
'()
|
||||
(list-tail (explode-path wrt-dir)
|
||||
(length (unbox exploded-base-dir))))))
|
||||
(and (unbox exploded-base-dir)
|
||||
(length exploded-base-dir)))))
|
||||
(and exploded-base-dir
|
||||
(path? v)
|
||||
(let ([exploded (explode-path v)])
|
||||
(and (for/and ([base-p (in-list (unbox exploded-base-dir))]
|
||||
(and (for/and ([base-p (in-list exploded-base-dir)]
|
||||
[p (in-list exploded)])
|
||||
(equal? base-p p))
|
||||
(let loop ([exploded-wrt-rel-dir (unbox exploded-wrt-rel-dir)]
|
||||
[rel (list-tail exploded (length (unbox exploded-base-dir)))])
|
||||
(let loop ([exploded-wrt-rel-dir exploded-wrt-rel-dir]
|
||||
[rel (list-tail exploded (length exploded-base-dir))])
|
||||
(cond
|
||||
[(null? exploded-wrt-rel-dir) rel]
|
||||
[(and (pair? rel)
|
||||
|
|
@ -42,4 +58,4 @@
|
|||
(loop (cdr exploded-wrt-rel-dir) (cdr rel))]
|
||||
[else (append (for/list ([p (in-list exploded-wrt-rel-dir)])
|
||||
'up)
|
||||
rel)]))))))
|
||||
rel)]))))))]))
|
||||
|
|
|
|||
|
|
@ -64,13 +64,14 @@
|
|||
;; If a module is dynamic-required through a path,
|
||||
;; then it can cause simplified module paths to be paths;
|
||||
;; keep the literal path, but marshal it to bytes.
|
||||
(define (protect-path p rel-to)
|
||||
(define (protect-path p deser-path->relative-path)
|
||||
(cond
|
||||
[(path? p) (if rel-to
|
||||
`(relative . ,(path->relative-path-elements p #:write-relative-directory rel-to))
|
||||
(path->bytes p))]
|
||||
[(path? p) (let ([rel (deser-path->relative-path p)])
|
||||
(if rel
|
||||
`(relative . ,rel)
|
||||
(path->bytes p)))]
|
||||
[(and (pair? p) (eq? (car p) 'submod) (path? (cadr p)))
|
||||
`(submod ,(protect-path (cadr p) rel-to) . ,(cddr p))]
|
||||
`(submod ,(protect-path (cadr p) deser-path->relative-path) . ,(cddr p))]
|
||||
[else p]))
|
||||
(define (unprotect-path p)
|
||||
(cond
|
||||
|
|
@ -101,8 +102,8 @@
|
|||
(void))))
|
||||
(define varref (#%variable-reference varref))
|
||||
|
||||
(define (collapse/resolve-module-path-index mpi rel-to)
|
||||
(let ([v (collapse-module-path-index mpi rel-to)])
|
||||
(define (collapse/resolve-module-path-index mpi deser-path->relative-path)
|
||||
(let ([v (collapse-module-path-index mpi deser-path->relative-path)])
|
||||
(if (path? v)
|
||||
;; If collapsing gives a path, then we can't do any better than
|
||||
;; resolving --- and we must resolved, because the mpi may record
|
||||
|
|
@ -113,7 +114,7 @@
|
|||
v2))
|
||||
v)))
|
||||
|
||||
(define (mod-to-id info mod-map cache rel-to)
|
||||
(define (mod-to-id info mod-map cache deser-path->relative-path)
|
||||
(let ([deserialize-id (serialize-info-deserialize-id info)])
|
||||
(hash-ref
|
||||
cache deserialize-id
|
||||
|
|
@ -135,7 +136,7 @@
|
|||
(caddr b)
|
||||
(build-path (serialize-info-dir info)
|
||||
"here.ss"))
|
||||
rel-to)))
|
||||
deser-path->relative-path)))
|
||||
(syntax-e deserialize-id)))]
|
||||
[(symbol? deserialize-id)
|
||||
(cons #f deserialize-id)]
|
||||
|
|
@ -148,7 +149,7 @@
|
|||
(cdr deserialize-id)
|
||||
(build-path (serialize-info-dir info)
|
||||
"here.ss"))
|
||||
rel-to))
|
||||
deser-path->relative-path))
|
||||
(car deserialize-id))]))])
|
||||
(hash-ref
|
||||
mod-map path+name
|
||||
|
|
@ -313,7 +314,7 @@
|
|||
(byte-regexp? v)
|
||||
(bytes? v))))
|
||||
|
||||
(define (serialize-one v share check-share? mod-map mod-map-cache rel-to)
|
||||
(define (serialize-one v share check-share? mod-map mod-map-cache path->relative-path deser-path->relative-path)
|
||||
(define ((serial check-share?) v)
|
||||
(cond
|
||||
[(or (boolean? v)
|
||||
|
|
@ -340,7 +341,7 @@
|
|||
v]
|
||||
[(serializable-struct? v)
|
||||
(let ([info (serializable-info v)])
|
||||
(cons (mod-to-id info mod-map mod-map-cache rel-to)
|
||||
(cons (mod-to-id info mod-map mod-map-cache deser-path->relative-path)
|
||||
(map (serial #t)
|
||||
(vector->list
|
||||
((serialize-info-vectorizer info) v)))))]
|
||||
|
|
@ -355,7 +356,10 @@
|
|||
(bytes? v))
|
||||
(cons 'u v)]
|
||||
[(path-for-some-system? v)
|
||||
(list* 'p+ (path->bytes v) (path-convention-type v))]
|
||||
(let ([v-rel (and (path? v) (path->relative-path v))])
|
||||
(if v-rel
|
||||
(cons 'p* v-rel)
|
||||
(list* 'p+ (path->bytes v) (path-convention-type v))))]
|
||||
[(vector? v)
|
||||
(define elems (map (serial #t) (vector->list v)))
|
||||
(if (and (immutable? v)
|
||||
|
|
@ -414,11 +418,11 @@
|
|||
[else (error 'serialize "shouldn't get here")]))
|
||||
((serial check-share?) v))
|
||||
|
||||
(define (serial-shell v mod-map mod-map-cache rel-to)
|
||||
(define (serial-shell v mod-map mod-map-cache deser-path->relative-path)
|
||||
(cond
|
||||
[(serializable-struct? v)
|
||||
(let ([info (serializable-info v)])
|
||||
(mod-to-id info mod-map mod-map-cache rel-to))]
|
||||
(mod-to-id info mod-map mod-map-cache deser-path->relative-path))]
|
||||
[(vector? v)
|
||||
(cons 'v (vector-length v))]
|
||||
[(mpair? v)
|
||||
|
|
@ -435,11 +439,15 @@
|
|||
(cons 'pf (cons (prefab-struct-key v)
|
||||
(sub1 (vector-length (struct->vector v)))))]))
|
||||
|
||||
(define (serialize v #:relative-directory [rel-to #f])
|
||||
(define (serialize v
|
||||
#:relative-directory [rel-to #f]
|
||||
#:deserialize-relative-directory [deser-rel-to rel-to])
|
||||
(let ([mod-map (make-hasheq)]
|
||||
[mod-map-cache (make-hash)]
|
||||
[share (make-hasheq)]
|
||||
[cycle (make-hasheq)])
|
||||
[cycle (make-hasheq)]
|
||||
[path->relative-path (make-path->relative-path-elements rel-to #:who 'serialize)]
|
||||
[deser-path->relative-path (make-path->relative-path-elements deser-rel-to #:who 'serialize)])
|
||||
;; First, traverse V to find cycles and sharing
|
||||
(find-cycles-and-sharing v cycle share)
|
||||
;; To simplify, all add the cycle records to shared.
|
||||
|
|
@ -453,19 +461,19 @@
|
|||
(if (hash-ref cycle v #f)
|
||||
;; Box indicates cycle record allocation
|
||||
;; followed by normal serialization
|
||||
(box (serial-shell v mod-map mod-map-cache rel-to))
|
||||
(box (serial-shell v mod-map mod-map-cache deser-path->relative-path))
|
||||
;; Otherwise, normal serialization
|
||||
(serialize-one v share #f mod-map mod-map-cache rel-to)))
|
||||
(serialize-one v share #f mod-map mod-map-cache path->relative-path deser-path->relative-path)))
|
||||
ordered)]
|
||||
[fixups (hash-map
|
||||
cycle
|
||||
(lambda (v n)
|
||||
(cons n
|
||||
(serialize-one v share #f mod-map mod-map-cache rel-to))))]
|
||||
[main-serialized (serialize-one v share #t mod-map mod-map-cache rel-to)]
|
||||
(serialize-one v share #f mod-map mod-map-cache path->relative-path deser-path->relative-path))))]
|
||||
[main-serialized (serialize-one v share #t mod-map mod-map-cache path->relative-path deser-path->relative-path)]
|
||||
[mod-map-l (map car (sort (hash-map mod-map cons)
|
||||
(lambda (a b) (< (cdr a) (cdr b)))))])
|
||||
(list '(3) ;; serialization-format version
|
||||
(list (if (or rel-to deser-rel-to) '(4) '(3)) ;; serialization-format version
|
||||
(hash-count mod-map)
|
||||
(map (lambda (v) (if (symbol-interned? (cdr v))
|
||||
v
|
||||
|
|
@ -547,6 +555,7 @@
|
|||
[(bytes? x) (bytes-copy x)]))]
|
||||
[(p) (bytes->path (cdr v))]
|
||||
[(p+) (bytes->path (cadr v) (cddr v))]
|
||||
[(p*) (relative-path-elements->path (cdr v))]
|
||||
[(c) (cons (loop (cadr v)) (loop (cddr v)))]
|
||||
[(c!) (cons (loop (cadr v)) (loop (cddr v)))]
|
||||
[(m) (mcons (loop (cadr v)) (loop (cddr v)))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user