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

racket/serialize: refinements for relative paths

Browse Source 
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 2018-07-15 12:22:16 -06:00
parent c2c04711a3
commit 652a0ad0d1
5 changed files with 172 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
pkgs/racket-doc/scribblings/reference/serialization.scrbl
View File

@ -17,11 +17,18 @@ See @racket[serialize] for an enumeration of serializable values.}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@defproc[(serialize [v serializable?] @defproc[(serialize [v serializable?]
[#:relative-directory relative-to (or/c (and/c path? complete-path?) [#:relative-directory relative-to
(cons/c (and/c path? complete-path?) (or/c (and/c path? complete-path?)
(and/c path? complete-path?)) (cons/c (and/c path? complete-path?)
#f) (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]{ any]{
Returns a value that encapsulates the value @racket[v]. This value 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} only if the cycle includes a mutable value, where a @tech{prefab}
structure counts as mutable only if all of its fields are mutable. structure counts as mutable only if all of its fields are mutable.
If @racket[relative-to] is not @racket[#f], than the If @racket[relative-to] is not @racket[#f], then paths to serialize
deserializer paths will be relative. See that extend the path in @racket[relative-to] are recorded in relative
@racket[current-write-relative-path]. 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 @margin-note{The @racket[serialize] and @racket[deserialize] functions
currently do not handle certain cyclic values that @racket[read] and 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 See @racket[deserialize] for information on the format of serialized
data. data.
@history[#:changed "6.5.0.4" @elem{Added keywords and regexp values as serializable} @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}]} #:changed "7.0.0.6" @elem{Added the @racket[#:relative-directory] and
@racket[#:deserialize-relative-directory] arguments.}]}
@; ---------------------------------------------------------------------- @; ----------------------------------------------------------------------
@ -98,12 +113,15 @@ elements:
@itemize[ @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 the version of the serialization format. If the first element
of a representation is not a list, then the version is of a representation is not a list, then the version is
@racket[0]. Version 1 adds support for mutable pairs, @racket[0]. Version 1 adds support for mutable pairs,
version 2 adds support for @tech{unreadable symbols}, 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 @item{A non-negative exact integer @racket[_s-count] that represents the
number of distinct structure types represented in the number of distinct structure types represented in the
@ -119,9 +137,11 @@ elements:
for a module that exports the structure's deserialization for a module that exports the structure's deserialization
information, or a relative path element list for a module to information, or a relative path element list for a module to
be resolved with respect to be resolved with respect to
@racket[current-load-relative-directory] (seen when using @racket[current-load-relative-directory] or (as a fallback)
the @racket[#:relative-directory] keyword with @racket[current-directory]; the list-of-relative-elements
@racket[serialize]). The @racket[cdr] of the pair is the 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 name of a binding (at the top level or exported from a
module) for deserialization information, either a symbol or module) for deserialization information, either a symbol or
a string representing an @tech{unreadable symbol}. These two a string representing an @tech{unreadable symbol}. These two
@ -266,6 +286,12 @@ elements:
@racket[system-path-convention-type]; it represents a @racket[system-path-convention-type]; it represents a
path using the specified convention.} 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 @item{a pair whose @racket[car] is @racket['c] and whose
@racket[cdr] is a pair of serials; it represents an @racket[cdr] is a pair of serials; it represents an
immutable pair.} immutable pair.}

72
pkgs/racket-test-core/tests/racket/serialize.rktl
View File

@ -606,32 +606,58 @@
;; ---------------------------------------- ;; ----------------------------------------
(let ([fn (make-temporary-file)]) (let ([fn (make-temporary-file)])
(with-output-to-file fn (define (try rel-mode #:fail-rel? [fail-rel? #t])
#:exists 'truncate (define ns (current-namespace))
(lambda () (display (parameterize ([current-namespace (make-base-namespace)])
(string-append "#lang racket/base\n" (namespace-attach-module ns 'racket/serialize )
"(require racket/serialize)\n" (with-output-to-file fn
"(module+ main\n" #:exists 'truncate
" (provide s foo?)\n" (lambda () (display
" (serializable-struct foo (bar))\n" (string-append "#lang racket/base\n"
" (define s (serialize (foo 49)\n" "(require racket/serialize)\n"
" #:relative-directory (find-system-path\n" "(module+ main\n"
" 'temp-dir))))\n")))) " (provide s foo?)\n"
(define s (dynamic-require `(submod ,fn main) 's)) " (serializable-struct foo (bar))\n"
(define foo? (dynamic-require `(submod ,fn main) 'foo?)) " (define s (serialize (foo 49)\n"
(parameterize ([current-load-relative-directory (find-system-path 'temp-dir)]) " #:" rel-mode "relative-directory"
(test #t 'relative-dir (foo? (deserialize s)))) " (find-system-path 'temp-dir))))\n"))))
(test 'correct-error 'unrelative-dir (define s (dynamic-require `(submod ,fn main) 's))
(with-handlers ([exn:fail:contract? (define foo? (dynamic-require `(submod ,fn main) 'foo?))
(λ (e) 'correct-error)]) (parameterize ([current-load-relative-directory (find-system-path 'temp-dir)])
(deserialize s))) (test #t 'relative-dir (foo? (deserialize s))))
(delete-file fn)) (test (if fail-rel? 'correct-error 'worked)
'unrelative-dir
(with-handlers ([exn:fail:contract?
(λ (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 'path-data
(deserialize (deserialize
(serialize (build-path "/" "home" "hotdogs") (serialize (build-path (find-system-path 'temp-dir) "home" "hotdogs")
#:relative-directory (build-path "/" "home")))) #: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"))))
;; ---------------------------------------- ;; ----------------------------------------

11
racket/collects/racket/fasl.rkt
View File

@ -127,9 +127,8 @@
[(prefab-struct-key v) [(prefab-struct-key v)
(loop (struct->vector v))] (loop (struct->vector v))]
[else (void)])) [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 (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
(define path->relative-path-elements (make-path->relative-path-elements))
;; The fasl formal prefix: ;; The fasl formal prefix:
(write-bytes fasl-prefix o) (write-bytes fasl-prefix o)
;; Write content to a string, so we can measure it ;; 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-integer (if (treat-immutable? v) fasl-immutable-bytes-type fasl-bytes-type) o)
(write-fasl-bytes v o)] (write-fasl-bytes v o)]
[(path-for-some-system? v) [(path-for-some-system? v)
(define rel-elems (path->relative-path-elements v (define rel-elems (path->relative-path-elements v))
#:exploded-base-dir exploded-base-dir
#:exploded-wrt-rel-dir exploded-wrt-rel-dir))
(cond (cond
[rel-elems [rel-elems
(write-byte fasl-relative-path-type o) (write-byte fasl-relative-path-type o)
@ -230,9 +227,7 @@
(define new-src (define new-src
(cond (cond
[(and (path? src) [(and (path? src)
(not (path->relative-path-elements src (not (path->relative-path-elements src)))
#:exploded-base-dir exploded-base-dir
#:exploded-wrt-rel-dir exploded-wrt-rel-dir)))
;; Convert to a string ;; Convert to a string
(truncate-path src)] (truncate-path src)]
[else src])) [else src]))

80
racket/collects/racket/private/relative-path.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(provide relative-path-elements->path (provide relative-path-elements->path
path->relative-path-elements) make-path->relative-path-elements)
(define (relative-path-elements->path elems) (define (relative-path-elements->path elems)
(define wrt-dir (current-load-relative-directory)) (define wrt-dir (current-load-relative-directory))
@ -12,34 +12,50 @@
[(null? rel-elems) (build-path 'same)] [(null? rel-elems) (build-path 'same)]
[else (apply build-path rel-elems)])) [else (apply build-path rel-elems)]))
(define (path->relative-path-elements v (define (make-path->relative-path-elements [wr-dir (current-write-relative-directory)]
#:write-relative-directory [write-relative-directory #f] #:who [who #f])
#:exploded-base-dir [exploded-base-dir (box 'not-ready)] (when who
#:exploded-wrt-rel-dir [exploded-wrt-rel-dir (box 'not-ready)]) (unless (or (not wr-dir)
(when (and (eq? (unbox exploded-base-dir) 'not-ready) (and (path-string? wr-dir) (complete-path? wr-dir))
(path? v)) (and (pair? wr-dir)
(define wr-dir (or write-relative-directory (current-write-relative-directory))) (path-string? (car wr-dir)) (complete-path? (car wr-dir))
(define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir))) (path-string? (cdr wr-dir)) (complete-path? (cdr wr-dir))))
(define base-dir (and wr-dir (if (pair? wr-dir) (cdr wr-dir) wr-dir))) (raise-argument-error who
(set-box! exploded-base-dir (and base-dir (explode-path base-dir))) (string-append
(set-box! exploded-wrt-rel-dir "(or/c (and/c path-string? complete-path?)\n"
(if (eq? base-dir wrt-dir) " (cons/c (and/c path-string? complete-path?)\n"
'() " (and/c path-string? complete-path?))\n"
(list-tail (explode-path wrt-dir) " #f)")
(length (unbox exploded-base-dir)))))) wr-dir)))
(and (unbox exploded-base-dir) (cond
(path? v) [(not wr-dir) (lambda (v) #f)]
(let ([exploded (explode-path v)]) [else
(and (for/and ([base-p (in-list (unbox exploded-base-dir))] (define exploded-base-dir 'not-ready)
[p (in-list exploded)]) (define exploded-wrt-rel-dir 'not-ready)
(equal? base-p p)) (lambda (v)
(let loop ([exploded-wrt-rel-dir (unbox exploded-wrt-rel-dir)] (when (and (eq? exploded-base-dir 'not-ready)
[rel (list-tail exploded (length (unbox exploded-base-dir)))]) (path? v))
(cond (define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir)))
[(null? exploded-wrt-rel-dir) rel] (define base-dir (and wr-dir (if (pair? wr-dir) (cdr wr-dir) wr-dir)))
[(and (pair? rel) (set! exploded-base-dir (and base-dir (explode-path base-dir)))
(equal? (car rel) (car exploded-wrt-rel-dir))) (set! exploded-wrt-rel-dir
(loop (cdr exploded-wrt-rel-dir) (cdr rel))] (if (eq? base-dir wrt-dir)
[else (append (for/list ([p (in-list exploded-wrt-rel-dir)]) '()
'up) (list-tail (explode-path wrt-dir)
rel)])))))) (length exploded-base-dir)))))
(and exploded-base-dir
(path? v)
(let ([exploded (explode-path v)])
(and (for/and ([base-p (in-list exploded-base-dir)]
[p (in-list exploded)])
(equal? base-p p))
(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)
(equal? (car rel) (car exploded-wrt-rel-dir)))
(loop (cdr exploded-wrt-rel-dir) (cdr rel))]
[else (append (for/list ([p (in-list exploded-wrt-rel-dir)])
'up)
rel)]))))))]))

53
racket/collects/racket/private/serialize.rkt
View File

@ -64,13 +64,14 @@
;; If a module is dynamic-required through a path, ;; If a module is dynamic-required through a path,
;; then it can cause simplified module paths to be paths; ;; then it can cause simplified module paths to be paths;
;; keep the literal path, but marshal it to bytes. ;; keep the literal path, but marshal it to bytes.
(define (protect-path p rel-to) (define (protect-path p deser-path->relative-path)
(cond (cond
[(path? p) (if rel-to [(path? p) (let ([rel (deser-path->relative-path p)])
`(relative . ,(path->relative-path-elements p #:write-relative-directory rel-to)) (if rel
(path->bytes p))] `(relative . ,rel)
(path->bytes p)))]
[(and (pair? p) (eq? (car p) 'submod) (path? (cadr 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])) [else p]))
(define (unprotect-path p) (define (unprotect-path p)
(cond (cond
@ -101,8 +102,8 @@
(void)))) (void))))
(define varref (#%variable-reference varref)) (define varref (#%variable-reference varref))
(define (collapse/resolve-module-path-index mpi rel-to) (define (collapse/resolve-module-path-index mpi deser-path->relative-path)
(let ([v (collapse-module-path-index mpi rel-to)]) (let ([v (collapse-module-path-index mpi deser-path->relative-path)])
(if (path? v) (if (path? v)
;; If collapsing gives a path, then we can't do any better than ;; If collapsing gives a path, then we can't do any better than
;; resolving --- and we must resolved, because the mpi may record ;; resolving --- and we must resolved, because the mpi may record
@ -113,7 +114,7 @@
v2)) v2))
v))) 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)]) (let ([deserialize-id (serialize-info-deserialize-id info)])
(hash-ref (hash-ref
cache deserialize-id cache deserialize-id
@ -135,7 +136,7 @@
(caddr b) (caddr b)
(build-path (serialize-info-dir info) (build-path (serialize-info-dir info)
"here.ss")) "here.ss"))
rel-to))) deser-path->relative-path)))
(syntax-e deserialize-id)))] (syntax-e deserialize-id)))]
[(symbol? deserialize-id) [(symbol? deserialize-id)
(cons #f deserialize-id)] (cons #f deserialize-id)]
@ -148,7 +149,7 @@
(cdr deserialize-id) (cdr deserialize-id)
(build-path (serialize-info-dir info) (build-path (serialize-info-dir info)
"here.ss")) "here.ss"))
rel-to)) deser-path->relative-path))
(car deserialize-id))]))]) (car deserialize-id))]))])
(hash-ref (hash-ref
mod-map path+name mod-map path+name
@ -313,7 +314,7 @@
(byte-regexp? v) (byte-regexp? v)
(bytes? 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) (define ((serial check-share?) v)
(cond (cond
[(or (boolean? v) [(or (boolean? v)
@ -340,7 +341,7 @@
v] v]
[(serializable-struct? v) [(serializable-struct? v)
(let ([info (serializable-info 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) (map (serial #t)
(vector->list (vector->list
((serialize-info-vectorizer info) v)))))] ((serialize-info-vectorizer info) v)))))]
@ -355,7 +356,10 @@
(bytes? v)) (bytes? v))
(cons 'u v)] (cons 'u v)]
[(path-for-some-system? 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) [(vector? v)
(define elems (map (serial #t) (vector->list v))) (define elems (map (serial #t) (vector->list v)))
(if (and (immutable? v) (if (and (immutable? v)
@ -414,11 +418,11 @@
[else (error 'serialize "shouldn't get here")])) [else (error 'serialize "shouldn't get here")]))
((serial check-share?) v)) ((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 (cond
[(serializable-struct? v) [(serializable-struct? v)
(let ([info (serializable-info 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) [(vector? v)
(cons 'v (vector-length v))] (cons 'v (vector-length v))]
[(mpair? v) [(mpair? v)
@ -435,11 +439,15 @@
(cons 'pf (cons (prefab-struct-key v) (cons 'pf (cons (prefab-struct-key v)
(sub1 (vector-length (struct->vector 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)] (let ([mod-map (make-hasheq)]
[mod-map-cache (make-hash)] [mod-map-cache (make-hash)]
[share (make-hasheq)] [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 ;; First, traverse V to find cycles and sharing
(find-cycles-and-sharing v cycle share) (find-cycles-and-sharing v cycle share)
;; To simplify, all add the cycle records to shared. ;; To simplify, all add the cycle records to shared.
@ -453,19 +461,19 @@
(if (hash-ref cycle v #f) (if (hash-ref cycle v #f)
;; Box indicates cycle record allocation ;; Box indicates cycle record allocation
;; followed by normal serialization ;; 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 ;; 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)] ordered)]
[fixups (hash-map [fixups (hash-map
cycle cycle
(lambda (v n) (lambda (v n)
(cons n (cons n
(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))))]
[main-serialized (serialize-one v share #t mod-map mod-map-cache rel-to)] [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) [mod-map-l (map car (sort (hash-map mod-map cons)
(lambda (a b) (< (cdr a) (cdr b)))))]) (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) (hash-count mod-map)
(map (lambda (v) (if (symbol-interned? (cdr v)) (map (lambda (v) (if (symbol-interned? (cdr v))
v v
@ -547,6 +555,7 @@
[(bytes? x) (bytes-copy x)]))] [(bytes? x) (bytes-copy x)]))]
[(p) (bytes->path (cdr v))] [(p) (bytes->path (cdr v))]
[(p+) (bytes->path (cadr v) (cddr 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)))]
[(c!) (cons (loop (cadr v)) (loop (cddr v)))] [(c!) (cons (loop (cadr v)) (loop (cddr v)))]
[(m) (mcons (loop (cadr v)) (loop (cddr v)))] [(m) (mcons (loop (cadr v)) (loop (cddr v)))]