emacs_el/post.el

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