I use this function for printing a buffer's content to PDF
(from my .emacs file:)
(defun print-to-pdf ()
(interactive)
(ps-spool-buffer-with-faces)
(switch-to-buffer "*PostScript*")
(write-file "/tmp/tmp.ps")
(kill-buffer "tmp.ps")
(setq cmd (concat "ps2pdf14 /tmp/tmp.ps /home/user/" (buffer-name) ".pdf"))
(shell-command cmd)
(shell-command "rm /tmp/tmp.ps")
(message (concat "Saved to: /home/user/" (buffer-name) ".pdf"))
)
I cannot, however, find a way to enable or apply the visual-line minor mode to the PostScript buffer before it gets written to disk so to enable word wrap in the output.
The problem with getting visual line mode to be respected is that it inserts "soft newlines" (which get ignored by the PS renderer). A solution is to replace these with hard newlines. The code below does what you want, I think. Note that we call harden-newlines in a temporary buffer so as not to mess up the current document. Also, I've changed the output destination to always land in /tmp/print.pdf. It seems... unwise to overwrite documents in your /home without any sort of warning! You can always move the PDF afterwards.
Anyway, here you go. Is this what you wanted?
(defun harden-newlines ()
(interactive)
"Make all the newlines in the buffer hard."
(save-excursion
(goto-char (point-min))
(while (search-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)
(longlines-mode t)
(harden-newlines)
(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")))
Related
Is it possible to throw a value when exiting recursive edit without using setq?
The functions below work correctly with setq, however, my goal is to eliminate unnecessary global variables (if possible) -- especially file names -- and use let bound variables instead. In the context of throwing a value when exiting recursive edit, however, I have been unable to devise a method that does not use a global variable for the file name.
In this example, I am using lawlist-save-as in conjunction with dired-read-file-name to enter dired-mode and select a file name or a path. Pressing the enter key on a file name selects a file. Pressing the enter key on a directory name or the two (2) dots moves up one directory. Pressing the enter key on the line with just one (1) dot, means select only the path in the current directory. The value of the file name or path is passed back to the function lawlist-save-as through the last line of dired-read-file-name.
[Although not necessary for this example (but just in case anyone is curious), getting marked files with (dired-get-marked-files) is used for a different situation, such as attaching multiple files to an e-mail using Wanderlust -- in which case, I use the condition ((listp lawlist-filename) (throw 'exit nil)). And, of course, opening a file is self-explanatory -- used for a situation when dired-mode is entered regularly and then just pressing the return key on a file to be opened.]
(require 'dired)
(defvar lawlist-filename nil)
(defvar save-as-buffer-filename nil)
(defvar save-as-variable nil)
(defvar dired-buffer-name nil)
(defun dired-read-file-name (&optional directory)
(let ((working-buffer (buffer-name)))
(if directory
(dired directory)
(dired nil))
(let ((dired-buffer-name (buffer-name)))
(if save-as-buffer-filename
(progn
(goto-char (point-min))
(re-search-forward (file-name-nondirectory save-as-buffer-filename) nil t)))
(recursive-edit)
(kill-buffer dired-buffer-name)
(switch-to-buffer working-buffer)
lawlist-filename)))
;; select file or directory.
(define-key dired-mode-map (kbd "<return>") (lambda () (interactive)
(setq lawlist-filename
(if (or (re-search-backward "^*" nil t)
(re-search-forward "^*" nil t))
(dired-get-marked-files)
(dired-get-file-for-visit)))
(cond
((listp lawlist-filename)
(throw 'exit nil))
;; open file
((and (not (file-directory-p lawlist-filename))
(file-exists-p lawlist-filename)
(not (equal lawlist-filename (concat (file-name-directory lawlist-filename) ".")))
(not save-as-variable))
(find-file lawlist-filename))
;; save-as
((and (not (file-directory-p lawlist-filename))
(file-exists-p lawlist-filename)
(not (equal lawlist-filename (concat (file-name-directory lawlist-filename) "."))))
(throw 'exit nil))
;; go up one directory
((and (file-directory-p lawlist-filename)
(not (equal lawlist-filename (concat (file-name-directory lawlist-filename) "."))))
(setq dired-buffer-name (buffer-name))
(dired-find-file)
(goto-char (point-min))
(re-search-forward " \\.\\.$" nil t)
(kill-buffer dired-buffer-name)
(setq dired-buffer-name (buffer-name)))
;; only use current path for save-as situation.
((and (equal lawlist-filename (concat (file-name-directory lawlist-filename) "."))
save-as-variable)
(setq lawlist-filename (expand-file-name default-directory))
(throw 'exit nil)) )))
(defun lawlist-save-as ()
(interactive)
(setq save-as-variable t)
(if (buffer-file-name)
(setq save-as-buffer-filename (buffer-file-name)))
(let ((proposed-filename (dired-read-file-name)))
(when proposed-filename ;; needed if aborting recursive-edit
(setq save-as-variable nil)
(let ((save-as-filename (read-string "Save-As: "
(concat proposed-filename (when (file-directory-p proposed-filename) (buffer-name))))))
(setq save-as-buffer-filename nil)
(when (and save-as-filename (file-exists-p save-as-filename))
(or (y-or-n-p (format "File `%s' exists; overwrite? " save-as-filename))
(error "Canceled")))
(set-visited-file-name save-as-filename)
(set-buffer-modified-p t)
(and (buffer-file-name)
(file-writable-p buffer-file-name)
(setq buffer-read-only nil))
(save-buffer)))))
recursive-edit is just a function that runs a command loop. All stuff that is valid for lisp applies.
So if you encapsulate recursive-edit into a let which locally binds some variable, say test, and if you setq this variable during the recursive edit session this variable is just set locally in the scope of the let.
Example:
Run the following with C-x C-e:
(let (test)
(recursive-edit)
(message "test=%S" test))
You will be in the command loop of the recursive edit. Then set test via M-: (setq test "That is my test.").
Afterwards press M-C-c to exit the recursive edit session.
The message test=\"That is my test.\" is be printed out but the symbol test is still unbound.
I'm having difficulty trying to add an if file-exists-p condition inside the interactive list of this print-to-pdf function. The error message is: file-name-sans-extension: Wrong type argument: stringp, t. I have commented out the section that works, but which nevertheless overwrites an existing file without prompting for a yes or no. I've tried replacing hello-world with pdf-file-name, but that didn't fix the error.
Emacs Trunk developer build --with-ns on OSX, using ns-read-file-name, likes to overwrite files without prompting unless an additional file-exists-p is included in the function.
(defun print-to-pdf (pdf-file-name)
"Print the current file to the given file."
;; (interactive (list (ns-read-file-name "Write PDF file: " "~/" nil ".pdf")
(interactive (list
(let ((hello-world (ns-read-file-name "Write PDF file: " "~/" nil ".pdf")))
(if (file-exists-p hello-world)
(or (yes-or-no-p (format "File %s exists. Save anyway? " hello-world))
(error ""))))
))
(let (
(ps-file-name (concat (file-name-sans-extension pdf-file-name) ".ps"))
(wbuf (generate-new-buffer "*Wrapped*"))
(sbuf (current-buffer)))
(jit-lock-fontify-now)
(save-current-buffer
(set-buffer wbuf)
(insert-buffer sbuf)
(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 ps-file-name)
(kill-buffer (current-buffer)))
(call-process "/usr/local/bin/ps2pdf14" nil nil nil ps-file-name pdf-file-name)
(delete-file ps-file-name)
(message "PDF saved to %s" pdf-file-name))
)
Why do you want to add it to interactive in the first place? Wouldn't something like this work for you?
(defun print-to-pdf (pdf-file-name)
"Print the current buffer to the given file as PDF."
(interactive (list (ns-read-file-name "Write PDF file: " "~/" nil ".pdf")))
(when (and pdf-file-name
(or (not (file-exists-p pdf-file-name))
(yes-or-no-p "File exists. Overwrite? ")))
(let ((ps-file-name (concat (file-name-sans-extension pdf-file-name) ".ps"))
(wbuf (generate-new-buffer "*Wrapped*"))
(sbuf (current-buffer)))
(jit-lock-fontify-now)
(save-current-buffer
(set-buffer wbuf)
(insert-buffer sbuf)
(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 ps-file-name)
(kill-buffer (current-buffer)))
(call-process "/usr/local/bin/ps2pdf14" nil nil nil ps-file-name pdf-file-name)
(delete-file ps-file-name)
(message "PDF saved to %s" pdf-file-name))))
The existing code written by Rupert Swarbrick, later modified by Rory Yorke, still leaves open the need to specify the file location with a save-as function (e.g. on OSX, this would be ns-write-file-using-panel). Does anyone have a suggestion, please, that adds an option similar to ns-write-file-using-panel and/or perhaps modifies the /tmp directory option written in the script?
Word wrap for Emacs print buffer to PDF
Formatting a header in an Emacs function to print a buffer to PDF w/ line wrapping
(defun harden-newlines ()
(interactive)
"Make all the newlines in the buffer hard."
(save-excursion
(goto-char (point-min))
(while (search-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 spool-buffer-given-name (name)
(let ((ps-left-header (list (format "(%s)" name))))
(ps-spool-buffer-with-faces)))
(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)
;; (longlines-mode t)
(visual-line-mode t)
(harden-newlines)
(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")))
You can modify the last function to take a filename as a parameter:
(defun print-to-pdf (pdf-file-name)
"Print the current file to the given file."
(interactive "FWrite PDF file: ")
(let ((ps-file-name (concat (file-name-sans-extension pdf-file-name) ".ps"))
(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 ps-file-name t)
(kill-buffer (current-buffer)))
(call-process "ps2pdf14" nil nil nil ps-file-name pdf-file-name)
(delete-file ps-file-name)
(message "PDF saved to %s" pdf-file-name)))
You might want to add some code that tests if the PDF file already exist though, to avoid overwriting anything.
When executing the command shell-command, the output shown in the associated buffer is not colorized.
This is particularly annoying when calling a testing framework (outputting yellow/green/red...) from within emacs.
How can I configure, or extend, emacs in order to have shell-command allowing colorized output in the shell and preserving the colors while representing that output?
Thanks!
ps. I'm using the Bash shell, on a UN*X system.
This is probably what you want :
(add-hook 'shell-mode-hook 'ansi-color-for-comint-mode-on)
You can implement your own shell-execute, something like
(defun my-shell-execute(cmd)
(interactive "sShell command: ")
(shell (get-buffer-create "my-shell-buf"))
(process-send-string (get-buffer-process "my-shell-buf") (concat cmd "\n")))
This adds an advice to run ansi-color-apply-on-region on the minibuffer after shell-command finishes:
(require 'ansi-color)
(defun ansi-color-apply-on-buffer ()
(ansi-color-apply-on-region (point-min) (point-max)))
(defun ansi-color-apply-on-minibuffer ()
(let ((bufs (remove-if-not
(lambda (x) (string-starts-with (buffer-name x) " *Echo Area"))
(buffer-list))))
(dolist (buf bufs)
(with-current-buffer buf
(ansi-color-apply-on-buffer)))))
(defun ansi-color-apply-on-minibuffer-advice (proc &rest rest)
(ansi-color-apply-on-minibuffer))
(advice-add 'shell-command :after #'ansi-color-apply-on-minibuffer-advice)
;; (advice-remove 'shell-command #'ansi-color-apply-on-minibuffer-advice)
It does not rely on shell-mode or comint. I accompany it with something like the following to get nice test output (a green smiley with the count of successful doctests.
(defun add-test-function (cmd)
(interactive "sCommand to run: ")
(setq my-testall-test-function cmd)
(defun my-testall ()
(interactive)
(shell-command my-testall-test-function))
(local-set-key [f9] 'my-testall))
This solution is inspired by #ArneBabenhauserheide's but uses xterm-color instead of ansi-color. It also colorizes the *Shell Command Output* buffer as well as the mini
(defun xterm-color-colorize-shell-command-output ()
"Colorize `shell-command' output."
(let ((bufs
(seq-remove
(lambda (x)
(not (or (string-prefix-p " *Echo Area" (buffer-name x))
(string-prefix-p "*Shell Command" (buffer-name x)))))
(buffer-list))))
(dolist (buf bufs)
(with-current-buffer buf
(xterm-color-colorize-buffer)))))
(defun xterm-color-colorize-shell-command-output-advice (proc &rest rest)
(xterm-color-colorize-shell-command-output))
(advice-add 'shell-command :after #'xterm-color-colorize-shell-command-output-advice)
;; (advice-remove 'shell-command #'xterm-color-colorize-shell-command-output-advice)
Basically I want the *Messages* buffer to always scroll to the bottom when a new message arrives.
Can I do that?
I found auto-revert-tail-mode but that works for buffers that are visiting files.
When I tried it in the Messages buffer, it popped an error:
auto-revert-tail-mode: This buffer is not visiting a file
For multiple frames you probably want:
(defadvice message (after message-tail activate)
"goto point max after a message"
(with-current-buffer "*Messages*"
(goto-char (point-max))
(walk-windows (lambda (window)
(if (string-equal (buffer-name (window-buffer window)) "*Messages*")
(set-window-point window (point-max))))
nil
t)))
Just put point at the end of the buffer M->. If you don't manually move it it will stay there -- IOW, you will always see the tail.
This code seems a bit overkill, but a the simple (goto-char (point-max)) wasn't working for me:
(defadvice message (after message-tail activate)
"goto point max after a message"
(with-current-buffer "*Messages*"
(goto-char (point-max))
(let ((windows (get-buffer-window-list (current-buffer) nil t)))
(while windows
(set-window-point (car windows) (point-max))
(setq windows (cdr windows))))))
Here's an implementation that uses the new advice style.
(defun message-buffer-goto-end-of-buffer (&rest args)
(let* ((win (get-buffer-window "*Messages*"))
(buf (and win (window-buffer win))))
(and win (not (equal (current-buffer) buf))
(set-window-point
win (with-current-buffer buf (point-max))))))
(advice-add 'message :after 'message-buffer-goto-end-of-buffer)
i run 23.3 and there were still way too many occasions where the built-in 'solution' and the orginal defadvice on the message function just didn't cut it, so i wrapped that code in a list / toggle / timer set up and it's working beautifully - no more frustration when debugging!
it's generic, so works on any buffer, although i only really use it for..
(toggle-buffer-tail "*Messages*" "on")
..hope it's useful to someone.
;alist of 'buffer-name / timer' items
(defvar buffer-tail-alist nil)
(defun buffer-tail (name)
"follow buffer tails"
(cond ((or (equal (buffer-name (current-buffer)) name)
(string-match "^ \\*Minibuf.*?\\*$" (buffer-name (current-buffer)))))
((get-buffer name)
(with-current-buffer (get-buffer name)
(goto-char (point-max))
(let ((windows (get-buffer-window-list (current-buffer) nil t)))
(while windows (set-window-point (car windows) (point-max))
(with-selected-window (car windows) (recenter -3)) (setq windows (cdr windows))))))))
(defun toggle-buffer-tail (name &optional force)
"toggle tailing of buffer NAME. when called non-interactively, a FORCE arg of 'on' or 'off' can be used to to ensure a given state for buffer NAME"
(interactive (list (cond ((if name name) (read-from-minibuffer
(concat "buffer name to tail"
(if buffer-tail-alist (concat " (" (caar buffer-tail-alist) ")") "") ": ")
(if buffer-tail-alist (caar buffer-tail-alist)) nil nil
(mapcar '(lambda (x) (car x)) buffer-tail-alist)
(if buffer-tail-alist (caar buffer-tail-alist)))) nil)))
(let ((toggle (cond (force force) ((assoc name buffer-tail-alist) "off") (t "on")) ))
(if (not (or (equal toggle "on") (equal toggle "off")))
(error "invalid 'force' arg. required 'on'/'off'")
(progn
(while (assoc name buffer-tail-alist)
(cancel-timer (cdr (assoc name buffer-tail-alist)))
(setq buffer-tail-alist (remove* name buffer-tail-alist :key 'car :test 'equal)))
(if (equal toggle "on")
(add-to-list 'buffer-tail-alist (cons name (run-at-time t 1 'buffer-tail name))))
(message "toggled 'tail buffer' for '%s' %s" name toggle)))))
edit: changed functionality to display tail at the bottom of the window
Here's an amendment over Peter's / Trey's solutions
(defun modi/messages-auto-tail (&rest _)
"Make *Messages* buffer auto-scroll to the end after each message."
(let* ((buf-name "*Messages*")
;; Create *Messages* buffer if it does not exist
(buf (get-buffer-create buf-name)))
;; Activate this advice only if the point is _not_ in the *Messages* buffer
;; to begin with. This condition is required; otherwise you will not be
;; able to use `isearch' and other stuff within the *Messages* buffer as
;; the point will keep moving to the end of buffer :P
(when (not (string= buf-name (buffer-name)))
;; Go to the end of buffer in all *Messages* buffer windows that are
;; *live* (`get-buffer-window-list' returns a list of only live windows).
(dolist (win (get-buffer-window-list buf-name nil :all-frames))
(with-selected-window win
(goto-char (point-max))))
;; Go to the end of the *Messages* buffer even if it is not in one of
;; the live windows.
(with-current-buffer buf
(goto-char (point-max))))))
(advice-add 'message :after #'modi/messages-auto-tail)