pdf.lisp

Revision 4148, 25.0 kB (checked in by hans, 2 weeks ago)
Fix some small bugs.

Line
1	;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
2	;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
3	;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html
4
5	(in-package #:pdf)
6
7	(defparameter version 2.03)
8
9	(defparameter +pdf-header+ "%PDF-1.4")
10
11	(defvar document)
12	(defvar outlines-stack)
13	(defvar root-page)
14	(defvar page)
15	(defvar page-number)
16	(defvar page-stream)
17	(defvar pdf-stream)
18	(defvar xrefs)
19	(defvar name-counter 100)
20
21	(defun gen-name (prefix)
22	(format nil "~a~d" prefix (incf name-counter)))
23
24	(defgeneric make-dictionary (thing &key &allow-other-keys))
25
26	(defclass dictionary ()
27	((dict-values :accessor dict-values :initform nil :initarg :dict-values)))
28
29	(defun add-dict-value (dict name value)
30	(push (cons name value)(dict-values dict)))
31
32	(defun get-dict-value (dict name)
33	(cdr (assoc name (dict-values dict) :test #'string=)))
34
35	(defun change-dict-value (dict name value)
36	(let ((key-val (assoc name (dict-values dict) :test #'string=)))
37	(if key-val
38	(setf (cdr key-val) value)
39	(add-dict-value dict name value))))
40
41	(defclass pdf-stream (dictionary)
42	((content :accessor content :initform "" :initarg :content)
43	(no-compression :accessor no-compression :initarg :no-compression :initform nil)))
44
45	(defmethod initialize-instance :after ((obj pdf-stream) &key empty &allow-other-keys)
46	(unless empty
47	(add-dict-value obj "/Length"
48	#'(lambda ()
49	(let ((content (content obj)))
50	(if (consp content)
51	(reduce #'+ content :key #'length)
52	(length content)))))))
53
54	(defun compress-pdf-stream (pdf-stream)
55	(when (and compress-streams (not (no-compression pdf-stream))
56	(> (length (content pdf-stream)) min-size-for-compression))
57	(setf (content pdf-stream) (compress-string (content pdf-stream)))
58	(let ((filter (get-dict-value pdf-stream "/Filter")))
59	(if filter
60	(change-dict-value pdf-stream "/Filter" (vector "/FlateDecode" filter))
61	(add-dict-value pdf-stream "/Filter" "/FlateDecode")))
62	(setf (no-compression pdf-stream) t)))
63
64	(defclass document ()
65	((objects :accessor objects :initform nil)
66	(root-page :accessor root-page :initform nil)
67	(catalog :accessor catalog :initform nil)
68	(outline-root :accessor outline-root :initform nil)
69	(named-refs :accessor named-refs :initform (make-hash-table :test #'equal))
70	(fonts :accessor fonts :initform '())
71	(gstates :accessor gstates :initform '())
72	(encodings :accessor encodings :initform '())
73	(last-object-number :accessor last-object-number :initform 0)
74	(docinfo :accessor docinfo :initform nil)
75	(author :accessor author :initarg :author :initform nil)
76	(title :accessor title :initarg :title :initform nil)
77	(keywords :accessor keywords :initarg :keywords :initform nil)
78	(subject :accessor subject :initarg :subject :initform nil)))
79
80	(defmethod initialize-instance :after ((doc document)
81	&key empty mode layout
82	(creator "") author title subject keywords
83	&allow-other-keys)
84	;;; Args: empty If true, do not set any slots
85	;; mode PageMode in catalog
86	;; layout PageLayout in catalog
87	(unless empty
88	(let ((document doc))
89	(setf (objects doc) (make-array 10 :fill-pointer 0 :adjustable t)
90	(catalog doc) (make-instance 'indirect-object)
91	(root-page doc) (make-instance 'page-node)
92	(outline-root doc) (make-instance 'outline)
93	(content (catalog doc))
94	(make-instance 'dictionary :dict-values
95	`(("/Type" . "/Catalog")
96	("/Pages" . ,(root-page doc))
97	,@(when layout `(("/PageLayout" . ,(case mode
98	(:page "/SinglePage")
99	(:column "/OneColumn")
100	(:left "/TwoColumnLeft")
101	(:right "/TwoColumnRight")
102	(otherwise (pdf-name layout))))))
103	,@(when mode `(("/PageMode" . ,(case mode
104	(:none "/UseNone")
105	(:outlines "/UseOutlines")
106	(:thumbs "/UseThumbs")
107	(:full "/FullScreen")
108	(otherwise (pdf-name mode)))))) )))
109	(add-doc-info doc :creator creator :author author
110	:title title :subject subject :keywords keywords) )))
111
112	(defun add-doc-info (doc &key (creator "") author title subject keywords)
113	(setf (docinfo doc) (make-instance 'indirect-object))
114	(setf (content (docinfo doc))
115	(make-instance 'dictionary
116	:dict-values `(("/Creator" . ,(format nil "(cl-pdf ~A - ~A)" version creator))
117	,@(when author `(("/Author" . ,(format nil "(~A)" author))))
118	,@(when title `(("/Title" . ,(format nil "(~A)" title))))
119	,@(when subject `(("/Subject" . ,(format nil "(~A)" subject))))
120	,@(when keywords `(("/Keywords" . ,(format nil "(~A)" keywords))))
121	("/CreationDate" .
122	,(multiple-value-bind (second minute hour date month year)
123	(get-decoded-time)
124	(format nil "(D:~D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D)"
125	year month date hour minute second)))))))
126
127	(defclass indirect-object ()
128	((obj-number :accessor obj-number :initform (incf (last-object-number document)) :initarg :obj-number)
129	(gen-number :accessor gen-number :initform 0 :initarg :gen-number)
130	(content :accessor content :initform nil :initarg :content)))
131
132	(defmethod initialize-instance :after ((obj indirect-object)
133	&key no-link &allow-other-keys)
134	(unless no-link
135	(vector-push-extend obj (objects document))))
136
137	(defclass object-ref ()
138	((obj-number :accessor obj-number :initform 0 :initarg :obj-number)
139	(gen-number :accessor gen-number :initform 0 :initarg :gen-number)))
140
141	(defclass page-node (indirect-object)
142	((pages :accessor pages :initform (make-array 1 :fill-pointer 0 :adjustable t))))
143
144	(defmethod initialize-instance :after ((obj page-node) &key no-link &allow-other-keys)
145	(when (and root-page (not no-link))
146	(vector-push-extend obj (pages root-page)))
147	(setf (content obj) (make-instance 'dictionary
148	:dict-values `(("/Type" . "/Pages")
149	("/Count" . ,#'(lambda ()(length (pages obj))))
150	,@(when root-page `(("/Parent" . ,root-page)))
151	("/Kids" . ,(pages obj))))))
152
153	(defclass page (indirect-object)
154	((bounds :accessor bounds :initform default-page-bounds :initarg :bounds)
155	(resources :accessor resources :initform (make-instance 'dictionary))
156	(fonts :accessor fonts :initform '())
157	(font-objects :accessor font-objects :initform (make-instance 'dictionary))
158	(gstates :accessor gstates :initform '())
159	(gstate-objects :accessor gstate-objects :initform (make-instance 'dictionary))
160	(xobjects :accessor xobjects :initform (make-instance 'dictionary))
161	(annotations :accessor annotations :initform (make-array 0 :fill-pointer 0 :adjustable t))
162	(content-stream :accessor content-stream)
163	))
164
165	(defmethod initialize-instance :after ((page page)
166	&key no-link (rotate 0) &allow-other-keys)
167	(when (and root-page (not no-link))
168	(incf page-number)
169	(when (> page-number max-number-of-pages)
170	(throw 'max-number-of-pages-reached nil))
171	(vector-push-extend page (pages root-page)))
172	(setf (content-stream page) (make-instance 'pdf-stream))
173	(add-dict-value (resources page) "/Font" (font-objects page))
174	(add-dict-value (resources page) "/ExtGState" (gstate-objects page))
175	(add-dict-value (resources page) "/ProcSet" "[ /PDF /Text ]")
176	(add-dict-value (resources page) "/XObject" (xobjects page))
177	(let ((content (make-instance 'indirect-object :content (content-stream page))))
178	(setf (content page)
179	(make-instance 'dictionary
180	:dict-values `(("/Type" . "/Page")
181	("/Parent" ,root-page)
182	("/MediaBox" . ,#'(lambda ()(bounds page)))
183	("/Resources" . ,(resources page))
184	("/Annots" ,(annotations page))
185	("/Rotate" . ,rotate)
186	("/Contents" . ,content))))))
187
188	(defclass named-reference ()
189	((name :accessor name :initarg :name)
190	(reference :accessor reference :initform nil)))
191
192	(defun get-named-reference (name)
193	(let ((ref (gethash name (named-refs document))))
194	(unless ref
195	(setf ref (make-instance 'named-reference :name name))
196	(setf (gethash name (named-refs document)) ref))
197	ref))
198
199	(defun register-named-reference (reference &optional (name (gen-name "R")))
200	(setf (reference (get-named-reference name)) reference)
201	name)
202
203	(defun register-page-reference (&optional (name (gen-name "R")))
204	(register-named-reference (vector page "/Fit") name)
205	name)
206
207	(defclass outline (indirect-object)
208	((title :accessor title :initarg :title :initform nil)
209	(reference :accessor reference :initform nil :initarg :reference)
210	(sub-levels :accessor sub-levels :initform nil)
211	(prev-outline :accessor prev-outline :initform nil)
212	(next-outline :accessor next-outline :initform nil)))
213
214	(defun enter-outline-level (title ref-name)
215	(let ((outline (make-instance 'outline :title title :reference (get-named-reference ref-name)))
216	(parent (first outlines-stack)))
217	(setf (sub-levels parent)(nconc (sub-levels parent)(list outline)))
218	(push outline outlines-stack)))
219
220	(defun close-outline-level ()
221	(pop outlines-stack))
222
223	(defmacro string-append (&rest args)
224	#+lispworks `(lw:string-append ,@args)
225	#-lispworks `(concatenate 'string ,@args))
226
227	(defun pdf-string (obj &key (unicode :default))
228	;;; Used to embrace a pdf string used in places other than content streams,
229	;; e.g. titles, annotations etc.
230	;; Args: unicode If true or defaults to true, the PDF text string is encoded in Unicode
231	;; lang ?
232	;; Q: Rename or create separate pdf-text-string?
233	(let ((string (if (stringp obj) obj (princ-to-string obj))))
234	(when (eq unicode :default)
235	(setq unicode (notevery #+lispworks #'lw:base-char-p
236	#-lispworks (lambda (char) (<= (char-code char) 255))
237	string)))
238	(with-output-to-string (stream nil :element-type 'base-char)
239	(write-char #\( stream)
240	(when unicode ; write the Unicode byte order marker U+FEFF
241	(write-char #.(code-char 254) stream) (write-char #.(code-char 255) stream))
242	(loop for char across string
243	for code = (char-code char)
244	if unicode
245	do (write-char (code-char (ldb (byte 8 8) code)) stream) ; hi
246	(write-char (code-char (ldb (byte 8 0) code)) stream) ; lo
247	else if (> code 255)
248	do (write-char (code-char (ldb (byte 8 0) code)) stream) ; lo
249	else do (case char ((#\( #\) #\\)
250	(write-char #\\ stream)))
251	(write-char char stream))
252	(write-char #\) stream))))
253
254	(defmacro with-outline-level ((title ref-name) &body body)
255	`(unwind-protect
256	(progn (enter-outline-level ,title ,ref-name)
257	,@body)
258	(close-outline-level)))
259
260	(defun compute-outline-tree (outlines &optional (parent nil))
261	(loop for prev = nil then outline
262	for outline in outlines
263	do
264	(when prev (setf (next-outline prev) outline))
265	(setf (prev-outline outline) prev)
266	(compute-outline-tree (sub-levels outline) outline))
267	(loop for outline in outlines
268	for sub-levels = (sub-levels outline)
269	for first = (first sub-levels)
270	for last = (first (last sub-levels))
271	do
272	(with-slots ((reference reference)(prev-outline prev-outline)(next-outline next-outline)) outline
273	(setf (content outline)
274	(make-instance 'dictionary
275	:dict-values `(,@(if parent `(("/Title" . ,(pdf-string (title outline)))
276	("/Parent" . ,parent))
277	'(("/Type" "/Outlines")))
278	,@(when first `(("/First" . ,first)))
279	,@(when last `(("/Last" . ,last)))
280	,@(when prev-outline `(("/Prev" . ,prev-outline)))
281	,@(when next-outline `(("/Next" . ,next-outline)))
282	,@(when reference `(("/Dest" . ,reference)))
283	("/Count" . "0")))))))
284
285	(defun process-outlines (document)
286	(when (and (outline-root document) (sub-levels (outline-root document)))
287	(compute-outline-tree (list (outline-root document)))
288	(add-dict-value (content (catalog document)) "/Outlines" (outline-root document))))
289
290	(defun pdf-name (obj &optional (prefix #\/))
291	"Helper (akin to pdf-string) to escape non-alphanumeric characters in PDF names
292	by writing 2-digit hexadecimal code, preceded by the number sign character (#).
293	CAUTION: PDF names are case-sensitive!"
294	(let ((string (if (stringp obj)
295	(if (and prefix (char= (schar obj 0) prefix))
296	(return-from pdf-name obj) ; PDF-ready
297	obj)
298	(princ-to-string obj))))
299	(with-output-to-string (stream nil #-cmu :element-type #-cmu (array-element-type string))
300	(when prefix
301	(write-char prefix stream))
302	(dotimes (i (length string))
303	(let ((char (schar string i)))
304	(if (or (alphanumericp char)
305	(find char "-_." :test #'char=)) ; often used regular chars
306	(write-char char stream)
307	(format stream "#~2,'0x" (char-code char))))))))
308
309	(defmacro enforce-/ (&rest names)
310	"Verify and prefix each name by / unless it is PDF-ready."
311	`(setf ,@(loop for name in names
312	collect name
313	collect `(pdf-name ,name))))
314
315	(defun add-/ (name)
316	(concatenate 'string "/" name))
317
318	(defclass encoding-object (indirect-object)
319	((encoding :accessor encoding :initarg :encoding)))
320
321	(defmethod initialize-instance :after ((encoding-object encoding-object)
322	&key encoding &allow-other-keys)
323	(setf (content encoding-object) (make-dictionary encoding)))
324
325	(defun find-encoding-object (encoding)
326	(let ((encoding-object (cdr (assoc encoding (encodings document)))))
327	(unless encoding-object
328	(setf encoding-object (make-instance 'encoding-object :encoding encoding))
329	(push (cons encoding encoding-object) (encodings document)))
330	encoding-object))
331
332	(defclass font-object (indirect-object)
333	((name :accessor name :initform (gen-name "/CLF") :initarg :name)
334	(font :accessor font :initarg :font)))
335
336	(defmethod initialize-instance :after ((font-object font-object)
337	&key font (embed embed-fonts)
338	&allow-other-keys)
339	(setf (content font-object) (make-dictionary (font-metrics font)
340	:font font :embed embed)))
341
342	(defun find-font-object (font &key (embed :default))
343	(let ((font-object (cdr (assoc font (fonts document)))))
344	(unless font-object
345	(setf font-object (make-instance 'font-object :font font :embed embed))
346	(push (cons font font-object) (fonts document)))
347	font-object))
348
349	(defun add-font-to-page (font &key (embed :default))
350	(let ((font-object (cdr (assoc font (fonts page)))))
351	(unless font-object
352	(setf font-object (find-font-object font :embed embed))
353	(push (cons font font-object) (fonts page))
354	(add-dict-value (font-objects page) (name font-object) font-object))
355	font-object))
356
357	(defclass gstate-object (indirect-object)
358	((name :accessor name :initform (gen-name "/GS") :initarg :name)))
359
360	(defmethod initialize-instance :after ((gstate-object gstate-object) &key gstate &allow-other-keys)
361	(setf (content gstate-object) (make-instance 'dictionary :dict-values '(("/Type" . "/ExtGState"))))
362	(loop for (name value) on gstate by #'cddr
363	do (add-dict-value (content gstate-object) (format nil "/~a" name) value)))
364
365	(defun find-gstate-object (&rest gstate)
366	(let ((gstate-object (cdr (assoc gstate (gstates document) :test #'equal))))
367	(unless gstate-object
368	(setf gstate-object (make-instance 'gstate-object :gstate gstate))
369	(push (cons gstate gstate-object) (gstates document)))
370	gstate-object))
371
372	(defun add-gstate-to-page (&rest gstate)
373	(let ((gstate-object (cdr (assoc gstate (gstates page) :test #'equal))))
374	(unless gstate-object
375	(setf gstate-object (apply #'find-gstate-object gstate))
376	(push (cons gstate gstate-object) (gstates page))
377	(add-dict-value (gstate-objects page) (name gstate-object) gstate-object))
378	gstate-object))
379
380	(defclass image (indirect-object)
381	((name :accessor name :initform (gen-name "/CLI") :initarg :name)
382	(width :accessor width :initarg :width)
383	(height :accessor height :initarg :height)))
384
385	(defmethod initialize-instance :after ((image image) &key
386	bits width height (filter "ASCIIHexDecode") decode-parms
387	(color-space "DeviceRGB") (bits-per-color 8) mask decode
388	no-compression
389	&allow-other-keys)
390	;;; Args: color-space - can be an array!
391	(enforce-/ filter) ; color-space)
392	(when (stringp color-space)
393	(enforce-/ color-space))
394	(setf (content image)
395	(make-instance 'pdf-stream
396	:no-compression no-compression
397	:dict-values `(("/Type" . "/XObject")("/Subtype" . "/Image")
398	("/Width" . ,width)("/Height" . ,height)
399	("/Filter" . ,filter)
400	,@(when decode-parms `(("/DecodeParms" .
401	,(make-instance 'dictionary
402	:dict-values decode-parms))))
403	("/ColorSpace" . ,color-space)
404	("/BitsPerComponent" . ,bits-per-color)
405	,@(when decode `(("/Decode" . ,decode)))
406	,@(when mask `(("/Mask" . ,mask))) )))
407	(setf (content (content image)) bits))
408
409	(defun add-images-to-page (&rest images)
410	(dolist (image images)
411	(add-dict-value (xobjects page) (name image) image)))
412
413	(defclass annotation (indirect-object)
414	())
415
416	(defmethod initialize-instance :after ((annotation annotation) &key
417	rect type (border #(0 0 0))
418	&allow-other-keys)
419	(enforce-/ type)
420	(vector-push-extend annotation (annotations page))
421	(setf (content annotation)
422	(make-instance 'dictionary
423	:dict-values `(("/Type" . "/Annot")("/Subtype" . ,type)
424	("/Rect" . ,rect)("/Border" . ,border)))))
425
426	(defclass annotation2 (indirect-object)
427	())
428
429	(defmethod initialize-instance :after ((annotation annotation2) &key rect text
430	&allow-other-keys)
431	(vector-push-extend annotation (annotations page))
432	(setf (content annotation)
433	(make-instance 'dictionary
434	:dict-values `(("/Type" . "/Annot")("/Subtype" . "/Text")
435	("/Rect" . ,rect)("/Contents" . ,text)))))
436
437	(defmethod write-object ((obj null) &optional root-level)
438	(declare (ignorable root-level))
439	(write-string "null" pdf-stream))
440
441	(defmethod write-object ((obj dictionary) &optional root-level)
442	(declare (ignorable root-level))
443	(write-string "<< " pdf-stream)
444	(loop for (key . val) in (dict-values obj)
445	when val do
446	(write-string key pdf-stream)
447	(write-char #\Space pdf-stream)
448	(write-object val)
449	(write-char #\Newline pdf-stream))
450	(write-line " >>" pdf-stream))
451
452	(defmethod write-stream-content ((content string))
453	;; Args: content Base string, may include
454	;; - either one-byte codes (already converted to external format if needed)
455	;; - or Unicode two-byte character codes (big-endian CIDs)
456	#+pdf-binary
457	(loop for char across content
458	do (write-byte (ldb (byte 8 0) (char-code char)) pdf-stream))
459	#-pdf-binary
460	(write-sequence content pdf-stream))
461
462	(defmethod write-stream-content ((obj sequence))
463	#+pdf-binary
464	(write-sequence obj pdf-stream)
465	#-pdf-binary
466	(loop for c across obj do
467	(write-char (code-char c) pdf-stream)))
468
469	(defmethod write-stream-content ((obj list))
470	(map nil 'write-stream-content obj))
471
472	(defmethod write-object ((obj pdf-stream) &optional root-level)
473	(declare (ignorable root-level))
474	(compress-pdf-stream obj)
475	(call-next-method)
476	(write-line "stream" pdf-stream)
477	(write-stream-content (content obj))
478	(write-char #\Newline pdf-stream)
479	(write-line "endstream" pdf-stream))
480
481	(defmethod write-object ((obj object-ref) &optional root-level)
482	(declare (ignorable root-level))
483	(format pdf-stream "~d ~d R" (obj-number obj)(gen-number obj)))
484
485	(defmethod write-object ((obj indirect-object) &optional root-level)
486	(if root-level
487	(progn
488	(vector-push-extend (format nil "~10,'0d ~5,'0d n "
489	(file-position pdf-stream)(gen-number obj))
490	xrefs)
491	(format pdf-stream "~d ~d obj~%" (obj-number obj)(gen-number obj))
492	(when (content obj)(write-object (content obj)))
493	(write-string " endobj" pdf-stream)
494	(write-char #\Newline pdf-stream))
495	(format pdf-stream "~d ~d R" (obj-number obj)(gen-number obj))))
496
497	(defmethod write-object ((list list) &optional root-level)
498	(declare (ignorable root-level))
499	(dolist (obj list)
500	(write-object obj)
501	(write-char #\Space pdf-stream)))
502
503	(defmethod write-object ((obj string) &optional root-level)
504	(declare (ignorable root-level))
505	#+(and lispworks pdf-binary)
506	(if (lw:text-string-p obj) ; may include unicode characters
507	(loop for char across obj
508	if (lw:base-char-p char)
509	do (write-char char pdf-stream)
510	else do (write-byte (char-external-code char default-charset) pdf-stream))
511	(write-string obj pdf-stream))
512	#-(and lispworks pdf-binary)
513	(write-string obj pdf-stream))
514
515	(defmethod write-object ((obj symbol) &optional root-level)
516	(declare (ignorable root-level))
517	(write-string (symbol-name obj) pdf-stream))
518
519	(defmethod write-object ((obj function) &optional root-level)
520	(declare (ignorable root-level))
521	(write-object (funcall obj)))
522
523	(defmethod write-object ((obj number) &optional root-level)
524	(declare (ignorable root-level))
525	(if (integerp obj)
526	(princ obj pdf-stream)
527	;; rationals and such aren't allowed.
528	(format pdf-stream "~,3f" obj)))
529
530	(defmethod write-object ((obj t) &optional root-level)
531	(declare (ignorable root-level))
532	(princ obj pdf-stream))
533
534	(defmethod write-object ((array array) &optional root-level)
535	(declare (ignorable root-level))
536	(write-string "[ " pdf-stream)
537	(loop for obj across array do
538	(write-object obj)
539	(write-char #\Space pdf-stream))
540	(write-char #\] pdf-stream))
541
542	(defmethod write-object ((obj named-reference) &optional root-level)
543	(declare (ignorable root-level))
544	(write-object (reference obj)))
545
546	(defmethod write-document ((s stream) &optional (document document))
547	(let ((xrefs (make-array 10 :adjustable t :fill-pointer 0))
548	startxref
549	(pdf-stream s))
550	(with-standard-io-syntax
551	(process-outlines document)
552	(vector-push-extend "0000000000 65535 f " xrefs)
553	(write-line +pdf-header+ pdf-stream)
554	(loop for obj across (objects document)
555	for first = t then nil
556	if obj do (write-object obj t)
557	else do (unless first (vector-push-extend "0000000000 00001 f " xrefs)))
558	(setf startxref (file-position s))
559	(format pdf-stream "xref~%0 ~d~%" (length xrefs))
560	(loop for xref across xrefs
561	do (write-line xref s))
562	(format s "trailer~%<< /Size ~d~%/Root " (length xrefs));(1- (length (objects document))))
563	(write-object (catalog document))
564	(when (docinfo document)
565	(format s " /Info ")
566	(write-object (docinfo document)))
567	(format s "~%>>~%startxref~%~d~%%%EOF~%" startxref))))
568
569	#-allegro
570	(defmethod write-document ((filename pathname) &optional (document document))
571	(with-open-file (stream filename
572	:direction :output :if-exists :supersede
573	:element-type #+pdf-binary #+sbcl :default #-sbcl'(unsigned-byte 8)
574	#-pdf-binary 'base-char
575	:external-format +external-format+)
576	(write-document stream document)
577	filename)) ; indicate that operation succeeded
578
579	#+allegro
580	(defmethod write-document ((filename pathname) &optional (document document))
581	(with-open-file (stream filename
582	:direction :output :if-exists :supersede
583	;; when :element-type is not specified, simple-stream is created
584	:external-format +external-format+)
585	(write-document stream document)
586	filename)) ; indicate that operation succeeded
587
588	(defmethod write-document ((filename string) &optional (document document))
589	(write-document (pathname filename) document))
590
591	(defmacro with-document ((&rest args &key (max-number-of-pages 'max-number-of-pages) &allow-other-keys)
592	&body body)
593	`(let* ((root-page nil)
594	(document (make-instance 'document ,@args))
595	(outlines-stack (list (outline-root document)))
596	(page nil)
597	(page-number 0)
598	(max-number-of-pages ,max-number-of-pages))
599	(setf root-page (root-page document))
600	(catch 'max-number-of-pages-reached
601	,@body)))
602
603	(defmacro with-page ((&rest args) &body body)
604	`(let* ((page (make-instance 'page ,@args)))
605	(with-standard-io-syntax
606	(setf (content (content-stream page))
607	(with-output-to-string (page-stream)
608	,@body)))
609	t))
610
611

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format