You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
139 lines
4.7 KiB
Racket
139 lines
4.7 KiB
Racket
#lang debug racket/base
|
|
(require
|
|
"core.rkt"
|
|
racket/class
|
|
racket/match
|
|
racket/format
|
|
racket/dict
|
|
sugar/unstable/dict
|
|
"annotation.rkt"
|
|
"reference.rkt"
|
|
"object.rkt"
|
|
"page.rkt"
|
|
"vector.rkt"
|
|
"font.rkt")
|
|
(provide (all-defined-out))
|
|
|
|
(define (store-ref doc ref)
|
|
(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)])
|
|
|
|
;; initial values
|
|
(define pages null)
|
|
(define refs null)
|
|
(define info (mhasheq 'Producer "PITFALL"
|
|
'Creator "PITFALL"
|
|
'CreationDate (current-seconds)))
|
|
(for ([(key val) (in-hash (hash-ref options 'info (hasheq)))])
|
|
(hash-set! info key val))
|
|
(define opacity-registry (make-hash))
|
|
(define current-fill-color #false)
|
|
(define ctm default-ctm-value)
|
|
(define ctm-stack null)
|
|
(define font-families (make-hash))
|
|
(define current-font-features null)
|
|
(define current-font-size 12)
|
|
(define current-font #false)
|
|
(define registered-fonts (make-hash))
|
|
(define line-gap 0)
|
|
(define x 0)
|
|
(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
|
|
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)))))
|
|
|
|
;; 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)])
|
|
;; create a page object
|
|
(define page-parent (dict-ref (pdf-root doc) 'Pages))
|
|
(set-pdf-pages! doc (cons (make-page page-parent options-arg) (pdf-pages doc)))
|
|
|
|
;; reset x and y coordinates
|
|
(set-pdf-x! doc (margin-left ($page-margins (current-page doc))))
|
|
(set-pdf-y! doc (margin-right ($page-margins (current-page doc))))
|
|
;; flip PDF coordinate system so that the origin is in
|
|
;; the top left rather than the bottom left
|
|
(set-pdf-ctm! doc default-ctm-value)
|
|
(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 "%ÿÿÿÿ"))
|
|
|
|
(define (end-doc doc)
|
|
(for-each page-end (pdf-pages doc))
|
|
|
|
(define doc-info (make-ref (pdf-info doc)))
|
|
(ref-end doc-info)
|
|
|
|
(for ([font (in-hash-values (pdf-font-families doc))])
|
|
(send font font-end))
|
|
|
|
(define pages-ref (dict-ref (pdf-root doc) 'Pages))
|
|
(dict-set! pages-ref 'Count (length (pdf-pages doc)))
|
|
(dict-set! pages-ref 'Kids (map $page-ref (reverse (pdf-pages doc))))
|
|
(ref-end pages-ref)
|
|
|
|
(ref-end (pdf-root doc))
|
|
|
|
(define xref-offset (file-position (current-output-port)))
|
|
(write-bytes-out "xref")
|
|
(define xref-count (add1 (length (pdf-refs doc))))
|
|
(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 "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")
|
|
(close-output-port (current-output-port))
|
|
(current-output-port last-output-port))
|
|
|
|
(module+ test
|
|
(define d (make-pdf))) |