mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

structify ref

Browse Source
main
Matthew Butterick 6 years ago
parent 00e0470114
commit 17b4c97897
12 changed files with 101 additions and 125 deletions
Show Stats Download Patch File Download Diff File

4
pitfall/pitfall/annotations.rkt
Unescape Escape View File

@ -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)

2
pitfall/pitfall/color.rkt
Unescape Escape View File

@ -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)

13
pitfall/pitfall/core.rkt
Unescape Escape View File

@ -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)

14
pitfall/pitfall/document.rkt
Unescape Escape View File

@ -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

77
pitfall/pitfall/embedded.rkt
Unescape Escape View File

@ -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

4
pitfall/pitfall/jpeg.rkt
Unescape Escape View File

@ -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)

1
pitfall/pitfall/object.rkt
Unescape Escape View File

@ -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) " "))]

5
pitfall/pitfall/page-test.rkt
Unescape Escape View File

@ -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))
(check-true ($ref? (· p dictionary Contents)))
(check-true ($ref? (· p dictionary Resources)))

8
pitfall/pitfall/page.rkt
Unescape Escape View File

@ -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

11
pitfall/pitfall/png.rkt
Unescape Escape View File

@ -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)

81
pitfall/pitfall/reference.rkt
Unescape Escape View File

@ -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"))

6
pitfall/pitfall/standard-font.rkt
Unescape Escape View File

@ -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))

Write Preview
Loading…
Cancel
Save