From 6eef00a31287fd88e1c93139dc5b6c1ab97f6da8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 13 Dec 2012 15:32:17 -0700 Subject: [PATCH] raco setup: fix problem with doc index database When a tag is serializable but not `write'--`read' invariant, then it needs to be serialized and deserialized. Also, clarify and check in `tag?' that a tag should be serializable. --- collects/scribble/core.rkt | 3 +- collects/scribblings/scribble/core.scrbl | 5 +- collects/setup/doc-db.rkt | 58 ++++++++++++++++++------ collects/setup/setup-unit.rkt | 8 +++- 4 files changed, 56 insertions(+), 18 deletions(-) diff --git a/collects/scribble/core.rkt b/collects/scribble/core.rkt index 109ccd43bd..07bbb99b15 100644 --- a/collects/scribble/core.rkt +++ b/collects/scribble/core.rkt @@ -93,7 +93,8 @@ (or (string? (cadr s)) (generated-tag? (cadr s)) (and (pair? (cadr s)) - (list? (cadr s)))) + (list? (cadr s)) + (serializable? (cadr s)))) (null? (cddr s)))) (provide block?) diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index 0c03eb8c1b..29b2e72749 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -3,6 +3,7 @@ (except-in "utils.rkt" url) "struct-hierarchy.rkt" (for-label scribble/manual-struct + racket/serialize file/convertible setup/main-collects scriblib/render-cond @@ -1157,8 +1158,8 @@ or @racket[style] structure.} Returns @racket[#t] if @racket[v] is acceptable as a link @techlink{tag}, which is a list containing a symbol and either a -string, a @racket[generated-tag] instance, or a list (of arbitrary -values).} +string, a @racket[generated-tag] instance, or a non-empty list +of @racket[serializable?] values.} @defstruct[generated-tag ()]{ diff --git a/collects/setup/doc-db.rkt b/collects/setup/doc-db.rkt index 63cca2faec..8d095c5f1f 100644 --- a/collects/setup/doc-db.rkt +++ b/collects/setup/doc-db.rkt @@ -1,6 +1,7 @@ #lang racket/base (require db racket/format + racket/serialize "main-doc.rkt") (provide doc-db-available? @@ -89,10 +90,10 @@ 'doc-db-key->path db-file (lambda (db) - (define row (query-maybe-row db select-pathid-vq - (~s key))) - (define pathid (and row - (vector-ref row 0))) + (define rows (query-rows db select-pathid-vq + (->string key))) + (define pathid (and (pair? rows) + (vector-ref (car rows) 0))) (and pathid (pathid->filename db pathid #f main-doc-relative-ok?))))) @@ -106,7 +107,7 @@ (prepare-tables db) (define pathid (filename->pathid db filename)) (for ([p (in-list elems)]) - (define stag (~s p)) + (define stag (->string p)) (callback db stag pathid))))) (define (clear who db-file filename statement) @@ -161,9 +162,9 @@ (query-exec db "INSERT INTO searchSets VALUES ($1, $2, $3)" pathid setid - (~s sk)) + (->string sk)) (for ([k (in-hash-keys s)]) - (define stag (~s k)) + (define stag (->string k)) (query-exec db "INSERT INTO searches VALUES ($1, $2, $3)" pathid setid @@ -226,9 +227,9 @@ " WHERE stag=$1") stag) null)) - (cons (read (if (bytes? stag) - (open-input-bytes stag) - (open-input-string stag))) + (cons (<-string (if (bytes? stag) + (open-input-bytes stag) + (open-input-string stag))) (append (for/list ([pathid-row (in-list pathid-rows)]) (pathid->filename db (vector-ref pathid-row 0) #f main-doc-relative-ok?)) @@ -284,7 +285,7 @@ " GROUP BY SS.stag") pathid)) (map (lambda (s) - (read (open-input-string (vector-ref s 0)))) + (<-string (open-input-string (vector-ref s 0)))) (append rows more-rows))))) @@ -342,7 +343,7 @@ [(equal? "y" (vector-ref row 0)) (main-doc-relative->path (cons 'doc (or (hash-ref reader-cache bstr #f) - (let ([v (read (open-input-bytes bstr))]) + (let ([v (<-string (open-input-bytes bstr))]) (hash-set! reader-cache bstr v) v))))] [(bytes? bstr) @@ -370,7 +371,7 @@ (define filename* (path->main-doc-relative filename)) (define filename-bytes (cond [(pair? filename*) - (string->bytes/utf-8 (~s (cdr filename*)))] + (string->bytes/utf-8 (->string (cdr filename*)))] [(path? filename*) (path->bytes filename*)] [else (path->bytes (string->path filename*))])) @@ -401,7 +402,7 @@ (if (equal? "y" (vector-ref row 0)) ((if main-doc-relative-ok? values main-doc-relative->path) (cons 'doc (or (hash-ref reader-cache path #f) - (let ([v (read (open-input-bytes path))]) + (let ([v (<-string (open-input-bytes path))]) (hash-set! reader-cache path v) v)))) (bytes->path path))))) @@ -494,3 +495,32 @@ (call-with-lock-handler (lambda () (loop (doc-db-pause `(query ,who) pause))) thunk))) + +(define (readable? s) + (or (string? s) + (bytes? s) + (symbol? s) + (number? s) + (boolean? s) + (and (list? s) (andmap readable? s)) + (and (vector? s) (for/and ([v (in-vector s)]) (readable? s))))) + +(define (->string v) + (if (and (not (box? v)) + (readable? v)) + (~s v) + (~s (box (serialize v))))) + +(define (<-string p) + (with-handlers ([exn:fail:read? + (lambda (exn) + (error 'read + (~a "error unmarshaling from database\n" + " original error: ~e") + (exn-message exn)))]) + (define v (read p)) + (if (box? v) + ;; A box indicates serialization: + (deserialize (unbox v)) + ;; Normal value: + v))) diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index d80c501cf7..9a398b9161 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -649,7 +649,13 @@ (define fn (build-path p "info-domain" "compiled" "cache.rktd")) (when (file-exists? fn) (with-handlers ([exn:fail:filesystem? (warning-handler (void))]) - (with-output-to-file fn void #:exists 'truncate/replace)))))) + (with-output-to-file fn void #:exists 'truncate/replace)))) + (setup-printf #f "deleting documentation databases") + (for ([d (in-list (list (find-doc-dir) (find-user-doc-dir)))]) + (when d + (define f (build-path d "docindex.sqlite")) + (when (file-exists? f) + (delete-file f)))))) (define (do-install-part part) (when (if (eq? part 'post) (call-post-install) (call-install))