better output-path handling

main
Matthew Butterick 6 years ago
parent d649e9986f
commit 85dee608ce

@ -5,23 +5,24 @@
;; structs
(struct pdf (options
pages
refs
root
info
opacity-registry
current-fill-color
ctm
ctm-stack
font-families
current-font-features
current-font-size
current-font
registered-fonts
line-gap
x
y
image-registry) #:transparent #:mutable)
pages
refs
root
info
opacity-registry
current-fill-color
ctm
ctm-stack
font-families
current-font-features
current-font-size
current-font
registered-fonts
line-gap
x
y
image-registry
output-path) #:transparent #:mutable)
;; for JPEG and PNG
@ -43,6 +44,7 @@
;; params
(define test-mode (make-parameter #f))
(define current-compress-streams (make-parameter #f))

@ -2,6 +2,7 @@
(require
"core.rkt"
racket/class
racket/match
racket/format
racket/dict
sugar/unstable/dict
@ -17,6 +18,7 @@
(set-pdf-refs! doc (cons ref (pdf-refs doc))))
(define (make-pdf [options (make-hasheq)]
#:output-path [output-path #f]
#:compress [compress? (current-compress-streams)]
#:auto-first-page [auto-first-page? (current-auto-first-page)])
@ -27,7 +29,7 @@
'Creator "PITFALL"
'CreationDate (current-seconds)))
(for ([(key val) (in-hash (hash-ref options 'info (hasheq)))])
(hash-set! info key val))
(hash-set! info key val))
(define opacity-registry (make-hash))
(define current-fill-color #false)
(define ctm default-ctm-value)
@ -42,35 +44,35 @@
(define y 0)
(define image-registry (make-hash))
(define new-doc (pdf options
pages
refs
'dummy-root-value-that-will-be-replaced-below
info
opacity-registry
current-fill-color
ctm
ctm-stack
font-families
current-font-features
current-font-size
current-font
registered-fonts
line-gap
x
y
image-registry))
pages
refs
'dummy-root-value-that-will-be-replaced-below
info
opacity-registry
current-fill-color
ctm
ctm-stack
font-families
current-font-features
current-font-size
current-font
registered-fonts
line-gap
x
y
image-registry
output-path))
(set-current-ref-id! 1)
(reset-annotations-cache!)
(register-ref-listener (λ (ref) (store-ref new-doc ref)))
(set-pdf-root! new-doc (make-ref (mhasheq 'Type 'Catalog
'Pages (make-ref (mhasheq 'Type 'Pages)))))
'Pages (make-ref (mhasheq 'Type 'Pages)))))
;; initialize params
(current-compress-streams compress?)
(current-auto-first-page auto-first-page?)
(when (current-auto-first-page) (add-page new-doc))
(when (current-auto-helvetica) (font new-doc "Helvetica"))
new-doc)
(define (add-page doc [options-arg (pdf-options doc)])
@ -87,7 +89,15 @@
(transform doc 1 0 0 -1 0 ($page-height (current-page doc)))
doc)
(define last-output-port #f)
(define (start-doc doc)
(define output-port (match (pdf-output-path doc)
[(? path-string? ps) (open-output-file ps #:exists 'replace)]
[(? output-port? op) op]
[#false (current-output-port)]))
(set! last-output-port (current-output-port))
(current-output-port output-port)
(write-bytes-out (format "%PDF-~a" (current-pdf-version)))
(write-bytes-out "%ÿÿÿÿ"))
@ -98,7 +108,7 @@
(ref-end doc-info)
(for ([font (in-hash-values (pdf-font-families doc))])
(send font font-end))
(send font font-end))
(define pages-ref (dict-ref (pdf-root doc) 'Pages))
(dict-set! pages-ref 'Count (length (pdf-pages doc)))
@ -113,15 +123,17 @@
(write-bytes-out (format "0 ~a" xref-count))
(write-bytes-out "0000000000 65535 f ")
(for ([ref (in-list (reverse (pdf-refs doc)))])
(write-bytes-out
(string-append (~r ($ref-offset ref) #:min-width 10 #:pad-string "0") " 00000 n ")))
(write-bytes-out
(string-append (~r ($ref-offset ref) #:min-width 10 #:pad-string "0") " 00000 n ")))
(write-bytes-out "trailer")
(write-bytes-out (convert (mhasheq 'Size xref-count
'Root (pdf-root doc)
'Info doc-info)))
(write-bytes-out "startxref")
(write-bytes-out (numberizer xref-offset))
(write-bytes-out "%%EOF"))
(write-bytes-out "%%EOF")
(close-output-port (current-output-port))
(current-output-port last-output-port))
(module+ test
(define d (make-pdf)))

@ -27,7 +27,7 @@
(define-macro (check-copy-equal? THIS)
(syntax/loc caller-stx (check-true (for/and ([b1 (in-input-port-bytes (open-input-file THIS))]
[b2 (in-input-port-bytes (open-input-file (this->control THIS)))])
(equal? b1 b2)))))
(equal? b1 b2)))))
(define-syntax-rule (check-pdfkit? this)
@ -35,13 +35,10 @@
(define (make-doc ps [compress? #false] [proc (λ (doc) doc)] #:test [test? #t] #:pdfkit [pdfkit? #t])
(time
(with-output-to-file ps
(λ ()
(define doc (make-pdf #:compress compress?))
(start-doc doc)
(proc doc)
(end-doc doc))
#:exists 'replace))
(define doc (make-pdf #:compress compress? #:output-path ps))
(start-doc doc)
(proc doc)
(end-doc doc))
(when test?
(check-headers-equal? ps (this->control ps))
(check-pdfs-equal? ps (this->control ps))

Loading…
Cancel
Save