emacs_el/post.el

   1 ;       $Id: post.el,v 2.4 2004/07/23 23:13:17 rreid Exp rreid $
   2 ;; post.el --- Use (X?)Emacs(client) as an external editor for mail and news.
   3
   4 ;;; Authors: Eric Kidd <eric.kidd@pobox.com>,
   5 ;;;          Dave Pearson <davep@davep.org>,
   6 ;;;          Rob Reid <reid@astro.utoronto.ca>,
   7 ;;;          Roland Rosenfeld <roland@spinnaker.de>
   8
   9 ;; This is free software distributed under the GPL, yadda, yadda, yadda.
  10 ;; It has no warranty. See the GNU General Public License for more
  11 ;; information. Send us your feature requests and patches, and we'll try
  12 ;; to integrate everything.
  13
  14 ;;; Maintainer: Rob Reid <reid@astro.utoronto.ca>
  15
  16 ;;; Keywords: mail
  17
  18 ;;; Commentary:
  19 ;; This is a major mode for use with Mutt, the spiffy *nix mailreader du jour
  20 ;; (See http://www.mutt.org/), slrn, the spiffy *nix newsreader du jour, or
  21 ;; whatever you can get it to work with.  To use this mode, add the following
  22 ;; line to the .emacs file in your home directory:
  23 ;;
  24 ;;   (load "/your/local/path/to/this/file/post")
  25 ;;
  26 ;; Note that you can omit the ".el" from the file name when calling load.
  27 ;;
  28 ;; If you want to make it available to all your users, type \C-h v
  29 ;; load-path RET, pick an appropriate directory for post.el, and modify
  30 ;; your sitewide default.el to (require 'post).
  31 ;;
  32 ;; You may find the latest version of this mode at
  33 ;; http://astro.utoronto.ca/~reid/mutt/
  34
  35
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;;
  38 ;; BUGS:
  39 ;;
  40 ;; Rob: I predict that some buffers (*Original*<2>, *Composing*<2>?)
  41 ;; will be left behind if you edit more than one message at a time.
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;;
  45 ;;; Thanks
  46 ;;;
  47 ;;; Dave Pearson: Code, feature ideas, Mutt experience. Many thanks!
  48 ;;; Louis Theran: Encouragement to make Mutt mode work like Emacs MUAs.
  49 ;;; Ronald: Enlightening gripes about what Emacs should do, but doesn't.
  50 ;;; Robert Napier: Bug reports about font-lock mode, fancy wrapping.
  51 ;;; Kevin Rodgers: Answered RR's question on gnu.emacs.help on
  52 ;;; overwriting server-process-filter's annoying message at startup.
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;;;
  56 ;;; Revision History
  57 ;;;
  58 ;;; $Log: post.el,v $
  59 ;;; Revision 2.401  2004/07/23 16:27:29  rreid
  60 ;;; Fixed post-delete-quoted-signatures to not remove sneaky things like quoted
  61 ;;; double dash arrows.  Thanks go to Felix Klee for a clear bug report.
  62 ;;;
  63 ;;; Revision 2.4  2002/04/22 22:04:29  reid
  64 ;;; Tweaked post-emoticon-pattern yet again.  Made cl mandatory for all
  65 ;;; versions of emacs.  (Thanks to Eric Dorland and Mike Schiraldi for bug
  66 ;;; reports.)  Fixed post-unquote-region.  (Thanks to Mike Schiraldi for the
  67 ;;; bug report.)
  68 ;;;
  69 ;;; Revision 2.3  2002/04/21 20:13:55  reid
  70 ;;; Improved post-emoticon-pattern.
  71 ;;;
  72 ;;; Revision 2.2  2002/04/20 04:12:54  reid
  73 ;;; Improved post-emoticon-pattern.
  74 ;;;
  75 ;;; Revision 2.1  2002/04/20 03:17:48  reid
  76 ;;; - A major (but not total) synchronization with Dave Pearson's post-mode.
  77 ;;;   header-set-followup-to and header-set-organization should work now.
  78 ;;; - Syntax highlighting now works for quoted email addresses and URLs.
  79 ;;; - *bold* words are now highlighted.
  80 ;;; - Emoticons can now be highlighted, and the default regexp,
  81 ;;;   post-emoticon-pattern, might be too enthusiastic for your taste.  In case
  82 ;;;   you're curious, I verified that gnus' smiley-ems.el works with post, but I
  83 ;;;   decided that it wasn't ideal.
  84 ;;; - post-url-text-pattern changed to post-url-pattern and made more enthusiastic.
  85 ;;;
  86 ;;; revision 1.95 2002/04/10 00:06:26 reid
  87 ;;; Fixed the regexp in post-kill-signature to not delete everything between
  88 ;;; mutt's standard forwarding lines.  post-kill-signature is called indirectly
  89 ;;; by many functions.
  90 ;;;
  91 ;;; Revision 1.9  2002/04/04 22:24:31  reid
  92 ;;; Applied a patch (not quite verbatim) from The Anarcat
  93 ;;; <anarcat@anarcat.dyndns.org> to make the entity separating siglets in
  94 ;;; `post-variable-signature-source' a regexp, `post-signature-sep-regexp'.  The
  95 ;;; default works either either the old post file format or strfiled (fortune)
  96 ;;; files.
  97 ;;;;
  98 ;;; Changed default `post-random-signature-command' to `fortune
  99 ;;; ~/.mutt/sigs.fortune'.
 100 ;;;
 101 ;;; `post-random-signature-command' should now NOT supply a fixed sig portion!
 102 ;;;
 103 ;;; (post-el-random-signature) supplied by The Anarcat to do random sig
 104 ;;; selection purely within Emacs Lisp.
 105 ;;;
 106 ;;; Revision 1.8  2002/02/06 22:24:31  eric
 107 ;;; clean up
 108 ;;;
 109 ;;; Revision 1.7.2  2002/02/06 22:17:01  eric
 110 ;;; tweak regexps, make font-lock-comment-face be post-signature-text-face
 111 ;;;
 112 ;;; Revision 1.7.1  2002/02/06 21:58:58  eric
 113 ;;; tweak regexp, change some types to regexp
 114 ;;;
 115 ;;; Revision 1.7.0  2002/02/06 21:36:56  eric
 116 ;;; hilight signatures, urls and emails
 117 ;;;
 118 ;;; Revision 1.6.3.10  1999/10/11 00:29:41  roland
 119 ;;; Corrected color quoting again: Now allows ">" in the middle of
 120 ;;; a line which is quoted twice.
 121 ;;;
 122 ;;; Revision 1.6.3.9  1999/10/08 10:43:18  roland
 123 ;;; Add third level of quoting faces.
 124 ;;; Allow super-cite name prefixes before quote signs.
 125 ;;;
 126 ;;; Revision 1.6.3.8  1999/10/08 08:39:00  roland
 127 ;;; post-font-lock-keywords now detects lines with only "> "in it
 128 ;;; correctly (merged following line into it before).
 129 ;;;
 130 ;;; Revision 1.6.3.7  1999/10/04 10:07:48  roland
 131 ;;; Add post-quote-region and post-unquote-region commands to quote and
 132 ;;; unquote a region (one level).
 133 ;;;
 134 ;;; Revision 1.6.3.6  1999/09/03 23:13:55  reid
 135 ;;; Valeriy E. Ushakov <uwe@ptc.spbu.ru> pointed out that (GNU) Emacs <20 has
 136 ;;; fewer (optional) arguments to (read-string) than what I was using to
 137 ;;; inherit the input method.  I didn't find a way off the top of my head
 138 ;;; to redefine (read-string) without causing an infinite loop, so I have
 139 ;;; substituted a macro (string-read prompt) which does the right thing,
 140 ;;; so please use it instead of read-string.
 141 ;;;
 142 ;;; Revision 1.6.3.5  1999/08/29 19:58:49  reid
 143 ;;; Changed default post-mail-message to handle hostnames with digits.
 144 ;;; Thanks to Brian D. Winters <brianw@alumni.caltech.edu>.
 145 ;;;
 146 ;;; Revision 1.6.3.4  1999/03/20 03:02:05  reid
 147 ;;; Made post compatible with emacs as far back as 19.28.1, probably
 148 ;;; farther.
 149 ;;;
 150 ;;; Revision 1.6.3.3  1999/03/16 03:14:07  reid
 151 ;;; Cleaned up post-select-signature-select-sig-from-file code.
 152 ;;;
 153 ;;; Revision 1.6.3.2  1999/03/16 03:05:12  reid
 154 ;;; Fixed alist updating.
 155 ;;;
 156 ;;; Revision 1.6.3.1  1999/03/13 02:23:48  reid
 157 ;;; Added defface to the list of things that get defined if customize
 158 ;;; hasn't already done it.  Thanks to Melissa Binde for the bug report.
 159 ;;;
 160 ;;; Modified post-body-says-attach to use a regexp,
 161 ;;; post-attachment-regexp, so that something like "\(attach\|anbringen\)"
 162 ;;; can be used by bilingual people like Roland.
 163 ;;;
 164 ;;; Revision 1.6.2.1  1999/03/12 10:16:11  roland
 165 ;;; Added missing () to post-insert-to-auto-mode-alist-on-load.
 166 ;;;
 167 ;;; Revision 1.6.2 1999/03/11 15:51 Dave Pearson
 168 ;;; header-position-on-value fixed to return (point), and
 169 ;;; defcustom macro provided for Emacs 19 users.
 170 ;;;
 171 ;;; Revision 1.6.1.2  1999/03/06 11:24:43  roland
 172 ;;; Added post-insert-to-auto-mode-alist-on-load.
 173 ;;;
 174 ;;; Revision 1.6.1.1  1999/03/06 11:02:27  roland
 175 ;;; Customized renaming of buffer.
 176 ;;; Removed different handling for mail, news, news-reply.
 177 ;;; Fixed problems with easy-menu under XEmacs.
 178 ;;;
 179 ;;; Revision 1.6.0 1999/03/04 18:04 Rob Reid
 180 ;;; Returned post-signature-pattern to using "--" instead of "-- "
 181 ;;; because some senders have broken MTAs (as Eric reminded me) and
 182 ;;; some users don't use procmail to compensate.  This time all of the
 183 ;;; functions dealing with signatures have been smartened up to avoid
 184 ;;; false matches.  Unfortunately that means they don't use
 185 ;;; post-signature-pattern in its raw form.
 186 ;;;
 187 ;;; Added post-backup-original so that Dave's post-copy-original can
 188 ;;; be used.
 189 ;;;
 190 ;;; Kevin Rodgers explained how to put this in .emacs to fix the
 191 ;;; server-process-filter's annoying message problem:
 192 ;;;
 193 ;;; Revision 1.1  1999/03/04 18:02:30  reid
 194 ;;; Initial revision
 195 ;;;
 196 ;;; %%%%%%%%%%%% Put in .emacs %%%%%%%%%%%
 197 ;;;
 198 ;;; ;;; Email
 199 ;;; (server-start)
 200 ;;; (load "/home/reid/.mutt/post")
 201 ;;; (defadvice server-process-filter (after post-mode-message first activate)
 202 ;;;    "If the buffer is in post mode, overwrite the server-edit
 203 ;;;    message with a post-save-current-buffer-and-exit message."
 204 ;;;    (if (eq major-mode 'post-mode)
 205 ;;;        (message
 206 ;;;         (substitute-command-keys "Type \\[describe-mode] for help composing; \\[post-save-current-buffer-and-exit] when done."))))
 207 ;;; ; This is also needed to see the magic message.  Set to a higher
 208 ;;; ; number if you have a faster computer or read slower than me.
 209 ;;; '(font-lock-verbose 1000)
 210 ;;; ; (setq server-temp-file-regexp "mutt-")
 211 ;;; (add-hook 'server-switch-hook
 212 ;;;         (function (lambda()
 213 ;;;                     (cond ((string-match "Post" mode-name)
 214 ;;;                            (post-goto-body))))))
 215 ;;;
 216 ;;; %%%%%%%%% We now return to our regular commentary %%%%%%%%%
 217 ;;;
 218 ;;; Eric Kidd asked that the name of Headers mode be changed so that
 219 ;;; it doesn't conflict with mutt-mode's Headers, so I changed it to
 220 ;;; just Header (no s).
 221 ;;;
 222 ;;; Revision 1.5? 1999/02/27 17:30 Rob Reid
 223 ;;; I had a go at combining Dave Pearson's post mode with Eric Kidd's
 224 ;;; Mutt mode.  Since Dave Pearson's post mode explicitly handles news as
 225 ;;; well as email, and this should be useful for more than just mutt,
 226 ;;; I'm calling it post mode.  I also added functions for picking
 227 ;;; random signatures, selecting a signature from a file, and
 228 ;;; intelligently (IMHO) prompting the user for an attachment when
 229 ;;; necessary.  Changed mutt-save-buffer-and-exit to work better with
 230 ;;; emacsclient, and some of the key bindings.  post-signature-pattern
 231 ;;; now defaults to use "-- " instead of "--", and I have far less
 232 ;;; trouble this way (I use procmail to clean up braindead "--"s.).  I
 233 ;;; don't know why Eric warned against trailing whitespace.
 234 ;;;
 235 ;;; Revision 1.4  1998/04/11 00:05:46  emk
 236 ;;; Fixed font-lock bug. Also made mutt-mode a little more careful about
 237 ;;; saving various bits of Emacs state when moving around the buffer.
 238 ;;;
 239 ;;; Revision 1.3  1998/03/25 00:37:36  emk
 240 ;;; Added support for menus and font-lock mode, plus a few bug fixes.
 241 ;;;
 242 ;;; Revision 1.2  1998/03/24 13:19:46  emk
 243 ;;; Major overhaul--more commands, a minor mode for header editing, and other
 244 ;;; desirable features. Attaching files seems to be broken, though.
 245 ;;;
 246
 247
 248 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 249 ;;;
 250 ;;; Required Packages
 251
 252 (require 'cl)
 253 (require 'derived)
 254 (require 'easymenu)
 255
 256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 257 ;;;
 258 ;;; Customization Support
 259 ;;;
 260 ;;; Set up our customizable features. You can edit these (and lots of other
 261 ;;; fun stuff) by typing M-x customize RET. The Post preferences can be
 262 ;;; found under the [Applications] [Mail] category.
 263
 264 ;; Make post mode a bit more compatible with older (i.e. <20) versions of emacs.
 265 ;;; Code:
 266 (eval-and-compile
 267   ;; Dumb down read-string if necessary.
 268   ;; The number of optional arguments for read-string seems to increase
 269   ;; sharply with (emacs-version).  Since old versions of emacs are a large
 270   ;; source of bug reports it might be worth writing (or looking for)
 271   ;; (bug-report reid@astro.utoronto.ca) which emails me the result of
 272   ;; (emacs-version) along with a user supplied description of the problem.
 273   ;; GNU Emacs 19.28.1 only has INITIAL-STRING as an optional argument.
 274   ;; 19.34.1 has (read-string PROMPT &optional INITIAL-INPUT HISTORY).  20.2.1
 275   ;; has (read-string PROMPT &optional INITIAL-INPUT HISTORY DEFAULT-VALUE
 276   ;; INHERIT-INPUT-METHOD).
 277   ;; Since I haven't found a way of redefining read-string without causing an
 278   ;; infinite loop, please use (string-read prompt).
 279   (if (< (string-to-number (substring (emacs-version)
 280                                       (string-match "[0-9]+\.[0-9]"
 281                                          (emacs-version) 5))) 20)
 282       (defmacro string-read (prompt) (` (read-string (, prompt))))
 283       (defmacro string-read (prompt)
 284         (` (read-string (, prompt) nil nil nil t))))
 285
 286   ;; XEmacs gnuserv uses slightly different functions than the GNU Emacs
 287   ;; server, and some people are still wasting time and CPU cycles by starting
 288   ;; up a new emacs each time.
 289   (cond ((fboundp 'server-edit)
 290          (fset 'post-finish 'server-edit))
 291         ((fboundp 'gnuserv-kill-buffer-function)
 292          (fset 'post-finish 'gnuserv-kill-buffer-function))
 293         (t
 294          (fset 'post-finish 'save-buffers-kill-emacs)))
 295
 296   ;; If customize isn't available just use defvar instead.
 297   (unless (fboundp 'defgroup)
 298     (defmacro defgroup  (&rest rest) nil)
 299     (defmacro defcustom (symbol init docstring &rest rest)
 300       ; The "extra" braces and whitespace are for emacs < 19.29.
 301       (` (defvar (, symbol) (, init) (, docstring))))
 302     (defmacro defface (&rest args) nil))
 303   (unless (fboundp 'buffer-substring-no-properties)
 304     (fset 'buffer-substring-no-properties 'buffer-substring)))
 305
 306 (defgroup post nil
 307   "Composing e-mail messages with Post.
 308 Emacs can run as an external editor for Mutt, the spiffy Unix mail reader
 309 du jour, or slrn, the spiffy Unix news reader du jour.  You can get
 310 Mutt from http://www.mutt.org/."
 311   :group 'mail)
 312
 313 (defcustom post-uses-fill-mode t
 314   "*Specifies whether Post should automatically wrap lines.
 315 Set this to t to enable line wrapping, and nil to disable line
 316 wrapping.  Note that if a paragraph gets messed up (the line wrapper
 317 is very primitive), you can type \\[fill-paragraph] to rewrap the paragraph."
 318   :type 'boolean
 319   :group 'post)
 320
 321 (defcustom post-mail-message "mutt-[a-z0-9]+-[0-9]+-[0-9]+\\'"
 322   "*Regular expression which matches your mailer's temporary files."
 323   :type 'string
 324   :group 'post)
 325
 326 (defcustom post-news-posting "\\.\\(followup\\|letter\\|article\\)$"
 327   "*Regular expression which matches your news reader's composition files."
 328   :type 'string
 329   :group 'post)
 330
 331 (defcustom post-backup-original nil
 332   "*Controls whether a pristine backup of the original is kept for reference."
 333   :type 'boolean
 334   :group 'post)
 335
 336 (defcustom post-signature-pattern "\\(--\\|Cheers,\\|\f\\)"
 337   "*Pattern signifying the beginning of signatures.
 338 It should not contain trailing whitespace unless you know what you're doing."
 339   :type 'regexp
 340   :group 'post)
 341
 342 (defcustom post-signature-sep-regexp "^\\(%\\|^L\\|--\\)?\n"
 343   "*Regular expression delimiting signatures in the signature file.
 344 This allows the use of classic fortune files as signature files.
 345 This should normally contain a newline."
 346   :type 'regexp
 347   :group 'post)
 348
 349 (defcustom post-signature-source-is-file t
 350   "*Toggles the signature source type between file and directory."
 351   :type 'boolean
 352   :group 'post)
 353
 354 (defcustom post-variable-signature-source "~/.mutt/sigs.fortune"
 355   "*Location of the variable part of your signature.
 356 Post uses this to locate signatures.  It can be either a directory
 357 with one item per file or a file with items separated by blank lines."
 358   :type 'string
 359   :group 'post)
 360
 361 (defcustom post-fixed-signature-source "~/.fixedsig"
 362   "*File with the fixed part of your signature."
 363   :type 'string
 364   :group 'post)
 365
 366 (defcustom post-signature-directory "~/.sigs/"
 367   "*The directory that contains your collection of signature files."
 368   :type 'string
 369   :group 'post)
 370
 371 (defcustom post-signature-wildcard "sig*"
 372   "*Wildcard for finding signature files in your signature directory."
 373   :type 'string
 374   :group 'post)
 375
 376 (defcustom post-random-signature-command "fortune ~/.mutt/sigs.fortune"
 377   "*Command to run to get a random signature.
 378 Examples are available at http://astro.utoronto.ca/~reid/mutt/"
 379   :type 'string
 380   :group 'post)
 381
 382 (defcustom post-kill-quoted-sig t
 383   "Specifies whether `post-mode' should automatically kill quoted signatures."
 384   :type 'boolean
 385   :group 'post)
 386
 387 (defcustom post-jump-header t
 388   "Specifies wheather `post-mode' should jump to the body."
 389   :type 'boolean
 390   :group 'post)
 391
 392 (defcustom post-force-pwd-to-home t
 393   "Specifies whether `post-mode' should cd to your home directory."
 394   :type 'boolean
 395   :group 'post)
 396
 397 (defcustom post-email-address (concat (user-login-name) "@" mail-host-address)
 398   "*Your email address."
 399   :type 'string
 400   :group 'post)
 401
 402 (defcustom post-should-prompt-for-attachment 'Smart
 403   "*Controls whether an attachment will be prompted for before saving
 404 the message and exiting.  'Smart' will prompt only if the body
 405 contains post-attachment-regexp."
 406   :type '(choice (const Never)
 407                  (const Smart)
 408                  (const Always))
 409   :group 'post)
 410
 411 (defcustom post-attachment-regexp "attach"
 412   "*This is what post looks for in the body if
 413 post-should-prompt-for-attachment is 'Smart'."
 414   :type 'regexp
 415   :group 'post)
 416
 417 (defcustom post-news-poster-regexp "^On .*<.*>.*wrote:$"
 418   "Regular expression used to locate the attribution line of a news posting."
 419   :type 'regexp
 420   :group 'post)
 421
 422 (defcustom post-rename-buffer t
 423   "Specify whether `post-mode' should rename the buffer to *Composing*."
 424   :type 'boolean
 425   :group 'post)
 426
 427 (defcustom post-insert-to-auto-mode-alist-on-load t
 428   "Automatically insert `post-mode' with `post-mail-message' to `auto-mode-alist'."
 429   :type 'boolean
 430   :group 'post)
 431
 432 (defcustom post-mode-hook nil
 433   "List of hooks to be executed on entry to `post-mode'."
 434   :group 'post)
 435
 436 (defcustom post-quote-start "> "
 437   "Pattern which is added (or removed) at the beginning of the line by
 438 comment-region"
 439   :group 'post)
 440
 441 (defcustom post-email-address-pattern
 442   "[A-Za-z0-9_][-A-Za-z0-9._]*@[-A-Za-z0-9._]*[A-Za-z0-9]"
 443   "Pattern to detect email addresses."
 444   :type 'regexp
 445   :group 'post)
 446
 447 (defcustom post-url-pattern
 448   '("\\<\\(\\(https?\\|news\\|mailto\\|ftp\\|gopher\\):\\|\\(www\\|ftp\\)\\.\\)[-~A-Za-z0-9._/%$+?#]+[A-Za-z0-9/#]" "<URL:[^ ]+>")
 449   "Pattern to detect URL addresses."
 450   :type '(repeat regexp)
 451   :group 'post)
 452
 453 (defcustom post-bold-pattern '("\\*\\w+\\*")
 454   "*List of regular expressions that define bold text."
 455   :type '(repeat regexp)
 456   :group 'post)
 457
 458 (defcustom post-underline-pattern '("_\\w+_")
 459   "*List of regular expressions that define underlined text."
 460   :type '(repeat regexp)
 461   :group 'post)
 462
 463 (defcustom post-emoticon-pattern '("[0O(<{}]?[;:8B|][.,]?[-+^*o0O][{<>/\|]?[][)>(<|/\P][)>]?"
 464                         "\\s [(<]?[][)>(<|/\][}<>|]?[-+^*oO0][,.]?[:8][0O>]?"
 465                         "\\s [;:][][P)\/(]" "\\s [][)(P\/][:;]"
 466                                    "<[Gg]>" "<[BbSs][Gg]>")
 467   "*List of regular expressions that define a emoticon."
 468   :type '(repeat regexp)
 469   :group 'post)
 470
 471 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 472 ;;;
 473 ;;; Customizable Faces
 474 ;;; If you find a more attractive color scheme for dark backgrounds, please
 475 ;;; email it to reid@astro.utoronto.
 476
 477 (defgroup post-faces nil
 478   "Typefaces used for composing messages with Post."
 479   :group 'post
 480   :group 'faces)
 481
 482 (defface post-header-keyword-face
 483   '((((class color)
 484       (background light))
 485      (:foreground "Navy" :bold t))
 486     (((class color)
 487       (background dark))
 488      (:foreground "LightBlue" :bold t))
 489     (t
 490      (:bold t)))
 491   "Face used for displaying keywords (e.g. \"From:\") in header."
 492   :group 'post-faces)
 493
 494 (defface post-header-value-face
 495   '((((class color)
 496       (background light))
 497      (:foreground "MidnightBlue"))
 498     (((class color)
 499       (background dark))
 500      (:foreground "LightSteelBlue")))
 501   "Face used for displaying the values of header."
 502   :group 'post-faces)
 503
 504 (defface post-quoted-text-face
 505   '((((class color)
 506       (background light))
 507      (:foreground "Sienna" :italic t))
 508     (((class color)
 509       (background dark))
 510      (:foreground "Wheat" :italic t))
 511     (t
 512      (:bold t :italic t)))
 513   "Face used for displaying text which has been quoted (e.g. \">foo\")."
 514   :group 'post-faces)
 515
 516 (defface post-double-quoted-text-face
 517   '((((class color)
 518       (background light))
 519      (:foreground "Firebrick" :italic t))
 520     (((class color)
 521       (background dark))
 522      (:foreground "Tan" :italic t))
 523     (t
 524      (:italic t)))
 525   "Face used for text which has been quoted twice (e.g. \">>foo\")."
 526   :group 'post-faces)
 527
 528 (defface post-multiply-quoted-text-face
 529   '((((class color)
 530       (background light))
 531      (:foreground "goldenrod" :italic t))
 532     (((class color)
 533       (background dark))
 534      (:foreground "tan3" :italic t))
 535     (t
 536      (:italic t)))
 537   "Face used for text which has been quoted more than twice (e.g. \">>>foo\")."
 538   :group 'post-faces)
 539
 540 (defface post-signature-text-face
 541   '((((class color)
 542       (background light))
 543      (:foreground "red3"))
 544     (((class color)
 545       (background dark))
 546      (:foreground "red1"))
 547     (t
 548      (:bold t)))
 549   "Face used for text that is part of a signature"
 550   :group 'post-faces)
 551
 552 (defface post-email-address-text-face
 553   '((((class color)
 554       (background light))
 555      (:foreground "green3"))
 556     (((class color)
 557       (background dark))
 558      (:foreground "green1"))
 559     (t
 560      (:italic t)))
 561   "Face used for email addresses"
 562   :group 'post-faces)
 563
 564 (defface post-url-face
 565   '((((class color)
 566       (background light))
 567      (:foreground "green3" :bold t))
 568     (((class color)
 569       (background dark))
 570      (:foreground "green1" :bold t))
 571     (t
 572      (:italic t)))
 573   "Face used for URL addresses"
 574   :group 'post-faces)
 575
 576 (defface post-emoticon-face
 577   '((((class color)
 578       (background light))
 579      (:foreground "black" :background "yellow" :bold t))
 580     (((class color)
 581       (background dark))
 582      (:foreground "black" :background "yellow" :bold t))
 583     (t
 584      (:bold t)))
 585   "Face used for text matched by post-emoticon-pattern."
 586   :group 'post-faces)
 587
 588 (defface post-bold-face
 589   '((((class color)
 590       (background light))
 591      (:bold t))
 592     (((class color)
 593       (background dark))
 594      (:bold t))
 595     (t
 596      (:bold t)))
 597   "Face used for text matching post-bold-pattern."
 598   :group 'post-faces)
 599
 600 (defface post-underline-face
 601   '((((class color)
 602       (background light))
 603      (:underline t))
 604     (((class color)
 605       (background dark))
 606      (:underline t))
 607     (t
 608      (:underline t)))
 609   "Face used for text matching post-underline-pattern."
 610   :group 'post-faces)
 611
 612 ; Note: some faces are added later!
 613 (defvar post-font-lock-keywords
 614   `(("^\\([A-Z][-A-Za-z0-9.]+:\\)\\(.*\\)$"
 615      (1 'post-header-keyword-face)
 616      (2 'post-header-value-face))
 617     ("^[ \t\f]*\\(>[ \t\f]*\\)\\([-a-zA-Z]*>[ \t\f]*\\)\\([-a-zA-Z]*>.*\\)$"
 618      (1 'post-quoted-text-face)
 619      (2 'post-double-quoted-text-face)
 620      (3 'post-multiply-quoted-text-face))
 621     ("^[ \t\f]*\\(>[ \t\f]*\\)\\([-a-zA-Z]*>.*\\)$"
 622      (1 'post-quoted-text-face)
 623      (2 'post-double-quoted-text-face))
 624     ("^[ \t\f]*\\(>[ \t\f]*[^ \t\f\n>].*\\)$"
 625      (1 'post-quoted-text-face))
 626     ("^[ \t\f]*\\(>[ \t\f]*\\)$"
 627      (1 'post-quoted-text-face))
 628         (,post-email-address-pattern
 629          (0 'post-email-address-text-face)))
 630   "Highlighting rules for message mode.")
 631
 632 ;;; Declare global mode variables.
 633
 634 (defconst post-font-lock-syntactic-keywords
 635   `((,(concat "^" post-signature-pattern "[ \t\f]*$") 0 '(11))))
 636
 637 (defun post-font-lock-syntactic-face-function (state)
 638   "Function for font locking syntactic faces.
 639 Argument STATE ."
 640 post-signature-text-face)
 641
 642 (defvar post-buf nil
 643   "Name of the composing buffer.")
 644
 645 (defvar post-select-signature-mode-map nil
 646   "Local keymap for the select-signature buffer.")
 647
 648 (defvar post-select-signature-last-buffer nil
 649   "Pointer to the calling buffer.")
 650
 651 (defvar post-select-signature-last-point nil
 652   "Where we were in the calling buffer.")
 653
 654 (defvar post-has-attachment nil
 655  "Whether the message has an attachment.")
 656
 657 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 658 ;;;
 659 ;;; Interactive Commands
 660
 661 (defun post-save-current-buffer-and-exit ()
 662   "Save the current buffer and exit Emacs."
 663   (interactive)
 664
 665   ;; Should the user be prompted for an attachment?
 666   (cond (post-has-attachment)
 667         ((equal post-should-prompt-for-attachment 'Never))
 668         ((or (equal post-should-prompt-for-attachment 'Always)
 669              (post-body-says-attach))
 670          (post-prompt-for-attachment)))
 671
 672   (basic-save-buffer)
 673
 674   (if post-backup-original
 675       (kill-buffer "*Original*"))
 676
 677   (post-finish)
 678
 679   ;; Added by Rob Reid 10/13/1998 to prevent accumulating *Composing* buffers
 680   ;; when using (emacs|gnu)client.  Helped by Eric Marsden's Eliza example in
 681   ;; http://www.ssc.com/lg/issue29/marsden.html
 682   (kill-buffer post-buf))
 683
 684 (defun post-goto-body ()
 685   "Go to the beginning of the message body."
 686   (interactive)
 687   (goto-char (point-min))
 688   ;; If the message has header, slide downward.
 689   (and header-mode (save-match-data (re-search-forward "^$" nil t))
 690        (next-line 1)))
 691
 692 (defun post-goto-signature ()
 693   "Go to the beginning of the message signature."
 694   (interactive)
 695   (goto-char (point-max))
 696   (and (save-match-data
 697          (re-search-backward (concat "^" post-signature-pattern
 698                                      "[ \t\f]*$")
 699                              nil t))))
 700
 701 (defun post-delete-quoted-signatures ()
 702   "Delete quoted signatures from buffer."
 703   (interactive)
 704   (goto-char (point-min))
 705   (flush-lines (concat "^\\([ \t\f]*>[ \t\f>]*\\)"
 706                        post-signature-pattern
 707                        "[ \t\f]*\\(\n\\1.*\\)+")))
 708
 709 (defun post-kill-signature ()
 710   "Kill the signature from the buffer.
 711 Returns the point value for where the signature was or, if there isn't a
 712 signature, the point value of the end of the buffer"
 713   (interactive)
 714   (save-excursion
 715     (goto-char (point-min))
 716 ; The .=*+|#@!~$%&()_- is to compensate for people who put ASCII art on the
 717 ; same line as the sigdashes, and the $ at the end prevents this from deleting
 718 ; everything between mutt's standard forwarding lines.
 719     (cond ((search-forward-regexp (concat "^" post-signature-pattern
 720                                           "[ \t\f.=*+|#@!~$%&()_-]*$") nil t)
 721            (beginning-of-line)
 722            (kill-region (point) (point-max)))
 723           (t
 724            (goto-char (point-max))))
 725     (point)))
 726
 727 (defun post-delete-old-citations ()
 728   "Delete citations more than one level deep from buffer."
 729   (interactive)
 730   (goto-char (point-min))
 731   (flush-lines "^[ \t\f]*>[ \t\f]*>[ \t\f>]*"))
 732
 733 ;;; Functions for messing with the body
 734
 735 (defun post-make-region-bold (start end)
 736   "Apply mutt's nroff style bold to a region of text.
 737 Argument START start of region.
 738 Argument END end of region."
 739   (interactive "r")
 740   (while (< start end)
 741     (goto-char start)
 742     (insert (buffer-substring-no-properties start (1+ start)))
 743     (insert (char-to-string 8))
 744     (setq start (+ start 3))
 745     (setq end   (+ end   2))))
 746
 747 (defun post-make-region-underlined (start end)
 748   "Apply mutt's nroff style underline to a region of text.
 749 Argument START start of region.
 750 Argument END end of region."
 751   (interactive "r")
 752   (while (< start end)
 753     (goto-char start)
 754     (insert "_")
 755     (insert (char-to-string 8))
 756     (setq start (+ start 3))
 757     (setq end   (+ end   2))))
 758
 759 (defun post-quote-region (beg end)
 760   "Quote a region using the `post-quote-start' variable.
 761 Argument BEG Beginning of region to be quoted.
 762 Argument END End of region to be quoted."
 763   (interactive "r")
 764   (comment-region beg end))
 765
 766 (defun post-unquote-region (beg end)
 767   "Un-quote a region one level using the `post-quote-start' variable.
 768 Argument BEG Beginning of region to be quoted.
 769 Argument END End of region to be quoted."
 770   (interactive "r")
 771   (uncomment-region beg end))
 772
 773 ; From Dave Pearson, July 15, 2000
 774 (defun* split-quoted-paragraph (&optional (quote-string "> "))
 775   "Split a quoted paragraph at point, keeping the quote."
 776   (interactive)
 777   (if (save-excursion
 778         (beginning-of-line)
 779         (looking-at (regexp-quote quote-string)))
 780       (progn
 781         (let ((spaces (- (point)
 782                          (save-excursion
 783                            (beginning-of-line)
 784                            (point))
 785                          (length quote-string))))
 786           (save-excursion
 787             (insert (format "\n\n%s%s" quote-string (make-string spaces ? ))))))
 788     (error "Can't see a quoted paragraph here")))
 789
 790 (defun post-random-signature ()
 791   "Randomize the signature.
 792 Set it to whatever `post-random-signature-command' spits out followed by the
 793 content of `post-fixed-signature-source', if available, or a nasty reminder if
 794 it is not."
 795   (interactive)
 796   (save-excursion
 797     (goto-char (post-kill-signature))
 798     (insert "-- \n")
 799     (shell-command post-random-signature-command t)
 800     (goto-char (point-max))
 801     (if (file-readable-p post-fixed-signature-source)
 802         (insert-file-contents post-fixed-signature-source)
 803       (insert "I really need a `post-fixed-signature-source'!\n"))))
 804
 805 (defun post-el-random-signature ()
 806   "Choose a random signature from `post-variable-signature-source'.
 807 the signatures in `post-variable-signature-source' must be separated by
 808 `post-signature-sep-regexp'."
 809   (interactive)
 810   (let ((sig nil))
 811     (save-excursion
 812       (set-buffer (generate-new-buffer "*Post-Select-Signature*"))
 813       (insert-file post-variable-signature-source)
 814       (beginning-of-buffer)
 815       ;; we have 2 lists of marks since seperators are of arbitrary lenght
 816       (let ((marks-st (list (point-min)))
 817             (marks-end (list))
 818             (count 0))          ;nth counts from zero and random is [0,N)
 819         (while (search-forward-regexp post-signature-sep-regexp nil "a")
 820           (setq marks-st (cons (match-end 0) marks-st)
 821                 marks-end (cons (match-beginning 0) marks-end)
 822                 count (1+ count)))
 823         (setq marks-end (cons (point-max) marks-end))
 824         (let ((r (random (1+ count))))
 825           (setq sig (buffer-substring-no-properties
 826                      (nth r marks-st) (nth r marks-end))))
 827         (kill-buffer (current-buffer)))
 828       (goto-char (post-kill-signature))
 829       (insert-string "-- \n")
 830       (insert sig)
 831       (if (file-readable-p post-fixed-signature-source)
 832           (insert-file-contents post-fixed-signature-source)
 833         (insert "I really need a `post-fixed-signature-source'!\n")))))
 834
 835 (defun post-select-signature-from-file ()
 836   "*Interactively select a signature from `post-variable-signature-source'."
 837   (interactive)
 838   (setq post-select-signature-last-buffer (current-buffer))
 839   (setq post-select-signature-last-point (point))
 840   (pop-to-buffer "*Post-Select-Signature*")
 841   (insert-file post-variable-signature-source)
 842   (use-local-map post-select-signature-mode-map))
 843
 844 (defun post-select-signature-select-sig-from-file ()
 845  "*Chooses the signature the cursor is in from `post-variable-signature-source'."
 846   (interactive)
 847
 848   ;; These 2 lines select whatever siglet the cursor is sitting in,
 849   ;; making it nifty to C-s "word" then C-m (or whatever this is
 850   ;; bound to).
 851   (let ((sig-start (point))
 852         (sig-end (point)))
 853
 854     (cond ((setq sig-start (search-backward-regexp post-signature-sep-regexp
 855                                                    nil "a"))
 856            (forward-line 1)
 857            (setq sig-start (point))))
 858
 859     (if (search-forward-regexp post-signature-sep-regexp nil "a")
 860         (setq sig-end (match-beginning 0))
 861       (setq sig-end (point-max)))
 862
 863     (let ((sig (buffer-substring-no-properties sig-start sig-end)))
 864       (switch-to-buffer post-select-signature-last-buffer)
 865       (goto-char (post-kill-signature))
 866       (insert-string "-- \n")
 867       (insert sig))
 868     (if (file-readable-p post-fixed-signature-source)
 869         (insert-file-contents post-fixed-signature-source))
 870     (post-select-signature-quit)))
 871
 872 (defun post-select-signature-from-dir ()
 873   "Select a new signature for an email/post in the current buffer."
 874   (interactive)
 875   (setq post-select-signature-last-buffer (current-buffer))
 876   (setq post-select-signature-last-point (point))
 877   (pop-to-buffer "*Post-Select-Signature*")
 878   (list-directory (concat post-signature-directory
 879                           post-signature-wildcard) t)
 880   (pop-to-buffer "*Directory*")
 881   (next-line 1)
 882   (copy-to-buffer "*Post-Select-Signature*" (point) (point-max))
 883   (kill-buffer "*Directory*")
 884   (pop-to-buffer "*Post-Select-Signature*")
 885   (use-local-map post-select-signature-mode-map)
 886   (toggle-read-only t))
 887
 888 (defun post-select-signature-select-sig-from-dir ()
 889   "Set the signature in the calling buffer to the one under the cursor."
 890   (interactive)
 891   (let ((sig-start   nil)
 892         (sig-to-load nil))
 893     (end-of-line)
 894     (search-backward " ")
 895     (forward-char)
 896     (setq sig-start (point))
 897     (end-of-line)
 898     (setq sig-to-load (buffer-substring-no-properties sig-start (point)))
 899     (switch-to-buffer post-select-signature-last-buffer)
 900     (goto-char (post-kill-signature))
 901     (insert-string "-- \n")
 902     (insert-file (concat post-signature-directory sig-to-load))
 903     (message "Signature set to %s%s" post-signature-directory sig-to-load)
 904     (post-select-signature-quit)))
 905
 906 (defun post-select-signature-quit ()
 907   "Kill the *Post-Select-Signature* frame."
 908   (interactive)
 909   (kill-buffer "*Post-Select-Signature*")
 910   (switch-to-buffer post-select-signature-last-buffer)
 911   (goto-char post-select-signature-last-point)
 912   (delete-other-windows))
 913
 914 ;;; Non-interactive functions
 915
 916 (defun post-ask-for-address-with-default (header)
 917   "Prompt for an email address, showing default.
 918 Argument HEADER the header type."
 919   (let ((default (if (= (length (post-get-header-value header)) 0)
 920                      post-email-address
 921                    (post-get-header-value header))))
 922     (read-string (concat header ": ") default)))
 923
 924 ; From davep@davep.org.  RR hasn't tested it.
 925 (defun post-get-header-value (header)
 926   "Get the value of a specific mail HEADER."
 927   (save-excursion
 928     (let ((value          "")
 929           (start-of-value nil))
 930       (setf (point) (point-min))
 931       (when (post-find-header-line header)
 932         (setq start-of-value (point))
 933         (end-of-line)
 934         (setq value (buffer-substring-no-properties start-of-value (point))))
 935       value)))
 936
 937 ;;; From davep@davep.org.  RR hasn't tested it.
 938 (defun post-find-header-line (header)
 939   "Find a HEADER line in the header."
 940   (let ((old-point (point))
 941         (end-of-header nil)
 942         (found-point nil))
 943     (setf (point) (point-min))
 944     (search-forward-regexp "^$" nil t)
 945     (setq end-of-header (point))
 946     (setf (point) (point-min))
 947     (cond ((search-forward-regexp (concat "^" header ": ") nil t)
 948            (cond ((< (point) end-of-header)
 949                   (setq found-point (point)))
 950                  (t
 951                   (setf (point) old-point))))
 952           (t
 953            (setf (point) old-point)))
 954     found-point))
 955
 956 ;;; Function to make a backup buffer for viewing the original.
 957 (defun post-copy-original ()
 958   "Make a copy of the `post-mode' buffer before any editing by the user.
 959 This way they can refer back to this buffer during a compose session."
 960   (copy-to-buffer (get-buffer-create "*Original*")
 961                   (point-min) (point-max)))
 962
 963 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 964 ;;;
 965 ;;; The Heart of Darkness
 966 ;;;
 967 ;;; The old post mode (i.e. Dave Pearson's) derived from mail-mode.  I
 968 ;;; prefer deriving from text mode like mutt mode did. - RR
 969 (define-derived-mode post-mode text-mode "Post"
 970   "Major mode for composing email or news with an external agent.
 971 To customize it, type \\[customize] and select [Applications] [Mail] [Post].
 972 When you finish editing this message, type \\[post-save-current-buffer-and-exit] to save and exit Emacs.
 973
 974 \\{post-mode-map}"
 975
 976 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 977 ;;;
 978 ;;; Neat things to do right off the bat.
 979
 980   (auto-fill-mode (if post-uses-fill-mode 1 0))
 981
 982   (if post-backup-original (post-copy-original))
 983
 984   ;; Make Emacs smarter about wrapping citations and paragraphs.
 985   ;; We probably can't handle Supercited messages, though.
 986   (make-local-variable 'paragraph-start)
 987   (make-local-variable 'paragraph-separate)
 988   (setq paragraph-start
 989         "\\([ \t\n\f]+[^ \t\n\f>]\\|[ \t\f>]*$\\)"
 990         paragraph-separate
 991         "[ \t\f>]*$")
 992
 993   ;; XEmacs needs easy-menu-add, Emacs does not care
 994   (easy-menu-add post-mode-menu)
 995
 996   ;; If headers were passed, activate the necessary commands.
 997   (when (looking-at "^[-A-Za-z0-9]+:")
 998     (header-mode 1))
 999
1000   ;; Our temporary file lives in /tmp. Yuck! Compensate appropriately.
1001   (make-local-variable 'backup-inhibited)
1002   (setq backup-inhibited t)
1003
1004   (if (boundp 'font-lock-defaults)
1005       (make-local-variable 'font-lock-defaults))
1006   (flet ((add-syntax-highlight (face regexps)
1007             (set face face)
1008             (nconc post-font-lock-keywords
1009                    (loop for regexp in regexps
1010                          collect (list regexp (list 0 face 't))))))
1011 ;                        collect (list regexp `(,0 ',face))))))
1012     (add-syntax-highlight 'post-emoticon-face post-emoticon-pattern)
1013     (add-syntax-highlight 'post-bold-face   post-bold-pattern)
1014     (add-syntax-highlight 'post-underline-face   post-underline-pattern)
1015     (add-syntax-highlight 'post-url-face    post-url-pattern))
1016   (setq font-lock-defaults
1017         '(post-font-lock-keywords nil nil nil nil
1018                                   (font-lock-syntactic-keywords
1019                                    . post-font-lock-syntactic-keywords)
1020                                   (font-lock-comment-face
1021 ;                                  . 'post-signature-text-face)))
1022                                    . post-signature-text-face)))
1023
1024   ;; Force pwd to home directory if so required.
1025   (cond (post-force-pwd-to-home
1026          (cd "~")))
1027
1028   ;; Kill quoted sig if so required.
1029   (cond (post-kill-quoted-sig
1030          (post-delete-quoted-signatures)
1031          (not-modified)))
1032
1033   ;; Remap signature selection functions according to whether the
1034   ;; signatures are stored in a file or directory.
1035   (if post-signature-source-is-file
1036       (progn
1037         (defalias 'post-select-signature 'post-select-signature-from-file)
1038         (defalias 'post-select-signature-select-sig
1039           'post-select-signature-select-sig-from-file))
1040     (progn
1041       (defalias 'post-select-signature 'post-select-signature-from-dir)
1042       (defalias 'post-select-signature-select-sig
1043         'post-select-signature-select-sig-from-dir)))
1044
1045   ;; Define mutt/slrn specific key bindings.
1046   (define-key (current-local-map) "\C-c\C-b"     'post-make-region-bold)
1047   (define-key (current-local-map) "\C-c\C-u"     'post-make-region-underlined)
1048   (define-key (current-local-map) "\C-c\C-q"     'post-quote-region)
1049   (define-key (current-local-map) "\C-c\C-d\C-q" 'post-unquote-region)
1050   (define-key (current-local-map) "\C-c\C-a"     'post-attach-file)
1051   (define-key (current-local-map) "\C-c\C-p"     'post-set-return-receipt-to)
1052
1053   ;; Give the buffer a handy name.
1054   (if post-rename-buffer
1055       (setq post-buf (rename-buffer "*Composing*" t)))
1056
1057   ;; If this is a news posting, check the length of the References field.
1058   (if (post-references-p)
1059       (header-check-references))
1060
1061   ;; Define the quote signs as comments to make comment-region usable.
1062   (make-local-variable 'comment-start)
1063   (setq comment-start post-quote-start)
1064
1065   ;; Run any hooks.
1066   (run-hooks 'post-mode-hook)
1067
1068   ;; Jump past header if so required.
1069   (cond (post-jump-header
1070          (post-goto-body)))
1071
1072   (unless (fboundp 'server-process-filter)
1073     (message (substitute-command-keys
1074      "Type \\[describe-mode] for help composing; \\[post-save-current-buffer-and-exit] when done."))))
1075
1076 (defun post-references-p ()
1077   "Is there a References header in this buffer?"
1078   (save-excursion
1079     (goto-char (point-min))
1080     (looking-at "^References: ")))
1081
1082 (defun post-body-says-attach ()
1083   "Check if attach appears in the body."
1084   (post-goto-body)
1085
1086   ;; Aargh it's annoying that how-many returns a string,
1087   ;; "13 occurences" instead of a number, 13.
1088   (let ((total-attach (string-to-int (how-many post-attachment-regexp))))
1089     ;; And this mess is just to catch the unlikely false alarm of
1090     ;; "attach" being in the signature, but not in the body.
1091     (if (> total-attach 0)
1092         (progn (post-goto-signature)
1093                (> total-attach (string-to-int (how-many
1094                                                post-attachment-regexp)))))))
1095
1096 (defun post-prompt-for-attachment ()
1097   "Prompt for an attachment."
1098    (if (y-or-n-p "Do you want to attach anything? ")
1099        (let ((file (read-file-name "Attach file: " nil nil t nil))
1100              (description (string-read "Description: ")))
1101          (header-attach-file file description))))
1102
1103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1104 ;;;
1105 ;;; Post Header Mode
1106
1107 (defvar header-mode nil)
1108
1109 (defun header-mode (&optional arg)
1110   "Commands for editing the header of an e-mail or news message.
1111
1112 \\{header-mode-map}
1113 Optional argument ARG ."
1114
1115   (interactive "P")
1116   (make-local-variable 'header-mode)
1117   (setq header-mode
1118         (if (null arg)
1119             (not header-mode)
1120           (> (prefix-numeric-value arg) 0)))
1121   (setq post-has-attachment nil)
1122
1123   ;; XEmacs needs easy-menu-add, Emacs does not care
1124   (easy-menu-add header-mode-menu)
1125
1126   (force-mode-line-update))
1127
1128 (defvar header-mode-map (make-sparse-keymap)
1129   "Keymap used for editing RFC822 header.")
1130
1131 (defun header-position-on-value ()
1132   "Go to the start of the value part of a header."
1133   (beginning-of-line)
1134   (skip-chars-forward "-A-Za-z0-9:")
1135   ;; XXX - Should make sure we stay on line.
1136   (forward-char)
1137   (point))
1138
1139 (defun header-goto-field (field)
1140   "Go to FIELD of a header."
1141   (let ((case-fold-search t))
1142     (goto-char (point-min))
1143     (save-match-data
1144       (when (re-search-forward (concat "^\\($\\|" field ": \\)"))
1145         (if (looking-at "^$")
1146             (progn
1147               (insert-string field ": \n")
1148               (forward-char -1))
1149           (header-position-on-value))))))
1150
1151 (defmacro define-header-goto (name header)
1152   "Define functions called NAME to go to HEADER."
1153   `(defun ,name ()
1154      ,(concat "Position the cursor on the " header ": header.")
1155      (interactive)
1156      (header-goto-field ,header)))
1157
1158 (define-header-goto header-goto-to "To")
1159 (define-header-goto header-goto-cc "Cc")
1160 (define-header-goto header-goto-fcc "Fcc")
1161 (define-header-goto header-goto-summary "Summary")
1162 (define-header-goto header-goto-keywords "Keywords")
1163 (define-header-goto header-goto-subject "Subject")
1164 (define-header-goto header-goto-bcc "Bcc")
1165 (define-header-goto header-goto-reply-to "Reply-To")
1166 (define-header-goto header-goto-from "From")
1167 (define-header-goto header-goto-organization "Organization")
1168
1169 (defun header-attach-file (file description)
1170   "Attach a FILE to the current message (works with Mutt).
1171 Argument DESCRIPTION MIME description."
1172   (interactive "fAttach file: \nsDescription: ")
1173   (when (> (length file) 0)
1174     (save-excursion
1175       (save-match-data
1176         (save-restriction
1177           (widen)
1178           (goto-char (point-min))
1179           (search-forward-regexp "^$")
1180           (insert-string (concat "Attach: " (file-truename file) " "
1181                                  description "\n"))
1182           (message (concat "Attached '" file "'."))
1183           (setq post-has-attachment t))))))
1184
1185 (or (assq 'header-mode minor-mode-alist)
1186     (setq minor-mode-alist
1187           (cons '(header-mode " Header") minor-mode-alist)))
1188
1189 (or (assq 'header-mode minor-mode-map-alist)
1190     (setq minor-mode-map-alist
1191           (cons (cons 'header-mode header-mode-map)
1192                 minor-mode-map-alist)))
1193
1194 (defun header-set-return-receipt-to (address)
1195   "Insert a Return-Receipt-To header into an email.
1196 Argument ADDRESS email address return receipts should be sent to."
1197   (interactive (list (post-ask-for-address-with-default "Return-Receipt-To")))
1198   (save-excursion
1199     (header-set-value "Return-Receipt-To" address)))
1200
1201 (defun post-news-posting-p ()
1202   "Does the buffer look like a news posting?"
1203   (save-excursion
1204     (setf (point) (point-min))
1205     (looking-at "^Newsgroups: ")))
1206
1207 (defun header-set-followup-to (to)
1208   "Set the Followup-To: header.
1209 Argument TO Where followups should go."
1210   (interactive (list (header-ask-for-value "Followup-To"
1211                                            (header-ask-for-value
1212                                             "Newsgroups"))))
1213   (cond ((post-news-posting-p)
1214          (save-excursion
1215            (header-set-value "Followup-To" to)))
1216         (t
1217          (error
1218   "Followup-To is for Usenet.  Maybe you want Reply-To or Mail-Followup-To"))))
1219
1220 (defun header-set-organization (org)
1221   "Set the Organization: header.
1222 Argument ORG Should be SMERSH."
1223   (interactive (list (header-ask-for-value "Organization")))
1224   (save-excursion
1225     (header-set-value "Organization" org)))
1226
1227 (defun header-check-references ()
1228   "Place the cursor at the start of the References: if they are too long."
1229   (interactive)
1230   (cond ((> (header-references-length) 500) ; 500 to be on the safe side.
1231          (beep)                              ; Catch my attention.
1232          (goto-char (point-min))
1233          (search-forward-regexp "^References: " nil t))))
1234
1235 (defun header-references-length (&optional show)
1236   "Get (and optionally display) the length of the references header.
1237 Optional argument SHOW Whether or not to display the length."
1238   (interactive)
1239   (let* ((header "References")
1240          (refs (header-get-value header))
1241          (len (+ (length header) (length refs) 2)))
1242     (if (or (interactive-p) show)
1243         (message "References header is %d characters in length." len))
1244     len))
1245
1246 (defun header-delete-reference ()
1247   "Delete the first reference in the references header."
1248   (interactive)
1249   (save-excursion
1250     (let ((ref-location (header-goto-field "References")))
1251       (cond (ref-location
1252              (let ((ref-start (goto-char ref-location)))
1253                (cond ((search-forward ">" nil t)
1254                       (forward-char 1)
1255                       (delete-region ref-start (point))
1256                       (header-references-length t)))))))))
1257
1258 ;; Noninteractive functions.
1259
1260 (defun header-ask-for-value (header &optional default)
1261   "Ask for a HEADER value, defaulting to the current value if one is present.
1262 Optional argument DEFAULT ."
1263   (let ((new-value (post-get-header-value header)))
1264     (and (= (length new-value) 0)
1265          default
1266          (setq new-value default))
1267     (read-string (concat header ": ") new-value)))
1268
1269 (defun header-get-value (header)
1270   "Get the value of a specific mail HEADER."
1271   (save-excursion
1272     (let ((value          "")
1273           (start-of-value nil))
1274       (goto-char (point-min))
1275       (cond ((post-find-header-line header)
1276              (setq start-of-value (point))
1277              (end-of-line)
1278              (setq value (buffer-substring-no-properties
1279                           start-of-value (point)))))
1280       value)))
1281
1282 (defun header-set-value (header value)
1283   "Set VALUE of a HEADER (replacing any existing value)."
1284   (let ((kill-ring kill-ring))
1285     (setf (point) (point-min))
1286     (cond ((post-find-header-line header)
1287            (beginning-of-line)
1288            (kill-line)
1289            (insert-string (concat header ": " value)))
1290           (t
1291            (header-append-value header value))))
1292   (message "%s set to %s" header value))
1293
1294 (defun header-append-value (header value)
1295   "Add a HEADER and set it's VALUE (if header exists, will add multiple headers)."
1296   (goto-char (point-min))
1297   (search-forward-regexp "^$" nil t)
1298   (insert-string (concat header ": " value "\n")))
1299
1300 ;;; Setup the mode map for the select-signature buffer.
1301 (if post-select-signature-mode-map nil
1302   (setq post-select-signature-mode-map (make-sparse-keymap))
1303   (define-key post-select-signature-mode-map "\C-m"
1304     'post-select-signature-select-sig)
1305   (define-key post-select-signature-mode-map " "
1306     'post-select-signature-select-sig)
1307   (define-key post-select-signature-mode-map "q" 'post-select-signature-quit)
1308   (define-key post-select-signature-mode-map "\C-g"
1309     'post-select-signature-quit))
1310
1311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1312 ;;;
1313 ;;; Key Bindings
1314
1315 (define-key post-mode-map "\C-c\C-c" 'post-save-current-buffer-and-exit)
1316 (define-key post-mode-map "\C-c\C-d\C-s" 'post-delete-quoted-signatures)
1317 (define-key post-mode-map "\C-c\C-d\C-c" 'post-delete-old-citations)
1318 (define-key post-mode-map "\C-c\C-t" 'post-goto-body)
1319 (define-key post-mode-map "\C-c\C-e" 'post-goto-signature)
1320 (define-key post-mode-map "\C-c\C-r" 'post-random-signature)
1321 (define-key post-mode-map "\C-c\C-b" 'post-make-region-bold)
1322 (define-key post-mode-map "\C-c\C-u" 'post-make-region-underlined)
1323 (define-key post-mode-map "\C-c\C-q" 'post-quote-region)
1324 (define-key post-mode-map "\C-c\C-d\C-q" 'post-unquote-region)
1325 (define-key post-mode-map "\C-c\C-s" 'post-select-signature)
1326
1327 (define-key header-mode-map "\C-c\C-f\C-t" 'header-goto-to)
1328 (define-key header-mode-map "\C-c\C-f\C-c" 'header-goto-cc)
1329 (define-key header-mode-map "\C-c\C-f\C-w" 'header-goto-fcc)
1330 (define-key header-mode-map "\C-c\C-f\C-u" 'header-goto-summary)
1331 (define-key header-mode-map "\C-c\C-f\C-k" 'header-goto-keywords)
1332 (define-key header-mode-map "\C-c\C-f\C-s" 'header-goto-subject)
1333 (define-key header-mode-map "\C-c\C-f\C-b" 'header-goto-bcc)
1334 (define-key header-mode-map "\C-c\C-f\C-r" 'header-goto-reply-to)
1335 (define-key header-mode-map "\C-c\C-f\C-f" 'header-goto-from)
1336 (define-key header-mode-map "\C-c\C-f\C-o" 'header-goto-organization)
1337 (define-key header-mode-map "\C-c\C-ff"    'header-set-followup-to)
1338 (define-key header-mode-map "\C-c\C-a"     'header-attach-file)
1339 (define-key header-mode-map "\C-c\C-fd"    'header-delete-reference)
1340
1341 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1342 ;;;
1343 ;;; Menus
1344
1345 (easy-menu-define
1346  post-mode-menu post-mode-map "Post Message Composition Commands."
1347  '("Post"
1348    ["Delete quoted signatures" post-delete-quoted-signatures t]
1349    ["Delete doubly quoted text" post-delete-old-citations t]
1350    "----"
1351    ["Go to body of message" post-goto-body t]
1352    ["Go to signature of message" post-goto-signature t]
1353    ["Get new random signature" post-random-signature t]
1354    ["Select new signature" post-select-signature t]
1355    "----"
1356    ["Embolden region" post-make-region-bold t]
1357    ["Underline region" post-make-region-underlined t]
1358    "----"
1359    ["Quote region" post-quote-region t]
1360    ["Unquote region" post-unquote-region t]
1361    "----"
1362    ["Save message and return from Post" post-save-current-buffer-and-exit t]))
1363
1364 (easy-menu-define
1365  header-mode-menu header-mode-map "Header Editing Commands."
1366  '("Header"
1367    ["Attach File..." header-attach-file t]
1368    "----"
1369    ["Edit From Header" header-goto-from t]
1370    ["Edit Subject Header" header-goto-subject t]
1371    ["Edit To Header" header-goto-to t]
1372    ["Edit Cc Header" header-goto-cc t]
1373    ["Edit Bcc Header" header-goto-bcc t]
1374    ["Edit Fcc Header" header-goto-fcc t]
1375    ["Edit Reply-To Header" header-goto-reply-to t]
1376    ["Edit Summary Header" header-goto-summary t]
1377    ["Edit Keywords Header" header-goto-keywords t]
1378    ["Edit Organization Header" header-goto-organization t]))
1379
1380
1381 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1382 ;;;
1383 ;;; Finish Installing Post Mode
1384
1385 (when post-insert-to-auto-mode-alist-on-load
1386   (unless (assq post-mail-message auto-mode-alist)
1387     (setq auto-mode-alist
1388           (cons (cons post-mail-message 'post-mode)
1389                 auto-mode-alist)))
1390   (unless (assq post-news-posting auto-mode-alist)
1391     (setq auto-mode-alist
1392           (cons (cons post-news-posting 'post-mode)
1393                 auto-mode-alist))))
1394
1395 (provide 'post)
1396
1397 ;;; post.el ends here