From 46ca51245b62accea48bcad97e15d19fb5f913b2 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 22 Dec 2018 22:46:50 -0800 Subject: [PATCH] listen --- pitfall/pitfall/annotations.rkt | 5 +++-- pitfall/pitfall/color.rkt | 3 ++- pitfall/pitfall/core.rkt | 2 ++ pitfall/pitfall/document.rkt | 15 ++++++--------- pitfall/pitfall/embedded.rkt | 9 +++++---- pitfall/pitfall/font.rkt | 4 ++-- pitfall/pitfall/jpeg-structy.rkt | 2 +- pitfall/pitfall/jpeg.rkt | 3 ++- pitfall/pitfall/page.rkt | 7 ++++--- pitfall/pitfall/png.rkt | 7 ++++--- pitfall/pitfall/reference.rkt | 13 ++++++++++++- 11 files changed, 43 insertions(+), 27 deletions(-) diff --git a/pitfall/pitfall/annotations.rkt b/pitfall/pitfall/annotations.rkt index 71e6c0d5..45d7f167 100644 --- a/pitfall/pitfall/annotations.rkt +++ b/pitfall/pitfall/annotations.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "core.rkt" + "reference.rkt" racket/class racket/match racket/contract @@ -36,7 +37,7 @@ (for ([(k v) (in-hash options)]) (hash-set! options (string->symbol (string-titlecase (symbol->string k))) v)) - (define annots-ref (send this make-ref options)) + (define annots-ref (make-ref options)) (send (· this page) annotations annots-ref) (· annots-ref end) this) @@ -46,7 +47,7 @@ ((number? number? number? number? string?) (hash?) . ->*m . object?) (hash-set*! options 'Subtype "Link" - 'A (send this make-ref (mhash 'S "URI" + 'A (make-ref (mhash 'S "URI" 'URI (String url)))) (send (· options A) end) (send this annotate x y w h options)) diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index aa7d499f..fc25b4b2 100644 --- a/pitfall/pitfall/color.rkt +++ b/pitfall/pitfall/color.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "core.rkt" + "reference.rkt" racket/class racket/match racket/string) @@ -104,7 +105,7 @@ (hash-set! dictionary 'ca fill-opacity)) (when stroke-opacity (hash-set! dictionary 'CA stroke-opacity)) - (define ref-dict (send this make-ref dictionary)) + (define ref-dict (make-ref dictionary)) (send ref-dict end) (set! @opacity-count (add1 @opacity-count)) (list ref-dict (format "Gs~a" @opacity-count))))) diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index 6860abab..64aeeefb 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -26,6 +26,8 @@ (define current-font (make-parameter #f)) (define current-font-size (make-parameter 12)) +(define current-ref-listeners (make-parameter null)) + ;; helpers (define (numberizer x #:round [round? #true]) diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index 184fd27f..2f54518f 100644 --- a/pitfall/pitfall/document.rkt +++ b/pitfall/pitfall/document.rkt @@ -3,7 +3,6 @@ "core.rkt" racket/class racket/format - racket/generator racket/match racket/dict racket/list @@ -21,13 +20,13 @@ (define PDFDocument (class (annotation-mixin (image-mixin (text-mixin (fonts-mixin (vector-mixin (color-mixin object%)))))) + (set-current-id! 1) + (current-ref-listeners (cons (λ (ref) (send this log-ref ref)) (current-ref-listeners))) + (super-new) (init-field [(@options options) (mhasheq)]) (field [@pages null] [@refs null] - [@ref-gen (generator () (let loop ([refid 1]) - (yield refid) - (loop (add1 refid))))] [@root (make-ref (mhasheq 'Type "Catalog" 'Pages (make-ref (mhasheq 'Type "Pages"))))] [(@x x) 0] @@ -53,12 +52,10 @@ (for ([(key val) (in-hash (hash-ref @options 'info (hasheq)))]) (hash-set! @info key val)) - (define/public (page) (first @pages)) + (define/public (log-ref ref) + (set! @refs (cons ref @refs))) - (define/public (make-ref [payload (mhasheq)]) - (define new-ref (make-object PDFReference (@ref-gen) payload)) - (set! @refs (cons new-ref @refs)) - new-ref) + (define/public (page) (first @pages)) (define/public (add-page [options-arg @options]) ;; create a page object diff --git a/pitfall/pitfall/embedded.rkt b/pitfall/pitfall/embedded.rkt index ddc2055d..eb50c2df 100644 --- a/pitfall/pitfall/embedded.rkt +++ b/pitfall/pitfall/embedded.rkt @@ -2,6 +2,7 @@ (require (for-syntax racket/base) "core.rkt" + "reference.rkt" racket/class racket/match racket/string @@ -88,7 +89,7 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (define/override (embed) ;; no CFF support (define isCFF #false) #;(is-a? subset CFFSubset) - (define font-file (send @document make-ref)) + (define font-file (make-ref)) (when isCFF (dict-set! font-file 'Subtype "CIDFontType0C")) @@ -115,7 +116,7 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (integer->char (random 65 (+ 65 26)))))) (define name (string-append tag "+" (font-postscript-name font))) (define bbox (font-bbox font)) - (define descriptor (send @document make-ref + (define descriptor (make-ref (mhash 'Type "FontDescriptor" 'FontName name @@ -132,7 +133,7 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (dict-set! descriptor (if isCFF 'FontFile3 'FontFile2) font-file) (send descriptor end) - (define descendant-font (send @document make-ref + (define descendant-font (make-ref (mhash 'Type "Font" 'Subtype (string-append "CIDFontType" (if isCFF "0" "2")) @@ -159,7 +160,7 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/font/embedded.coffee (define/public (toUnicodeCmap) - (define cmap (send @document make-ref)) + (define cmap (make-ref)) (define entries (for/list ([idx (in-range (length (hash-keys unicode)))]) (define codepoints (hash-ref unicode idx)) diff --git a/pitfall/pitfall/font.rkt b/pitfall/pitfall/font.rkt index 6531be7f..62ed186f 100644 --- a/pitfall/pitfall/font.rkt +++ b/pitfall/pitfall/font.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require racket/class) +(require racket/class "reference.rkt") (provide PDFFont) (define PDFFont @@ -17,7 +17,7 @@ (define/public (ref) (unless @dictionary - (set! @dictionary (send @document make-ref))) + (set! @dictionary (make-ref))) @dictionary) (define/public (finalize) diff --git a/pitfall/pitfall/jpeg-structy.rkt b/pitfall/pitfall/jpeg-structy.rkt index cabd5b93..7584577f 100644 --- a/pitfall/pitfall/jpeg-structy.rkt +++ b/pitfall/pitfall/jpeg-structy.rkt @@ -48,7 +48,7 @@ (unless (· this obj) (set-field! obj this - (send doc-in make-ref + (make-ref (mhash 'Type "XObject" 'Subtype "Image" diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt index c7ffe86f..c61a2eb3 100644 --- a/pitfall/pitfall/jpeg.rkt +++ b/pitfall/pitfall/jpeg.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require racket/class + "reference.rkt" racket/contract racket/dict sugar/unstable/class @@ -55,7 +56,7 @@ (unless (· this obj) (set-field! obj this - (send doc-in make-ref + (make-ref (mhash 'Type "XObject" 'Subtype "Image" diff --git a/pitfall/pitfall/page.rkt b/pitfall/pitfall/page.rkt index 1da9c30b..0faeda37 100644 --- a/pitfall/pitfall/page.rkt +++ b/pitfall/pitfall/page.rkt @@ -2,6 +2,7 @@ (require racket/class racket/dict + "reference.rkt" sugar/unstable/dict "core.rkt") @@ -18,8 +19,8 @@ (hash-ref page-sizes (string-upcase @size)))] [(@width width) (list-ref @dimensions (if (equal? @layout "portrait") 0 1))] [(@height height) (list-ref @dimensions (if (equal? @layout "portrait") 1 0))] - [@content (send @doc make-ref)] - [(@resources resources) (send @doc make-ref (mhash 'ProcSet '("PDF" "Text" "ImageB" "ImageC" "ImageI")))] + [@content (make-ref)] + [(@resources resources) (make-ref (mhash 'ProcSet '("PDF" "Text" "ImageB" "ImageC" "ImageI")))] [(@margins margins) (let ([margin-value (hash-ref @options 'margin #f)]) (if (number? margin-value) @@ -27,7 +28,7 @@ (hash-ref @options 'margins (current-default-margins))))] ;; The page dictionary [(@dictionary dictionary) - (send @doc make-ref + (make-ref (mhash 'Type "Page" 'Parent @page-parent 'MediaBox (list 0 0 @width @height) diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 0f0b7102..a64de528 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -1,6 +1,7 @@ #lang debug racket/base (require racket/class + "reference.rkt" racket/contract racket/dict racket/draw @@ -34,7 +35,7 @@ (unless (· this obj) (set-field! obj this - (send (· this document) make-ref + (make-ref (mhash 'Type "XObject" 'Subtype "Image" 'BitsPerComponent (· this image bits) @@ -43,7 +44,7 @@ 'Filter "FlateDecode"))) (unless (· this image hasAlphaChannel) - (define params (send (· this document) make-ref + (define params (make-ref (mhash 'Predictor 15 'Colors (· this image colors) 'BitsPerComponent (· this image bits) @@ -82,7 +83,7 @@ (when (· this alphaChannel) (define sMask - (send (· this document) make-ref + (make-ref (mhash 'Type "XObject" 'Subtype "Image" 'Height (· this height) diff --git a/pitfall/pitfall/reference.rkt b/pitfall/pitfall/reference.rkt index 45166b5b..ec56ec25 100644 --- a/pitfall/pitfall/reference.rkt +++ b/pitfall/pitfall/reference.rkt @@ -7,7 +7,7 @@ "core.rkt" "object.rkt" "zlib.rkt") -(provide PDFReference) +(provide PDFReference set-current-id! make-ref) (define dictable<%> (interface* () @@ -20,6 +20,15 @@ (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 current-id 0) +(define (set-current-id! val) + (set! current-id val)) + +(define (make-ref [payload (make-hasheq)]) + (begin0 + (make-object PDFReference current-id payload) + (set! current-id (add1 current-id)))) + (define PDFReference (class* object% (dictable<%>) (super-new) @@ -28,6 +37,8 @@ (field [(@offset offset) #f] [@port (open-output-bytes)]) + (for-each (λ (proc) (proc this)) (current-ref-listeners)) + (define/public (write x) (write-bytes (to-bytes x) @port))