pdf-parser.lisp

;;; cl-pdf copyright 2002-2005 Marc Battyani see license.txt for the details
;;; You can reach me at marc.battyani@fractalconcept.com or marc@battyani.net
;;; The homepage of cl-pdf is here: http://www.fractalconcept.com/asp/html/cl-pdf.html

;; Thanks to Arthur Lemmens for the recursive descent parser :)
;; (It's much nicer than my original LALR parser ;-)
;; See the example at the end for usage.

(in-package #:pdf)

(defvar *pdf-input-stream* nil)
(defvar *indirect-objects* nil)

(defun find-indirect-object (obj-number gen-number)
  (let ((object.pos (gethash (cons obj-number gen-number) *indirect-objects*)))
    (if object.pos
	(values (car object.pos) (cdr object.pos))
	(make-indirect-object obj-number gen-number 0))))

(defun make-indirect-object (obj-number gen-number position)
  (let ((object (or (car (gethash (cons obj-number gen-number) *indirect-objects*))
		    (make-instance 'indirect-object
				   :obj-number obj-number
				   :gen-number gen-number
				   :content :unread
				   :no-link t))))
    (setf (gethash (cons obj-number gen-number) *indirect-objects*) (cons object position))
    object))

(defun read-indirect-object (obj-number gen-number)
  (multiple-value-bind (object position) (find-indirect-object obj-number gen-number)
    (when (eq (content object) :unread)
      (setf (content object) (read-indirect-object-content position)))
    object))

(defun load-indirect-object (object)
  (when (eq (content object) :unread)
    (read-indirect-object (obj-number object) (gen-number object)))
  object)

(defun delete-indirect-object (object)
  (remhash (cons (obj-number object) (gen-number object)) *indirect-objects*))

(defun load-all-indirect-objects ()
  (loop for object.pos being the hash-value of *indirect-objects*
        do (load-indirect-object (car object.pos))))

;;; Parsing Errors

(define-condition pdf-parse-error (parse-error)
  ((stream :initarg :stream :reader pdf-parse-error-stream)
   (control :initarg :control :reader pdf-parse-error-control :allocation :class)
   (context :initarg :context :reader pdf-parse-error-context :allocation :class))
  (:default-initargs :control nil :context ())
  (:report report-pdf-parse-error))

(defun report-pdf-parse-error (error stream)
  (format stream "~&Error at position ~D while reading PDF document:~
                  ~:[~*~;~:*~%~?~]~%~A~%"
          (file-position (pdf-parse-error-stream error))
          (pdf-parse-error-control error)
          (mapcar (lambda (reader) (funcall reader error))
                  (pdf-parse-error-context error))
          (pdf-parse-error-stream error)))

(defmacro define-parsing-error (name continuable string &rest slots)
  (loop for (slot-name initarg reader) in slots collect
       `(,slot-name :initarg ,initarg :reader ,reader) into slot-definitions
     collect slot-name into slot-names collect reader into readers
     nconc `(,initarg ,slot-name) into initargs finally
       (return `(progn
                  (define-condition ,name (pdf-parse-error) ,slot-definitions
                    (:default-initargs :control ,string :context ',readers))
                  (defmacro ,name ,slot-names
                    ,(if continuable
                         ``(cerror "Ignore it and continue."
                                   ',',name :stream *pdf-input-stream*
                                   ,,@initargs)
                         ``(error ',',name :stream *pdf-input-stream*
                                  ,,@initargs)))))))

(define-parsing-error unexpected-eof-error nil "Unexpected EOF, during ~A."
  (eof-context :eof-context unexpected-eof-context))
(define-parsing-error unexpected-character-error t "Unexpected character ~S."
  (unexpected :unexpected unexpected-character))
(define-parsing-error wrong-character-error t "Wrong character ~S, wanted ~S."
  (unexpected :unexpected unexpected-character)
  (expected :expected expected-character))
(define-parsing-error invalid-number-error nil "Object ~S is not a number."
  (unexpected :unexpected unexpected-object))
(define-parsing-error invalid-hexadecimal-error nil "~S is not a hex digit."
  (unexpected :unexpected unexpected-character))

;;; Characters

(defvar +white-char+ (coerce '(#\Space #\Newline #\Return #\Tab #\Null #\Page) 'string))

(defun white-char-p (c)
  (find c +white-char+))

(defun numeric-char-p (char)
  (find char "0123456789-."))

(defun name-char-p (char)
  (and (<= #x21 (char-code char) #x7E)
       (not (find char "%()<>[]{}/#"))))

(defun extended-ascii-p (char)
  (<= 128 (char-code char) 253))

;;; Skipping characters

(defun eat-char (expected-char)
  (let ((char (read-char *pdf-input-stream*)))
    (unless (char= char expected-char)
      (wrong-character-error char expected-char))))

(defun eat-chars (chars)
  (loop for char across chars
        do (eat-char char)))

(defun eat-keyword (keyword)
  (skip-whitespace t)
  (eat-chars keyword)
  (skip-whitespace t))

(defun skip-whitespace (eof-error-p &key (skip-comments t))
  (loop
   (let ((char (read-char *pdf-input-stream* eof-error-p)))
     (cond ((null char)
            (return :eof))
           ((and skip-comments (eql char #\%))
            (loop for c = (read-char *pdf-input-stream* nil)
                  until (or (null c) (eq c #\Newline))))
           ((not (white-char-p char))
            (unread-char char *pdf-input-stream*)
            (return char))))))

;;; PDF Basic objects (see Chapter 4)

(defun read-object (&optional (eof-error-p t))
  "Returns one of the following PDF objects: boolean (:true or :false),
number (Lisp number), string (Lisp string), name (Lisp symbol in the PDF
package), array (Lisp vector), dictionary (Lisp property list), stream
(Lisp pdf-stream) or null (Lisp NIL). When EOF-ERRORP is nil, it returns
:eof for the end of the stream (otherwise it signals an error)." 
  (skip-whitespace eof-error-p)
  (let ((char (peek-char nil *pdf-input-stream* eof-error-p)))
    (cond ((numeric-char-p char)
           (read-number))
          ((eql char #\()
           (eat-char #\()
           (read-pdf-string))
          ((eql char #\/)
           (eat-char #\/)
           (read-name ))
          ((eql char #\[)
           (eat-char #\[)
           (read-array))
          ((eql char #\<)
           (eat-char #\<)
           (let ((next-char (peek-char nil *pdf-input-stream*)))
             (if (char= next-char #\<)
                 (progn (eat-char #\<)
                   (read-dictionary-or-stream))
               (read-hex-string))))
          ((eql char #\t)
           (eat-chars "true")
           "true")
          ((eql char #\f)
           (eat-chars "false")
           "false")
          ((eql char #\n)
           (eat-chars "null")
           nil)
          ((eql char #\e)
           ;; this is probably an empty indirect object.  WRITE-OBJECT
           ;; can write them, so we should be able to read them too.
           nil)
          ((or (eql char #\R) (eql char #\U))
           ;; Add this clause to avoid parsing error
           ;; when it encouters "UNREAD" or "R" line. -- by H.Kuroda
           nil)
          (t (unexpected-character-error char)))))

(defun read-number ()
  (read-from-string
   (with-output-to-string (s)
     (loop for char = (read-char *pdf-input-stream* nil nil)
           until (or (null char) (not (numeric-char-p char)))
           do (write-char char s)
           finally (when char
                     (unread-char char *pdf-input-stream*))))))

;;; Integers

(defun check-integers (&rest objects)
  (dolist (object objects)
    (assert (integerp object) () 'invalid-number-error
            :unexpected object :stream *pdf-input-stream*)))

(defun read-integer (&aux (object (read-object))) (check-integers object) object)

;;; Strings

;; See "7.3.4.2 Literal Strings" in
;; https://www.adobe.com/content/dam/acom/en/devnet/pdf/pdfs/PDF32000_2008.pdf
(defun read-pdf-string ()
  ;; TODO: Deal with encodings.
  (with-output-to-string (s)
    (write-char #\( s)
    (loop with paren-count = 0
          for prev-char = #\( then char
          for char = (read-char *pdf-input-stream*)
          do (unless (char= prev-char #\\)
               (cond ((char= char #\() (incf paren-count))
                     ((char= char #\))
                      (when (eql 0 paren-count) (return))
                      (decf paren-count))))
             (write-char char s))
    (write-char #\) s)))

(defun read-hex-string ()
  (with-output-to-string (s)
    (write-char #\< s)
    (loop for char = (read-char *pdf-input-stream*)
       until (char= char #\>)
       do (write-char char s))
    (write-char #\> s)))

(defun read-hex-digit (&aux (char (read-char *pdf-input-stream*)))
  (or (digit-char-p char 16) (invalid-hexadecimal-error char)))

;;; Names

(defun read-name ()
  (with-output-to-string (name)
    (write-char #\/ name)
    (loop (let ((char (read-char *pdf-input-stream* nil nil)))
	    (cond ((null char) (return))
		  ((eql char #\#)
                   (write-char (code-char (+ (ash (read-hex-digit) 4)
                                             (read-hex-digit)))
                               name))
		  ((name-char-p char) (write-char char name))
                  ((extended-ascii-p char) ; Extended ASCII -- by H.Kuroda
		   (write-char char name))
		  (t (unread-char char *pdf-input-stream*)
		     (return)))))))

;;; Arrays

(defun read-array ()
  ;; #\[ has already been read
  (let ((stack '()))
    (loop (skip-whitespace t)
          (let ((char (peek-char nil *pdf-input-stream*)))
            (case char
              ( #\]
                (eat-char #\])
                (return))
              ( #\R
                (eat-char #\R)
                ;; Reduce last two numbers to indirect-reference
                (let ((generation (pop stack)) (object (pop stack)))
                  (check-integers object generation)
                  (push (find-indirect-object object generation) stack)))
              (otherwise
               (push (read-object) stack)))))
    (make-array (length stack)
                :initial-contents (nreverse stack))))

;;; Dictionaries and streams

(defun read-dictionary-properties ()
  (let ((plist '()))
    (loop (skip-whitespace t)
          (let ((char (peek-char nil *pdf-input-stream*)))
            (case char
              ( #\>
                (eat-chars ">>")
                (return))
              ( #\R
                (eat-char #\R)
                ;; Reduce last two numbers to indirect-object
                (let ((generation (pop plist)) (object (pop plist)))
                  (check-integers object generation)
                  (push (find-indirect-object object generation) plist)))
              (otherwise
               (push (read-object t)
                     plist)))))
    (loop for (k v . rest) on (nreverse plist) by #'cddr
          collect (cons k v))))

(defun read-dictionary ()
  (make-instance 'dictionary :dict-values (read-dictionary-properties)))

(defun read-dictionary-or-stream ()
  (let ((properties (read-dictionary-properties)))
    ;; Check if dictionary is followed by a stream
    (skip-whitespace nil)
    (let ((char (peek-char nil *pdf-input-stream* nil nil)))
      (cond ((eql char #\s)
             ;; Don't use EAT-KEYWORD here, because it may eat too many newlines!
             (eat-chars "stream")
             (read-line *pdf-input-stream*)
             (read-pdf-stream properties))
            (t (make-instance 'dictionary :dict-values properties))))))

(defun read-pdf-stream (properties)
  (let ((length (cdr (assoc "/Length" properties :test #'string=))))
    (when (typep length 'indirect-object)
      (let ((saved-filepos (file-position *pdf-input-stream*)))
        (setq length (content (load-indirect-object length)))
        (file-position *pdf-input-stream* saved-filepos)))
    (check-integers length)
    (let ((content (loop repeat (ceiling length array-total-size-limit)
		      for buffer-size = (min length array-total-size-limit)
		      ;; while (plusp buffer-size)
		      collect (let* ((buffer (make-string buffer-size))
				     (bytes-read (read-sequence buffer *pdf-input-stream*)))
				(when (< bytes-read buffer-size)
                                  (unexpected-eof-error "encoded object stream"))
				buffer)
		      do (decf length buffer-size))))
      (eat-keyword "endstream")
      (make-instance 'pdf-stream :dict-values properties :content content :no-compression t))))

;;; Indirect objects

(defun read-indirect-object-content (file-position)
  (file-position *pdf-input-stream* file-position)
  (let ((object-number (read-integer)) (generation-number (read-integer)))
    (declare (ignorable object-number generation-number))
    (eat-keyword "obj")
    (let ((object (read-object)))
      ;; Some producers forget the "endobj" at the end of a stream
      ;; Let's try to be tolerant.
      (skip-whitespace t)
      (when (char= #\e (peek-char nil *pdf-input-stream*))
        (eat-keyword "endobj"))
      object)))

;;; xref

(defun read-xref-and-trailer (position)
  (let (first-trailer)
    (loop
       (read-cross-reference-subsections position)
       (let ((trailer (read-trailer)))
	 (unless first-trailer (setf first-trailer trailer))
	 (let ((prev-position (get-dict-value trailer "/Prev")))
	   (if prev-position
	       (setq position prev-position)
	       (return first-trailer)))))))

(defun read-cross-reference-subsections (position)
  (file-position *pdf-input-stream* position)
  (eat-keyword "xref")
  (loop
   ;; the eat-keyword skips whitespace the first time, but there can
   ;; be more whitespace the second time around.
     (skip-whitespace t)
     (let ((char (peek-char nil *pdf-input-stream*)))
       (cond ((char= char #\t) (return))
             (t (read-cross-reference-subsection))))))

(defun read-cross-reference-subsection ()
  (let ((first-entry (read-integer))
        (nr-entries (read-integer)))
    (loop repeat nr-entries
	  for number from first-entry
          do (read-cross-reference-entry number))))

(defun read-cross-reference-entry (number)
  (let ((position (read-integer)))
    (skip-whitespace nil)
    (let ((gen (read-integer)))
      (skip-whitespace nil)
      (let ((type (read-char *pdf-input-stream*)))
        (skip-whitespace nil)
        (if (char= type #\n)
	    (make-indirect-object number gen position))))))

(defun read-trailer ()
  (eat-keyword "trailer")
  (skip-whitespace t)
  (eat-chars "<<")
  (read-dictionary))

(defconstant +xref-search-size+ 1024
  "Read this many bytes at end of file to look for 'startxref'")

(defun find-cross-reference-start ()
  (let* ((file-length (file-length *pdf-input-stream*))
         (xref-search-size ; file-length can be smaller then +xref-search-size+
          (min +xref-search-size+ file-length))
         (buffer (make-string +xref-search-size+)))
    (file-position *pdf-input-stream* (- file-length xref-search-size))
    (read-sequence buffer *pdf-input-stream*)
    (let ((position (search "startxref" buffer)))
      (unless position (unexpected-eof-error "file trailer"))
      (parse-integer buffer :start (+ position 10) :junk-allowed t))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Higher level Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun renumber-all-indirect-objects ()
  "Gives all indirect objects a consecutive numbering.
Returns the first unused object-number."
  (let ((objects (make-array (hash-table-count *indirect-objects*)
			     :fill-pointer 0 :adjustable t
			     :initial-element nil)))
    (setf (objects *document*) objects)
    (setf (last-object-number *document*) (hash-table-count *indirect-objects*))
    (loop for object.pos being the hash-value of *indirect-objects*
	  for object = (car object.pos)
          for number from 1 do
	 (setf (obj-number object) number
	       (gen-number object) 0)
	 (vector-push-extend object objects))))

(defun read-pdf-file (file)
  (let ((*indirect-objects* (make-hash-table :test #'equal))
	(*document* (make-instance 'document :empty t)))
    (with-open-file (*pdf-input-stream* file
		     :direction :input
		     :external-format +external-format+)
      (read-pdf))
    *document*))

(defun collect-pages (page pages-vector root-page-node)
  (if (string= (get-dict-value (content page) "/Type") "/Pages")
      (progn
	(loop for kid-page across (get-dict-value (content page) "/Kids")
  	      do (collect-pages kid-page pages-vector root-page-node))
	(unless (eq page root-page-node) (delete-indirect-object page)))
      (progn
	(unless (eq page root-page-node)
	  (change-dict-value (content page) "/Parent" root-page-node))
	(vector-push-extend page pages-vector))))

(defun read-pdf ()
  (let ((trailer (read-xref-and-trailer (find-cross-reference-start))))
    (setf (catalog *document*) (get-dict-value trailer "/Root")
          (docinfo *document*) (get-dict-value trailer "/Info"))
    (load-all-indirect-objects)
    (let ((root-page-node
           (change-class (get-dict-value (content (catalog *document*)) "/Pages")
                         'page-node))
	  (pages-vector (make-array 1 :fill-pointer 0 :adjustable t)))
      (collect-pages root-page-node pages-vector root-page-node)
      (setf (pages root-page-node) pages-vector)
      (change-dict-value (content root-page-node) "/Count"
                         (lambda () (length (pages root-page-node))))
      (change-dict-value (content root-page-node) "/Kids" (pages root-page-node))
      (renumber-all-indirect-objects)
      (setf (root-page *document*) root-page-node))))

(defvar *original-content* nil)
(defvar *current-content* nil)

(defun insert-original-page-content ()
  ;; save graphics state
  (write-line " q" *page-stream*)
  (vector-push-extend (make-instance 'indirect-object :content 
				     (make-instance 'pdf-stream :content 
						    (get-output-stream-string *page-stream*)))
		      *current-content*)
  (if (vectorp *original-content*)
      (loop for content across *original-content* do
	   (vector-push-extend content *current-content*))
      (vector-push-extend *original-content* *current-content*))
  (setf *page-stream* (make-string-output-stream))
  ;; restore graphics state
  (write-line " Q" *page-stream*))

(export 'insert-original-page-content)

(defun ensure-dictionary (obj)
  (if (typep obj 'indirect-object)
      (content obj)
      obj))

(defun open-page (page-num)
  (let* ((page (aref (pages *root-page*) page-num))
	 (dict (content page))
	 (resources (ensure-dictionary (get-dict-value dict "/Resources")))
         (fonts (ensure-dictionary (get-dict-value resources "/Font")))
         (xobjects (ensure-dictionary (get-dict-value resources "/XObject")))
         (content-stream (make-instance 'pdf-stream)))
    (setf *original-content* (get-dict-value dict "/Contents"))
    (setf *current-content* (make-array 10 :fill-pointer 0 :adjustable t ))
    (change-class page 'page)
    (unless resources
      (setf resources (make-instance 'dictionary)))
    (change-dict-value dict "/Resources" resources)
    (unless fonts
      (setf fonts (make-instance 'dictionary)))
    (change-dict-value resources "/Font" fonts)
    (unless xobjects
      (setf xobjects (make-instance 'dictionary)))
    (change-dict-value resources "/XObject" xobjects)
    (setf (bounds page)(get-dict-value dict "/MediaBox")
          (resources page) resources
          (font-objects page) fonts
          (xobjects page) xobjects
          (content-stream page) content-stream)
    (change-dict-value dict "/Contents" *current-content*)
    page))

(defun copy-page (page-num)
  (let* ((src-page (aref (pages *root-page*) page-num))
	 (src-dict (content src-page))
	 (resources (copy-dict (ensure-dictionary (get-dict-value src-dict "/Resources"))))
	 (fonts (copy-dict (ensure-dictionary (get-dict-value resources "/Font"))))
	 (xobjects (copy-dict (ensure-dictionary (get-dict-value resources "/XObject"))))
	 (new-page (make-instance 'page))
	 (new-dict (setf (content new-page) (copy-dict src-dict)))
	 (content-stream (make-instance 'pdf-stream)))
    (setf *original-content* (get-dict-value src-dict "/Contents"))
    (setf *current-content* (make-array 10 :fill-pointer 0 :adjustable t))
    (unless resources
      (setf resources (make-instance 'dictionary)))
    (change-dict-value new-dict "/Resources" resources)
    (unless fonts
      (setf fonts (make-instance 'dictionary)))
    (change-dict-value resources "/Font" fonts)
    (unless xobjects
      (setf xobjects (make-instance 'dictionary)))
    (change-dict-value resources "/XObject" xobjects)
    (setf (bounds new-page) (get-dict-value src-dict "/MediaBox")
	  (resources new-page) resources
	  (font-objects new-page) fonts
	  (xobjects new-page) xobjects
	  (content-stream new-page) content-stream)
    (change-dict-value new-dict "/Contents" *current-content*)
    new-page))

(defun remove-page (page-num)
  (let ((page (aref (pages *root-page*) page-num)))
    (setf (pages *root-page*)
	  (remove page (pages *root-page*)))
    (change-dict-value (content *root-page*) "/Count"
                       (lambda () (length (pages *root-page*))))
    (change-dict-value (content *root-page*) "/Kids" (pages *root-page*))))


(export 'remove-page)

(defmacro with-existing-document ((file &key creator author title subject keywords) &body body)
  `(let* ((*document* (read-pdf-file ,file))
	  (*root-page* (root-page *document*))
	  (*page-number* 0)
          (*name-counter* 100))
     (add-doc-info *document* :creator ,creator :author ,author
		   :title ,title :subject ,subject :keywords ,keywords)
    ,@body))

(export 'with-existing-document)

(defmacro with-existing-page ((page-number &key copy-p) &body body)
  `(let* ((*original-content* nil)
	  (*current-content* nil)
	  (*page* (if ,copy-p
		      (copy-page ,page-number)
		      (open-page ,page-number))))
     (setf (content (content-stream *page*))
	   (let ((*page-stream* (make-string-output-stream)))
	     ,@body
	     (vector-push-extend
	      (make-instance 'indirect-object :content 
			     (make-instance 'pdf-stream :content 
					    (get-output-stream-string pdf::*page-stream*)))
	      *current-content*)))))

(export 'with-existing-page)

#|

(pdf:with-existing-document (#P"/tmp/MS-32.pdf")
  (pdf:with-existing-page (0)
    (let ((helvetica (pdf:get-font "Helvetica")))
      (pdf:in-text-mode
       (pdf:set-font helvetica 45.0)
       (pdf:move-text 95 700)
       (pdf:draw-text "cl-pdf-parser example"))
      (pdf:with-saved-state
	  (pdf:translate 200 60)
	(pdf:scale 0.7 0.7)
	(pdf:rotate 15)
	(pdf:insert-original-page-content))
      (pdf:translate 230 400)
      (loop repeat 170
	 for i = 0.67 then (* i 1.03)
	 do (pdf:in-text-mode
	     (pdf:set-font helvetica i)
	     (pdf:set-rgb-fill (/ (random 255) 255.0)(/ (random 255) 255.0)(/ (random 255) 255.0))
	     (pdf:move-text (* i 3) 0)
	     (pdf:draw-text "cl-pdf"))
	   (pdf:rotate 13))))
  (pdf:with-existing-page (1)
    (let ((helvetica (pdf:get-font "Helvetica")))
      (pdf:insert-original-page-content)
      (pdf:in-text-mode
       (pdf:set-font helvetica 60.0)
       (pdf:move-text 250 250)
       (pdf:rotate 30)
       (pdf:set-rgb-fill 1.0 0.0 0.0)
       (pdf:draw-text "cl-pdf-parser example"))))
  (pdf:with-page ()       ;add a new page
    (let ((helvetica (pdf:get-font "Helvetica")))
      (pdf:in-text-mode
       (pdf:set-font helvetica 36.0)
       (pdf:move-text 100 800)
       (pdf:draw-text "cl-pdf: Example 1"))
      (pdf:translate 230 500)
      (loop repeat 150
	 for i = 0.67 then (* i 1.045)
	 do (pdf:in-text-mode
	     (pdf:set-font helvetica i)
	     (pdf:set-rgb-fill (/ (random 255) 255.0)(/ (random 255) 255.0)(/ (random 255) 255.0))
	     (pdf:move-text (* i 3) 0)
	     (pdf:draw-text "cl-typesetting"))
	   (pdf:rotate 13))))
  (pdf:write-document #P"/tmp/t.pdf"))

|#