Formatting a header in an Emacs function to print a buffer to PDF w/ line wrapping

Rupert Swarbrick came up with the following three functions to print an Emacs buffer to pdf in which lines are wrapped (this is not normally the case when using ps-print* functions).

The problem is this function is that to achieve this line wrapping, a copy of the current buffer has to be made. This effectively breaks the capability of ps-print-buffer-with-faces to display a correct header on top of each page in the resulting PDF file.

As part of his solution, Rupert Swarbrick wrote a function that preserves this information. The resulting header, however, is always HeaderLinesLeft

Who can spot the mistake?

(defun harden-newlines ()
  (interactive)
  "Make all the newlines in the buffer hard."
  (save-excursion
    (goto-char (point-min))
    (while (searc开发者_Go百科h-forward "\n" nil t)
      (backward-char)
      (put-text-property (point) (1+ (point)) 'hard t)
      (forward-char))))

(defun spool-buffer-given-name (name)
  (load "ps-print")
  (let ((tmp ps-left-header))
    (unwind-protect
        (progn
          (setq ps-left-header
                (list (lambda () name) 'ps-header-dirpart))
          (ps-spool-buffer-with-faces))
      (setf ps-left-header tmp))))

(defun print-to-pdf ()
  "Print the current file to /tmp/print.pdf"
  (interactive)
  (let ((wbuf (generate-new-buffer "*Wrapped*"))
        (sbuf (current-buffer)))
    (jit-lock-fontify-now)
    (save-current-buffer
      (set-buffer wbuf)
      (insert-buffer sbuf)
      (setq fill-column 95)
      (longlines-mode t)
      (harden-newlines)
      (message (buffer-name sbuf))
      (spool-buffer-given-name (buffer-name sbuf))
      (kill-buffer wbuf)
      (switch-to-buffer "*PostScript*")
      (write-file "/tmp/print.ps")
      (kill-buffer (current-buffer)))
    (call-process "ps2pdf14" nil nil nil
                  "/tmp/print.ps" "/tmp/print.pdf")
    (delete-file "/tmp/print.ps")
    (message "PDF saved to /tmp/print.pdf")))

Try this:

(defun spool-buffer-given-name (name)
  (let ((ps-left-header (list (format "(%s)" name))))
    (ps-spool-buffer-with-faces)))

See documentation for variable ps-left-header, which is what clued me in to the above.

This is a neat capability; I'll definitely use it instead of ps-print. It would be good to make it act more like C-u M-x ps-print-buffer-with-faces; two missing features are directory name in the header, and prompting the user for a filename. Neither is too difficult.