diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index b796effc..0af92043 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -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)) diff --git a/pitfall/pitfall/pdf.rkt b/pitfall/pitfall/pdf.rkt index b39905ab..5131dda3 100644 --- a/pitfall/pitfall/pdf.rkt +++ b/pitfall/pitfall/pdf.rkt @@ -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))) \ No newline at end of file diff --git a/pitfall/pitfall/pdftest.rkt b/pitfall/pitfall/pdftest.rkt index db8c19ec..1b11e690 100644 --- a/pitfall/pitfall/pdftest.rkt +++ b/pitfall/pitfall/pdftest.rkt @@ -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))