🚀 go-pugleaf

This code gives you a mail-fcc command, bound to C-c C-f C-f in mail-mode,
that gives you completion on the folder name, looking by default in your
vm-folder-directory.  It uses vm-auto-folder-alist to pick a default
folder for you.  Since I use folders to contain both sides of
correspondence, this is very useful.

This code uses the mail-get-header-contents function from Noah Friedman.
If you don't have that already:

(defun mail-get-header-contents (HEADER)
  "Return the contents of header HEADER.  
If HEADER does not exist in the current mail buffer, return nil."
  (save-excursion
    (and (mail-position-on-field HEADER 'soft)
         (progn
           (let ((end (point))
                 (beg (progn
                        (re-search-backward (concat HEADER ": "))
                        (goto-char (match-end 0)))))
             (buffer-substring beg end))))))


;;; vm-fcc.el -- mail-fcc command for VM users.
;;; Copyright (C) 1992 Roland McGrath
;;; Based on code from vm-summary.el, version 5.32 beta.
;;; Copyright (C) 1989, 1990 Kyle E. Jones
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to roland@gnu.ai.mit.edu) or
;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Send bug reports to roland@gnu.ai.mit.edu.
;;;
;;; This is a mail-fcc function, bound to C-c C-f C-f in mail-mode,
;;; that gives you completion on the folder name, looking by default
;;; in your vm-folder-directory.  It uses vm-auto-folder-alist to pick
;;; a default folder.

;;; From vm-summary.el
(defun vm-match-data ()
  (let ((index '(9 8 7 6 5 4 3 2 1 0))
        (list))
    (while index
      (setq list (cons (match-beginning (car index))
		       (cons (match-end (car index)) list))
	    index (cdr index)))
    list))

(defun mail-fcc-auto-select-folder (auto-folder-alist)
  (condition-case ()
      (catch 'match
	(let (header alist tuple-list)
	  (setq alist auto-folder-alist)
	  (while alist
	    (setq header (mail-get-header-contents (car (car alist))))
	    (if (null header)
		()
	      (setq tuple-list (cdr (car alist)))
	      (while tuple-list
		(if (let ((case-fold-search
			   (if (boundp 'vm-auto-folder-case-fold-search)
			       vm-auto-folder-case-fold-search
			     case-fold-searc)))
		      (string-match (car (car tuple-list)) header))
		    ;; Don't waste time eval'ing an atom.
		    (if (atom (cdr (car tuple-list)))
			(throw 'match (cdr (car tuple-list)))
		      (let* ((match-data (vm-match-data))
			     (buf (get-buffer-create " *VM scratch*"))
			     (result))
			;; Set up a buffer that matches our cached
			;; match data.
			(save-excursion
			  (set-buffer buf)
			  (widen)
			  (erase-buffer)
			  (insert header)
			  ;; It appears that get-buffer-create clobbers the
			  ;; match-data.
			  ;;
			  ;; The match data is off by one because we matched
			  ;; a string and Emacs indexes strings from 0 and
			  ;; buffers from 1.
			  ;;
			  ;; Also store-match-data only accepts MARKERS!!
			  ;; AUGHGHGH!!
			  (store-match-data
			   (mapcar
			    (function (lambda (n) (and n (vm-marker n))))
			    (mapcar
			     (function (lambda (n) (and n (1+ n))))
			     match-data)))
			  (setq result (eval (cdr (car tuple-list))))
			  (throw 'match
				 (if (listp result)
				     (mail-fcc-auto-select-folder mp result)
				   result))))))
		(setq tuple-list (cdr tuple-list))))
	    (setq alist (cdr alist)))
	  nil ))
    (error nil)))

(defun mail-fcc ()
  "Add a new FCC field, with file name completion."
  (interactive)
  (expand-abbrev)
  (save-excursion
    (or (mail-position-on-field "fcc" t) ;Put new field after exiting FCC.
	(mail-position-on-field "to"))
    (insert "\nFCC: "
	    (let ((default (mail-fcc-auto-select-folder vm-auto-folder-alist)))
	      (read-file-name (format "Folder carbon copy (default %s): "
				      default)
			      vm-folder-directory 
			      default)))))

(define-key mail-mode-map "\C-c\C-f\C-f" 'mail-fcc)

(provide 'vm-fcc)