From 17b4c978975751a732bb0e479e0175c64452fc41 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 25 Dec 2018 21:13:53 -0800 Subject: [PATCH] structify ref --- pitfall/pitfall/annotations.rkt | 4 +- pitfall/pitfall/color.rkt | 2 +- pitfall/pitfall/core.rkt | 13 ++++- pitfall/pitfall/document.rkt | 14 +++--- pitfall/pitfall/embedded.rkt | 77 +++++++++++++++-------------- pitfall/pitfall/jpeg.rkt | 4 +- pitfall/pitfall/object.rkt | 1 + pitfall/pitfall/page-test.rkt | 5 +- pitfall/pitfall/page.rkt | 8 +-- pitfall/pitfall/png.rkt | 11 +++-- pitfall/pitfall/reference.rkt | 81 ++++++++----------------------- pitfall/pitfall/standard-font.rkt | 6 ++- 12 files changed, 101 insertions(+), 125 deletions(-) diff --git a/pitfall/pitfall/annotations.rkt b/pitfall/pitfall/annotations.rkt index 16d0803e..201a10fb 100644 --- a/pitfall/pitfall/annotations.rkt +++ b/pitfall/pitfall/annotations.rkt @@ -29,7 +29,7 @@ (define annots-ref (make-ref options)) (send (send this page) annotations annots-ref) - (send annots-ref end) + (ref-end annots-ref) this) (define/public (link x y w h url [options (mhasheq)]) @@ -37,7 +37,7 @@ 'Subtype 'Link 'A (make-ref (mhash 'S 'URI 'URI url))) - (send (hash-ref options 'A) end) + (ref-end (hash-ref options 'A)) (annotate x y w h options)) (define/public (convert-rect x1 y1 w h) diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index a7c4b34c..2988d82b 100644 --- a/pitfall/pitfall/color.rkt +++ b/pitfall/pitfall/color.rkt @@ -106,7 +106,7 @@ (when stroke-opacity (hash-set! dictionary 'CA stroke-opacity)) (define ref-dict (make-ref dictionary)) - (send ref-dict end) + (ref-end ref-dict) (set! @opacity-count (add1 @opacity-count)) (list ref-dict (string->symbol (format "Gs~a" @opacity-count)))))) (hash-set! (send (send this page) ext_gstates) name dictionary) diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index 1fa3e2a0..610ff399 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -1,8 +1,19 @@ #lang racket/base -(require racket/match racket/port) +(require racket/match racket/port racket/dict) (provide (all-defined-out)) ;; structs + +(struct $ref (id payload offset port) #:transparent #:mutable + #:methods gen:dict + [(define (dict-ref $ key [thunk (λ () (error 'dict-ref-key-not-found))]) + (hash-ref ($ref-payload $) key)) + (define (dict-ref! $ key thunk) + (hash-ref! ($ref-payload $) key thunk)) + (define (dict-set! $ key val) (hash-set! ($ref-payload $) key val)) + (define (dict-update! $ key updater [failure-result (λ () (error 'update-no-key))]) + (hash-update! ($ref-payload $) key updater failure-result))]) + ;; for JPEG and PNG (struct image (label width height obj) #:transparent #:mutable) diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 9c18e937..9e1b62dd 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -88,17 +88,17 @@ (define doc-info (make-ref)) (for ([(key val) (in-hash @info)]) (dict-set! doc-info key val)) - (send doc-info end) + (ref-end doc-info) (for ([font (in-hash-values @font-families)]) (send font end)) - (send* (dict-ref @root 'Pages) - [set-key! 'Count (length @pages)] - [set-key! 'Kids (map (λ (page) (get-field dictionary page)) (reverse @pages))] - [end]) + (define pages-ref (dict-ref @root 'Pages)) + (dict-set! pages-ref 'Count (length @pages)) + (dict-set! pages-ref 'Kids (map (λ (page) (get-field dictionary page)) (reverse @pages))) + (ref-end pages-ref) - (send @root end) + (ref-end @root) (define xref-offset (file-position (current-output-port))) (write-bytes-out "xref") @@ -106,7 +106,7 @@ (write-bytes-out "0000000000 65535 f ") (for ([ref (in-list (reverse @refs))]) (write-bytes-out - (string-append (~r (get-field offset ref) #:min-width 10 #:pad-string "0") " 00000 n "))) + (string-append (~r ($ref-offset ref) #:min-width 10 #:pad-string "0") " 00000 n "))) (write-bytes-out "trailer") (write-bytes-out (convert (mhasheq 'Size (add1 (length @refs)) 'Root @root diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index 750ad522..bd2a30c9 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/pitfall/pitfall/embedded.rkt @@ -90,8 +90,9 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (when isCFF (dict-set! font-file 'Subtype 'CIDFontType0C)) - - (send* font-file [write (get-output-bytes (encode-to-port subset))] [end]) + + (ref-write font-file (get-output-bytes (encode-to-port subset))) + (ref-end font-file) (define family-class (if (has-table? font 'OS/2) (floor (/ (hash-ref (get-OS/2-table font) 'sFamilyClass) 256)) ; >> 8 @@ -114,46 +115,45 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (define name (string->symbol (string-append tag "+" (font-postscript-name font)))) (define bbox (font-bbox font)) (define descriptor (make-ref - (mhash - 'Type 'FontDescriptor - 'FontName name - 'Flags flags - 'FontBBox (map (λ (x) (* scale x)) - (bbox->list bbox)) - 'ItalicAngle (font-italic-angle font) - 'Ascent @ascender - 'Descent @descender - 'CapHeight (* (or (font-cap-height font) (font-ascent font)) scale) - 'XHeight (* (or (font-x-height font) 0) scale) - 'StemV 0))) + (mhash + 'Type 'FontDescriptor + 'FontName name + 'Flags flags + 'FontBBox (map (λ (x) (* scale x)) + (bbox->list bbox)) + 'ItalicAngle (font-italic-angle font) + 'Ascent @ascender + 'Descent @descender + 'CapHeight (* (or (font-cap-height font) (font-ascent font)) scale) + 'XHeight (* (or (font-x-height font) 0) scale) + 'StemV 0))) (dict-set! descriptor (if isCFF 'FontFile3 'FontFile2) font-file) - (send descriptor end) + (ref-end descriptor) (define descendant-font (make-ref - (mhash - 'Type 'Font - 'Subtype (string->symbol (string-append "CIDFontType" (if isCFF "0" "2"))) - 'BaseFont name - 'CIDSystemInfo - (mhash - 'Registry "Adobe" - 'Ordering "Identity" - 'Supplement 0) - 'FontDescriptor descriptor - 'W (list 0 (for/list ([idx (in-range (length (hash-keys widths)))]) - (hash-ref widths idx (λ () (error 'embed (format "hash key ~a not found" idx))))))))) - (send descendant-font end) + (mhash + 'Type 'Font + 'Subtype (string->symbol (string-append "CIDFontType" (if isCFF "0" "2"))) + 'BaseFont name + 'CIDSystemInfo + (mhash + 'Registry "Adobe" + 'Ordering "Identity" + 'Supplement 0) + 'FontDescriptor descriptor + 'W (list 0 (for/list ([idx (in-range (length (hash-keys widths)))]) + (hash-ref widths idx (λ () (error 'embed (format "hash key ~a not found" idx))))))))) + (ref-end descendant-font) - (send* @dictionary - [set-key! 'Type 'Font] - [set-key! 'Subtype 'Type0] - [set-key! 'BaseFont name] - [set-key! 'Encoding 'Identity-H] - [set-key! 'DescendantFonts (list descendant-font)] - [set-key! 'ToUnicode (toUnicodeCmap)]) + [dict-set! @dictionary 'Type 'Font] + [dict-set! @dictionary 'Subtype 'Type0] + [dict-set! @dictionary 'BaseFont name] + [dict-set! @dictionary 'Encoding 'Identity-H] + [dict-set! @dictionary 'DescendantFonts (list descendant-font)] + [dict-set! @dictionary 'ToUnicode (toUnicodeCmap)] - (send @dictionary end)) + (ref-end @dictionary)) (define/public (toUnicodeCmap) @@ -191,9 +191,8 @@ end HERE ) - (send* cmap - [write (format unicode-cmap-str (to-hex (sub1 (length entries))) (string-join entries " "))] - [end]) + (ref-write cmap (format unicode-cmap-str (to-hex (sub1 (length entries))) (string-join entries " "))) + (ref-end cmap) cmap))) (module+ test diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt index 1babad47..465fe0d9 100644 --- a/pitfall/pitfall/jpeg.rkt +++ b/pitfall/pitfall/jpeg.rkt @@ -60,8 +60,8 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/jpeg.coffee (when (eq? @colorSpace 'DeviceCMYK) (dict-set! @obj 'Decode '(1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0))) (file-position @data 0) - (send* @obj [write @data] - [end]))))) + (ref-write @obj @data) + (ref-end @obj))))) (define (read-16bit-integer ip-or-bytes) (define signed #f) (define big-endian #t) diff --git a/pitfall/pitfall/object.rkt b/pitfall/pitfall/object.rkt index 000108da..31437ea4 100644 --- a/pitfall/pitfall/object.rkt +++ b/pitfall/pitfall/object.rkt @@ -63,6 +63,7 @@ [(bytes? x) (format "<~a>" (string-append* (for/list ([b (in-bytes x)]) (number->string b 16))))] + [($ref? x) (format "~a 0 R" ($ref-id x))] [(object? x) (send x to-string)] [(date? x) (format "(D:~aZ)" (date->string x "~Y~m~d~H~M~S"))] [(list? x) (format "[~a]" (string-join (map loop x) " "))] diff --git a/pitfall/pitfall/page-test.rkt b/pitfall/pitfall/page-test.rkt index bd1e275b..7a234f22 100644 --- a/pitfall/pitfall/page-test.rkt +++ b/pitfall/pitfall/page-test.rkt @@ -16,6 +16,5 @@ (check-equal? (· p dictionary Type) 'Page) (check-equal? (· p dictionary MediaBox) '(0 0 612.0 792.0)) -(check-true (is-a? (· p dictionary Contents) PDFReference)) -(check-true (is-a? (· p dictionary Resources) PDFReference)) -#;(check-true (is-a? (· p dictionary Parent) PDFReference)) \ No newline at end of file +(check-true ($ref? (· p dictionary Contents))) +(check-true ($ref? (· p dictionary Resources))) \ No newline at end of file diff --git a/pitfall/pitfall/page.rkt b/pitfall/pitfall/page.rkt index 87ed3e60..f24e2294 100644 --- a/pitfall/pitfall/page.rkt +++ b/pitfall/pitfall/page.rkt @@ -57,12 +57,12 @@ (- @height (margin-bottom @margins))) (define/public (write chunk) - (send @content write chunk)) + (ref-write @content chunk)) (define/public (end) - (send @dictionary end) - (send @resources end) - (send @content end)))) + (ref-end @dictionary) + (ref-end @resources) + (ref-end @content)))) (define page-sizes diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 267e68aa..050a9bbe 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -44,13 +44,14 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee 'BitsPerComponent (hash-ref @image 'bits) 'Columns @width))) (dict-set! @obj 'DecodeParms params) - (send params end)) + (ref-end params)) (cond [(hash-has-key? @image 'palette) ;; embed the color palette in the PDF as an object stream (define palette-ref (make-ref)) - (send* palette-ref [write (hash-ref @image 'palette)] [end]) + (ref-write palette-ref (hash-ref @image 'palette)) + (ref-end palette-ref) ;; build the color space array for the image (dict-set! @obj 'Colorspace (list 'Indexed 'DeviceRGB (sub1 (/ (bytes-length (hash-ref @image 'palette)) 3)) palette-ref))] @@ -85,11 +86,13 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee 'Filter 'FlateDecode 'ColorSpace 'DeviceGray 'Decode '(0 1)))) - (send* sMask-ref [write @alpha-channel] [end]) + (ref-write sMask-ref @alpha-channel) + (ref-end sMask-ref) (dict-set! @obj 'SMask sMask-ref)) ;; embed the actual image data - (send* @obj [write @img-data] [end])) + (ref-write @obj @img-data) + (ref-end @obj)) (define/public (split-alpha-channel) diff --git a/pitfall/pitfall/reference.rkt b/pitfall/pitfall/reference.rkt index 4a251796..e85c4f07 100644 --- a/pitfall/pitfall/reference.rkt +++ b/pitfall/pitfall/reference.rkt @@ -1,25 +1,9 @@ #lang debug racket/base -(require racket/class - racket/match - racket/port - racket/dict - racket/private/generic-methods - "core.rkt" +(require "core.rkt" "object.rkt" "zlib.rkt") (provide (all-defined-out)) -(define dictable<%> - (interface* () - ([(generic-property gen:dict) - (generic-method-table gen:dict - (define (dict-ref refobj key [thunk (λ () (error 'dict-ref-key-not-found))]) - (send refobj get-key key)) - (define (dict-ref! refobj key thunk) - (send refobj get-key! key thunk)) - (define (dict-set! refobj key val) (send refobj set-key! key val)) - (define (dict-update! refobj key updater [failure-result (λ () (error 'update-no-key))]) (send refobj update-key! key updater failure-result)))]))) - (define ref-listeners null) (define (register-ref-listener proc) (set! ref-listeners (cons proc ref-listeners))) @@ -29,57 +13,34 @@ (set! current-id val)) (define (make-ref [payload (make-hasheq)]) - (define new-ref (make-object PDFReference current-id payload)) + (define new-ref ($ref current-id payload #f (open-output-bytes))) (for-each (λ (listener-proc) (listener-proc new-ref)) ref-listeners) (begin0 new-ref (set! current-id (add1 current-id)))) -(define PDFReference - (class* object% (dictable<%>) - (super-new) - (init-field [(@id id)] - [(@payload payload) (make-hasheq)]) - (field [(@offset offset) #f] - [@port (open-output-bytes)]) - - (define/public (write x) - (write-bytes (to-bytes x) @port)) - - (define/public (get-key key) - (hash-ref @payload key)) - - (define/public (get-key! key val) - (hash-ref! @payload key val)) +(define (ref-write ref chunk) + (write-bytes (to-bytes chunk) ($ref-port ref))) - (define/public (set-key! key val) - (hash-set! @payload key val)) - - (define/public (update-key! key updater [failure-result (λ () (error 'update-no-key))]) - (hash-update! @payload key updater failure-result)) - - (define/public (end) - (set! @offset (file-position (current-output-port))) +(define (ref-end ref) + (set-$ref-offset! ref (file-position (current-output-port))) - (write-bytes-out (format "~a 0 obj" @id)) + (write-bytes-out (format "~a 0 obj" ($ref-id ref))) - (define bstr - (let ([bstr (get-output-bytes @port)]) - (cond - [(zero? (bytes-length bstr)) #false] - [(and (current-compress-streams?) (not (hash-ref @payload 'Filter #f))) - (hash-set! @payload 'Filter 'FlateDecode) - (deflate bstr)] - [else bstr]))) + (define bstr + (let ([bstr (get-output-bytes ($ref-port ref))]) + (cond + [(zero? (bytes-length bstr)) #false] + [(and (current-compress-streams?) (not (hash-ref ($ref-payload ref) 'Filter #f))) + (hash-set! ($ref-payload ref) 'Filter 'FlateDecode) + (deflate bstr)] + [else bstr]))) - (when bstr - (hash-set! @payload 'Length (bytes-length bstr))) - (write-bytes-out (convert @payload)) + (when bstr + (hash-set! ($ref-payload ref) 'Length (bytes-length bstr))) + (write-bytes-out (convert ($ref-payload ref))) - (when bstr - (write-bytes-out (bytes-append #"stream\n" bstr #"\nendstream"))) + (when bstr + (write-bytes-out (bytes-append #"stream\n" bstr #"\nendstream"))) - (write-bytes-out "\nendobj")) - - (define/public (to-string) - (format "~a 0 R" @id)))) + (write-bytes-out "\nendobj")) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index 2bb7cd67..b55e9338 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/pitfall/pitfall/standard-font.rkt @@ -6,6 +6,8 @@ sugar/unstable/dict "afm-font.rkt" "font.rkt" + "core.rkt" + "reference.rkt" fontland racket/runtime-path) (provide isStandardFont standard-fonts StandardFont) @@ -28,12 +30,12 @@ [@dictionary dictionary]) (define/override (embed) - (set-field! payload @dictionary + (set-$ref-payload! @dictionary (mhash 'Type 'Font 'BaseFont (string->symbol name) 'Subtype 'Type1 'Encoding 'WinAnsiEncoding)) - (send @dictionary end)) + (ref-end @dictionary)) (define/override (encode text [options #f]) (define encoded (send font encode-text text))