From 652a0ad0d11f95f8e1b81d83e6e5d2d072a856ff Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 15 Jul 2018 12:22:16 -0600 Subject: [PATCH] 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. --- .../scribblings/reference/serialization.scrbl | 56 +++++++++---- .../tests/racket/serialize.rktl | 72 +++++++++++------ racket/collects/racket/fasl.rkt | 11 +-- .../collects/racket/private/relative-path.rkt | 80 +++++++++++-------- racket/collects/racket/private/serialize.rkt | 53 +++++++----- 5 files changed, 172 insertions(+), 100 deletions(-) diff --git a/pkgs/racket-doc/scribblings/reference/serialization.scrbl b/pkgs/racket-doc/scribblings/reference/serialization.scrbl index b5e29d067e..d1f6ae859d 100644 --- a/pkgs/racket-doc/scribblings/reference/serialization.scrbl +++ b/pkgs/racket-doc/scribblings/reference/serialization.scrbl @@ -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?) - (cons/c (and/c path? complete-path?) - (and/c path? complete-path?)) - #f) - #f]) + [#: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] + [#: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.} diff --git a/pkgs/racket-test-core/tests/racket/serialize.rktl b/pkgs/racket-test-core/tests/racket/serialize.rktl index 7630d98de6..70d4c87ae9 100644 --- a/pkgs/racket-test-core/tests/racket/serialize.rktl +++ b/pkgs/racket-test-core/tests/racket/serialize.rktl @@ -606,32 +606,58 @@ ;; ---------------------------------------- (let ([fn (make-temporary-file)]) - (with-output-to-file fn - #:exists 'truncate - (lambda () (display - (string-append "#lang racket/base\n" - "(require racket/serialize)\n" - "(module+ main\n" - " (provide s foo?)\n" - " (serializable-struct foo (bar))\n" - " (define s (serialize (foo 49)\n" - " #:relative-directory (find-system-path\n" - " '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 - (with-handlers ([exn:fail:contract? - (λ (e) 'correct-error)]) - (deserialize s))) - (delete-file fn)) + (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 + (string-append "#lang racket/base\n" + "(require racket/serialize)\n" + "(module+ main\n" + " (provide s foo?)\n" + " (serializable-struct foo (bar))\n" + " (define s (serialize (foo 49)\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 (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 (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")))) ;; ---------------------------------------- diff --git a/racket/collects/racket/fasl.rkt b/racket/collects/racket/fasl.rkt index ef95ec038b..1bcd0b5d1f 100644 --- a/racket/collects/racket/fasl.rkt +++ b/racket/collects/racket/fasl.rkt @@ -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])) diff --git a/racket/collects/racket/private/relative-path.rkt b/racket/collects/racket/private/relative-path.rkt index 4c54d2d767..397c589930 100644 --- a/racket/collects/racket/private/relative-path.rkt +++ b/racket/collects/racket/private/relative-path.rkt @@ -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,34 +12,50 @@ [(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) - (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 - (if (eq? base-dir wrt-dir) - '() - (list-tail (explode-path wrt-dir) - (length (unbox exploded-base-dir)))))) - (and (unbox exploded-base-dir) - (path? v) - (let ([exploded (explode-path v)]) - (and (for/and ([base-p (in-list (unbox 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)))]) - (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)])))))) +(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 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! 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 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)]))))))])) diff --git a/racket/collects/racket/private/serialize.rkt b/racket/collects/racket/private/serialize.rkt index 1bad079d5d..b842440153 100644 --- a/racket/collects/racket/private/serialize.rkt +++ b/racket/collects/racket/private/serialize.rkt @@ -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)))]