emacs_el/tiny-tools/tiny/tinymailbox.el

   1 ;;; tinymailbox.el --- Berkeley style aka std. mailbox browsing minor mode
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1997-2007 Jari Aalto
   8 ;; Keywords:        tools
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinymailbox-version.
  13 ;; Look at the code with folding.el.
  14
  15 ;; This program is free software; you can redistribute it and/or modify it
  16 ;; under the terms of the GNU General Public License as published by the Free
  17 ;; Software Foundation; either version 2 of the License, or (at your option)
  18 ;; any later version.
  19 ;;
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  22 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  23 ;; for more details.
  24 ;;
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with program; see the file COPYING. If not, write to the
  27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  28 ;; Boston, MA 02110-1301, USA.
  29 ;;
  30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  31
  32 ;;}}}
  33 ;;{{{ Install
  34
  35 ;; ....................................................... &t-install ...
  36 ;;  Put this file on your Emacs-Lisp load path, add following into your
  37 ;;  ~/.emacs startup file. Code can be extracted with function
  38 ;;  tinylib.el/ti::package-rip-magic
  39 ;;
  40 ;;      (add-hook 'tinymailbox-:load-hook 'tinymailbox-install)
  41 ;;      (require 'tinymailbox)
  42 ;;
  43 ;;  Or you can also use the preferred way: autoload
  44 ;;
  45 ;;      (add-hook 'tinymailbox-:load-hook 'tinymailbox-install)
  46 ;;      (autoload 'tinymailbox-mode          "tinymailbox "" t)
  47 ;;      (autoload 'turn-on-tinymailbox-mode  "tinymailbox "" t)
  48 ;;      (autoload 'turn-off-tinymailbox-mode "tinymailbox "" t)
  49 ;;
  50 ;;  You can toggle the mode with `M-x' `tinymailbox-mode'. The default
  51 ;;  mailbox type files are liested in `tinymailbox-:auto-mode-alist'.
  52 ;;  To add more mailbox files for the mode, use code like:
  53 ;;
  54 ;;      (require 'cl)
  55 ;;      (pushnew '("\\.spool\\'" . turn-on-tinymailbox-mode-maybe)
  56 ;;               auto-mode-alist
  57 ;;               :test 'equal)
  58 ;;      (pushnew '("\\.mbo?x\\'" . turn-on-tinymailbox-mode-maybe)
  59 ;;               auto-mode-alist
  60 ;;               :test 'equal)
  61 ;;
  62 ;;  If you have any questions, use this function to contact author
  63 ;;
  64 ;;       M-x tinymailbox-submit-bug-report
  65
  66 ;;}}}
  67 ;;{{{ Documentation
  68
  69 ;; ..................................................... &t-commentary ...
  70 ;;; Commentary:
  71 ;;
  72 ;;  Preface, sep 1997
  73 ;;
  74 ;;      It is possible to use Procmail <http://www.procmail.org/> to
  75 ;;      manage growing incoming mail. But sometimes your recipes go
  76 ;;      wrong and mail ends up folders that you dind't intend to.
  77 ;;      People usually direct UBE, UCE and Spam mail to different
  78 ;;      folders, but sometimes procmail filter just guesses wrong and
  79 ;;      it sends perfetly valid mail into one of these reject folders.
  80 ;;      It is good to check the Spam mailboxes manually for valid mail
  81 ;;      and then extract it out of them. Not very nice job to do. At
  82 ;;      the the time Gnus was not available for managing multiple
  83 ;;      forlders so I decided to pull out some old code and make it a
  84 ;;      package.
  85 ;;
  86 ;;  Overview of features
  87 ;;
  88 ;;      o   Browse standard unix mailbox .mbox .mbx .spool
  89 ;;      o   Kill, copy messages from mailbox. Copy message bodies.
  90 ;;      o   Highlighting and defcustom supported.
  91 ;;      o   Hide or show headers during mailbox browsing.
  92 ;;      o   Simple summaries can be done with `occur' command. Eg. to browse
  93 ;;          messages based on `From' or `Subject' Headers.
  94 ;;
  95 ;;  Showing and hiding headers
  96 ;;
  97 ;;      When you browse a mail folder, it has lot of attached headers,
  98 ;;      which don't interest you at all when you want to look at the
  99 ;;      messages itself. for example, here is one typical header from
 100 ;;      a test message
 101 ;;
 102 ;;          From nobody Sun Sep 28 20:57:48 1997
 103 ;;          To: nobody
 104 ;;          Subject: Re: bandwidth (was: [RePol] check this issue)
 105 ;;          References: <tbd8lwmfid.fsf@totally-fudged-out-message-id>
 106 ;;          From: Foo bar <judgeDredd@marylyn.com>
 107 ;;          Date: 28 Sep 1997 20:57:47 +0300
 108 ;;          In-Reply-To: Jeff's message of "Tue, 23 Sep 1997 01:35:26 -0400"
 109 ;;          Message-ID: <tbiuvlmick.fsf@marylyn.com>
 110 ;;          X-Mailer: Quassia Gnus v0.11/Emacs 19.34
 111 ;;          Lines: 3
 112 ;;          Xref: marylyn.com junk-test:4
 113 ;;          X-Gnus-Article-Number: 4   Sun Sep 28 20:57:48 1997
 114 ;;
 115 ;;      When you go from this message with `tinymailbox-forward', the headers
 116 ;;      that you're interested in are only shown according to
 117 ;;      `tinymailbox-:header-show-regexp'. The messages headers are collapsed
 118 ;;      as you move around the messages. This approach was chosen, so that
 119 ;;      parsing a big message file (Gnus nnfolder backend) wouldn't put you
 120 ;;      on hold while the headers were collapsed. Now the headers are
 121 ;;      handled while you browse forward and backward. The above headers
 122 ;;      lookes like this after
 123 ;;      processing it:
 124 ;;
 125 ;;          To: nobody
 126 ;;          Subject: Re: bandwidth (was: [RePol] check this issue)
 127 ;;          From: Foo bar <foo@example.com>
 128 ;;          Date: 28 Sep 1997 20:57:47 +0300
 129 ;;          X-Mailer: Quassia Gnus v0.11/Emacs 19.34
 130 ;;          X-Gnus-Article-Number: 4   Sun Sep 28 20:57:48 1997
 131 ;;
 132 ;;      By default all the `X-' headers are shown, so you may want to make
 133 ;;      the `tinymailbox-:header-show-regexp' a bit more restrictive if
 134 ;;      messages contain too many X-headers. You can toggle this message
 135 ;;      hiding feature with
 136 ;;
 137 ;;          C-c ' C-q     or tinymailbox-header-hide-mode
 138 ;;
 139 ;;  Copying or deleting messages
 140 ;;
 141 ;;      When you browse the mailbox, you can perform copy or delete on
 142 ;;      the current message with following commands.
 143 ;;
 144 ;;          C-c ' RET   tinymailbox-copy
 145 ;;          C-c ' SPC   tinymailbox-copy-body
 146 ;;          C-c ' d     tinymailbox-delete
 147 ;;
 148 ;;  Moving between the messages
 149 ;;
 150 ;;      There are couple of movement commands that let you jump from
 151 ;;      one message to another. See also variable `tinymailbox-:move-header-regexp'
 152 ;;
 153 ;;          C-p     tinymailbox-forward-body  or Ctrl-home
 154 ;;          C-n     tinymailbox-backward-body or Ctrl-end
 155 ;;          home    tinymailbox-forward (see tinymailbox-:move-header-regexp)
 156 ;;          end     tinymailbox-backward
 157 ;;
 158 ;;}}}
 159
 160 ;;; Change Log:
 161
 162 ;;; Code:
 163
 164 ;;{{{ setup: require
 165
 166 (require 'tinylibm)
 167 ;; (require 'sendmail)
 168
 169 (eval-when-compile (ti::package-use-dynamic-compilation))
 170
 171 (eval-and-compile
 172   (defvar mail-yank-prefix) ;; Byte compiler silencer
 173   (autoload 'mail-fetch-field           "mail-utils")
 174   (autoload 'mail-position-on-field     "mail-utils")
 175   (autoload 'string-rectangle           "rect" "" t))
 176
 177 (ti::package-defgroup-tiny TinyMailbox tinymailbox-: tools
 178   "Mailbox management minor mode.
 179   Overview of features
 180
 181         o   Browse standard unix mailbox .mbox .mbx .spool
 182         o   Kill, copy messages from mailbox. Copy message bodies.
 183         o   Highlighting and defcustom supported.
 184         o   Hide or show headers during mailbox browsing.
 185         o   Simple summaries can be done with `occur' command. Eg. to browse
 186             messages based on `From' or `Subject' Headers.")
 187
 188 ;;}}}
 189 ;;{{{ setup: variables
 190
 191 ;;; ......................................................... &v-hooks ...
 192
 193 (defcustom tinymailbox-:load-hook nil
 194   "*Hook run when package has been loaded."
 195   :type  'hook
 196   :group 'TinyMailbox)
 197
 198 (defcustom tinymailbox-:mail-setup-hook nil
 199   "*Hook run when mail has been composed.
 200 The point is at the beginning of message."
 201   :type  'hook
 202   :group 'TinyMailbox)
 203
 204 ;;; ......................................................... &private ...
 205
 206 (defvar tinymailbox-:last-file nil
 207   "Last file used by `tinymailbox-message-to-folder'.")
 208
 209 (defvar tinymailbox:-header-begin-regexp
 210   "\n\n[A-Z][a-z]: +\\|^From "
 211   "Regexp of beginning of message headers")
 212
 213 ;;; ........................................................ &v-public ...
 214
 215 (defcustom tinymailbox-:font-lock-keywords
 216   '(("From:[ \t]*\\(.*\\)"
 217      (1 font-lock-function-name-face))
 218
 219     ("Reply-To:[ \t]*\\(.*\\)"
 220      (1 font-lock-function-name-face))
 221
 222     ("Subject:[ \t]*\\(.*\\)"
 223      (1  font-lock-keyword-face))
 224
 225     ("^\\(X-[A-Za-z0-9-]+\\|Date\\):[ \t]*\\(.*\\)"
 226      (1  font-lock-reference-face)))
 227   "*Font lock keywords."
 228   :type   'sexp
 229   :group  'TinyMailbox)
 230
 231 (defcustom tinymailbox-:auto-mode-alist
 232   '(("\\.mbo?x\\'"    . turn-on-tinymailbox-mode-maybe)
 233     ;;  Gnus spool file: Incoming
 234     ("Incoming"       . turn-on-tinymailbox-mode-maybe)
 235     ;;  Gnus `nnml' backend where procmail should deliver output to
 236     ;;  xxx..xxxx.spool, like mail.private.spool, junk.spam.spool,
 237     ;;  junk.bounce.spool
 238     ("\\.spool\\'"    . turn-on-tinymailbox-mode-maybe))
 239   "Items to add to `auto-mode-alist' to turn mode on when file is loaded."
 240   :type '(repeat
 241           (list
 242            (string :tag "File Regexp")
 243            (const 'tinymailbox-mode)))
 244   :group  'TinyMailbox)
 245
 246 (defcustom tinymailbox-:move-header-regexp "^Subject:"
 247   "Regexp that is use in movement commands. See `tinymailbox-forward'."
 248   :type   'string
 249   :group  'TinyMailbox)
 250
 251 (defcustom tinymailbox-:header-show-regexp
 252   "^Subject:\\|^To:\\|^From:\\|^Newsgroups:\\|^X-\\|^Date:"
 253   "Regexp to show the interesting headers. Others will be hidden."
 254   :type  'string
 255   :group 'TinyMailbox)
 256
 257 (defcustom tinymailbox-:header-hide-mode t
 258   "If non-nil then uninteresting headers are hidden while you move."
 259   :type  'boolean
 260   :group 'TinyMailbox)
 261
 262 ;;; .......................................................... &v-menu ...
 263
 264 (defcustom tinymailbox-:menu-use-flag t
 265   "*Non-nil means to use echo-area menu."
 266   :type  'boolean
 267   :group 'TinyMailbox)
 268
 269 (defvar tinymailbox-:menu-main
 270   (list
 271    '(format
 272      "%sTinyMbx: hdr)+-C-q  copy)RETSPC m)ail oO)ccur f)ld F)ile ?H) d)el x)mode off"
 273      (if current-prefix-arg
 274          (format "%s "  (prin1-to-string current-prefix-arg)) "" ))
 275    '(
 276      (?+     . ( (call-interactively 'tinymailbox-header-show)))
 277      (?-     . ( (call-interactively 'tinymailbox-header-hide)))
 278      (?\C-q  . ( (call-interactively 'tinymailbox-header-hide-mode)))
 279      (?d     . ( (call-interactively 'tinymailbox-delete)))
 280      (?\C-m  . ( (call-interactively 'tinymailbox-copy)))
 281      (?\     . ( (call-interactively 'tinymailbox-copy-body)))
 282      (?m     . ( (call-interactively 'tinymailbox-mail-send-at-point)))
 283      (?o     . ( (call-interactively 'tinymailbox-occur)))
 284      (?O     . ( (call-interactively 'tinymailbox-occur-subject)))
 285      (?f     . ( (call-interactively 'tinymailbox-message-to-folder)))
 286      (?F     . ( (call-interactively 'tinymailbox-message-write-file)))
 287      (??     . 'tinymailbox-:menu-help)
 288      (?H     . 'tinymailbox-:menu-help)
 289      (?x     . ( (call-interactively 'turn-off-tinymailbox-help)))))
 290   "*TinyMailbox echo menu.
 291
 292 Header controls:
 293
 294     +    Show headers
 295     -    Hide headers
 296     C-q  Toggle header mode
 297
 298 Message options
 299
 300     RET  Copy message
 301     SPC  Copy body
 302
 303 Transfer options
 304
 305     d    Delete message
 306     m    Send mail with current message
 307     f    Append message to a folder
 308     F    Write message to a file
 309
 310 Miscellaneous
 311
 312     o    Run M-x occur on all lines
 313     O    Run M-x occur for Subject matches only.
 314     ?    Help menu
 315     H    Help menu
 316     x    Exit mode")
 317
 318 ;;;###autoload (autoload 'tinymailbox-version "tinymailbox" "Display commentary" t)
 319 (eval-and-compile
 320   (ti::macrof-version-bug-report
 321    "tinymailbox.el"
 322    "tinymailbox"
 323    tinymailbox-:version-id
 324    "$Id: tinymailbox.el,v 2.79 2007/05/06 23:15:20 jaalto Exp $"
 325    '(tinymailbox-:version-id
 326      tinymailbox-:load-hook
 327      tinymailbox-:last-file
 328      tinymailbox-:font-lock-keywords
 329      tinymailbox-:auto-mode-alist
 330      tinymailbox-:move-header-regexp
 331      tinymailbox-:header-show-regexp
 332      tinymailbox-:header-hide-mode
 333      tinymailbox-:menu-use-flag
 334      tinymailbox-:menu-main)
 335    '(tinymailbox-:debug-buffer)))
 336
 337 ;;}}}
 338 ;;{{{ minor mode
 339
 340 ;;;###autoload (autoload 'tinymailbox-install-mode  "tinymailbox" "" t)
 341 ;;;###autoload (autoload 'tinymailbox-mode          "tinymailbox" "" t)
 342 ;;;###autoload (autoload 'turn-on-tinymailbox-mode  "tinymailbox" "" t)
 343 ;;;###autoload (autoload 'turn-off-tinymailbox-mode "tinymailbox" "" t)
 344 ;;;###autoload (autoload 'tinymailbox-commentary    "tinymailbox" "" t)
 345
 346 (eval-and-compile
 347   (ti::macrof-minor-mode-wizard
 348    "tinymailbox-" " Mbx" "\C-c'"  "Mbx" 'TinyMailbox "tinymailbox-:"
 349
 350    "Unix mailbox minor mode.
 351
 352 You use this minor mode to browse your .mbx and .mbox files or any file
 353 hich is stored in standard unix mailbox format (like news articles).  The
 354 file format is as follows. notice that there is no mistake, the first
 355 'From ' field marks the message biginning and there is no colon.
 356
 357     From Foo Wee Gee <Gee@this.is>
 358     Subject: Swiss Yodddla-laddli-duu
 359     Newsgroups: nothing.interesting
 360
 361     BODY 1 OF MESSAGE
 362
 363     From Foo Wee Gee <Gee@this.is>
 364     Subject: Swiss Yodddla-laddli-duu
 365     Newsgroups: nothing.interesting
 366
 367     BODY 2 OF MESSAGE
 368
 369 Mode description:
 370
 371 Prefix key to access the minor mode is defined in `tinymailbox-:mode-prefix-key'
 372
 373 \\{tinymailbox-:mode-map}"
 374
 375    "TinyMailbox"
 376
 377    (progn                              ;Some mode specific things? No?
 378      (when (and tinymailbox-mode
 379                 (not (get 'tinymailbox-install 'install-done)))
 380        ;; User called us directly and forgot tu run install. Do it now
 381        (tinymailbox-install))
 382      (tinymailbox-font-lock)
 383      ;;  When mode is turned off, we must kill the text properties we used
 384      (unless tinymailbox-mode
 385        (save-excursion
 386          (ti::text-property-search-and-modify '(owner timbx) nil))))
 387
 388    "Mailbox mode"
 389    (list                                ;arg 10
 390     tinymailbox-:mode-easymenu-name
 391     "----"
 392     ["Message forward"      tinymailbox-forward                 t]
 393     ["Message backward"     tinymailbox-backward                t]
 394     ["Body forward"         tinymailbox-forward-boby            t]
 395     ["Body backward"        tinymailbox-backward-body           t]
 396     "----"
 397     ["Header Hide"          tinymailbox-header-hide             t]
 398     ["Header Show"          tinymailbox-header-show             t]
 399     ["Header show/hide mode" tinymailbox-header-hide-mode        t]
 400     "----"
 401     ["Copy message"         tinymailbox-copy                    t]
 402     ["Copy message body"            tinymailbox-copy-body               t]
 403     ["Delete message"       tinymailbox-delete                  t]
 404     "----"
 405     ["Append to file"       tinymailbox-message-to-folder       t]
 406     ["Write to file"        tinymailbox-message-write-file      t]
 407     ["Send email at point"   tinymailbox-mail-send-at-point      t]
 408     "----"
 409     ["Make Summary (occur)"  tinymailbox-occur                  t]
 410     ["Make Summary (occur subject)"  tinymailbox-occur-subject  t]
 411     "----"
 412     ["Keyboard menu"        tinymailbox-menu-main               t]
 413     ["Package version"      tinymailbox-version                 t]
 414     ["Package commentary"    tinymailbox-commentary             t]
 415     ["Mode help"                    tinymailbox-mode-help               t]
 416     ["Mode off"             turn-off-tinymailbox-mode           t])
 417    (progn
 418      (cond
 419       (tinymailbox-:menu-use-flag
 420        ;;  Using menu to remeber commands is easier if you don't use
 421        ;;  menu bar at all.
 422        (define-key   root-map [(home)]          'tinymailbox-backward)
 423        (define-key   root-map [(end)]           'tinymailbox-forward)
 424        (define-key   root-map "\C-p"            'tinymailbox-backward-body)
 425        (define-key   root-map "\C-n"            'tinymailbox-forward-body)
 426        (define-key   root-map [(control home)]  'tinymailbox-backward-body)
 427        (define-key   root-map [(control end)]   'tinymailbox-forward-body)
 428        (define-key   root-map p 'tinymailbox-menu-main))
 429       (t
 430        (define-key   root-map [(home)]          'tinymailbox-backward)
 431        (define-key   root-map [(end)]           'tinymailbox-forward)
 432        (define-key   root-map "\C-p"            'tinymailbox-backward-body)
 433        (define-key   root-map "\C-n"            'tinymailbox-forward-body)
 434        (define-key   root-map [(control home)]  'tinymailbox-backward-body)
 435        (define-key   root-map [(control end)]   'tinymailbox-forward-body)
 436        (define-key   map  "+"     'tinymailbox-header-show)
 437        (define-key   map  "-"     'tinymailbox-header-hide)
 438        (define-key   map "\C-q"   'tinymailbox-header-hide-mode)
 439        (define-key   map  "d"     'tinymailbox-delete)
 440        (define-key   map  "\C-m"  'tinymailbox-copy)
 441        (define-key   map  " "     'tinymailbox-copy-body)
 442        (define-key   map  "m"     'tinymailbox-mail-send-at-point)
 443        (define-key   map  "o"     'tinymailbox-occur)
 444        (define-key   map  "O"     'tinymailbox-occur-subject)
 445        (define-key   map  "f"     'tinymailbox-message-to-folder)
 446        (define-key   map  "F"     'tinymailbox-message-write-file)
 447        (define-key   map "?"      'tinymailbox-help)
 448        (define-key   map  "Hm"    'tinymailbox-mode-help)
 449        (define-key   map  "Hc"    'tinymailbox-commentary)
 450        (define-key   map  "Hv"    'tinymailbox-version)
 451        (define-key   map  "x"     'turn-off-tinymailbox-mode)
 452        (message "TinyMailbox: Use home/end to move between messages."))))))
 453
 454 ;;; ----------------------------------------------------------------------
 455 ;;;
 456 (defun tinymailbox-menu-main (&optional arg)
 457   "Show echo area menu and pass ARG to `ti::menu-menu'."
 458   (interactive "P")
 459   (ti::menu-menu 'tinymailbox-:menu-main arg))
 460
 461 ;;}}}
 462 ;;{{{ Install
 463
 464 ;;; ----------------------------------------------------------------------
 465 ;;;
 466 (defun tinymailbox-mode-candidate-p ()
 467   "Return non-nil if buffer is candidate for `tinymailbox-mode'."
 468   (and (not (or (memq major-mode
 469                       '(vm-mode
 470                         rmail-mode
 471                         article-mode
 472                         message-mode
 473                         mail-mode
 474                         gnus-summary-mode))
 475                 (string-match
 476                  ;; Do not activate on
 477                  ;;
 478                  ;;  *.log
 479                  ;;  *.tmp
 480                  ;;  .procmailrc (dot files in general)
 481                  ;;
 482                  "^\\.\\|\\.\\(log\\|tmp\\)$\\|VM\\|RMAIL"
 483                  (or (buffer-name) ""))))
 484        (ti::mail-mailbox-p)))
 485
 486 ;;; ----------------------------------------------------------------------
 487 ;;;
 488 (defun turn-on-tinymailbox-mode-maybe ()
 489   "Turn on `tinymailbox-mode' if buffer looks like a Berkeley mailbox.
 490 Ignore big mailboxes."
 491   (when (and (tinymailbox-mode-candidate-p)
 492              ;;  Font-locking is too slow for big mailboxes
 493              (< (buffer-size) (* 2 1000 1000)))
 494     (turn-on-tinymailbox-mode)))
 495
 496 ;;; ----------------------------------------------------------------------
 497 ;;;
 498 ;;;###autoload
 499 (defun tinymailbox-install (&optional uninstall verb)
 500   "Install mode, or optionally UNINSTALL and print messages with VERB."
 501   (interactive "P")
 502   (unless uninstall
 503     ;; Signal that we were called. This is checked inside mode wizard
 504     (put 'tinymailbox-install 'install-done t))
 505   (ti::assoc-replace-maybe-add 'auto-mode-alist
 506                                tinymailbox-:auto-mode-alist
 507                                uninstall)
 508   (ti::add-hooks 'find-file-hooks
 509                  'turn-on-tinymailbox-mode-maybe
 510                  uninstall)
 511   (when (or verb
 512             (interactive-p))
 513     (message "TinyMailbox %s"
 514              (if uninstall
 515                  "uninstalled"
 516                "installed"))))
 517
 518 ;;; ----------------------------------------------------------------------
 519 ;;;
 520 ;;;###autoload
 521 (defun tinymailbox-uninstall ()
 522   "Uninstall mode."
 523   (tinymailbox-install 'uninstall (interactive-p)))
 524
 525 ;;; ----------------------------------------------------------------------
 526 ;;;
 527 (defun tinymailbox-font-lock ()
 528   "Add/remove font lock support if `font-lock-mode' exists."
 529   (interactive)
 530   (let* ((sym 'font-lock-keywords)
 531          orig)
 532     (when (and (boundp sym)
 533                (ti::colors-supported-p))
 534       (cond
 535        (tinymailbox-mode
 536         (ti::string-syntax-kill-double-quote)
 537         (make-variable-buffer-local 'tinymailbox-:font-lock-keywords)
 538         (unless (get 'tinymailbox-:font-lock-keywords 'original)
 539           (put 'tinymailbox-:font-lock-keywords
 540                'original
 541                (symbol-value sym)))
 542         (set sym tinymailbox-:font-lock-keywords)
 543         (turn-on-font-lock))
 544        (t
 545         (when (ti::listp
 546                (setq orig
 547                      (get 'tinymailbox-:font-lock-keywords 'original)))
 548           (set sym orig))))
 549       (when (and (boundp 'font-lock-mode)
 550                  (symbol-value 'font-lock-mode))
 551         ;;  fontify approx. 50 lines or until point-max
 552         (save-excursion
 553           (font-lock-fontify-region
 554            (point)
 555            (min (+ (point) (* 80 50)) (point-max))))))))
 556
 557 ;;}}}
 558 ;;{{{ Macros
 559
 560 ;;; ----------------------------------------------------------------------
 561 ;;;
 562 (defsubst tinymailbox-message-move-beginning ()
 563   "Move to message beginning."
 564   (re-search-backward tinymailbox:-header-begin-regexp  nil t))
 565
 566 ;;; ----------------------------------------------------------------------
 567 ;;;
 568 (put 'tinymailbox-message-macro 'lisp-indent-function 0)
 569 (put 'tinymailbox-message-macro 'edebug-form-spec '(body))
 570 (defmacro tinymailbox-message-macro (&rest body)
 571   "Do BODY on message. You can refer to `beg' and `end' for message region."
 572   (`
 573    (let* ((opoint  (point))
 574           beg
 575           end)
 576      ;; Just to make byteCompiler happy
 577      (if (null opoint)  (setq opoint nil))
 578      (if beg            (setq beg t))
 579      (if end            (setq end t))
 580      (tinymailbox-begin 'backward)
 581      (setq beg (point))
 582      ;;   Go forward
 583      (tinymailbox-begin)
 584      ;;   txt txt
 585      ;;   Last line of previous message is here....
 586      ;;
 587      ;;   From asdasdasdadas
 588      ;;   X-Header: blah
 589      ;;   ...
 590 ;;;     (if (looking-at "From ")
 591 ;;;         (backward-line 1))             ;Fix position a bit
 592      (setq end (point))
 593 ;;;      (error beg end)
 594      (,@ body))))
 595
 596 ;;; ----------------------------------------------------------------------
 597 ;;;
 598 (put 'tinymailbox-header-macro 'lisp-indent-function 0)
 599 (defmacro tinymailbox-header-macro (&rest body)
 600   "Do BODY on message. You can refer to `beg' and `end' for message region."
 601   (`
 602    (let* (beg
 603           end)
 604      ;; Just to make byteCompiler happy
 605      (if beg
 606          (setq beg t))
 607      (if end
 608          (setq end t))
 609      (tinymailbox-begin 'backward)          (setq beg (point))
 610      (re-search-forward "^[ \t]*$")
 611      (beginning-of-line)
 612      (setq end (point))
 613      (,@ body))))
 614
 615 ;;; ----------------------------------------------------------------------
 616 ;;;
 617 (put 'tinymailbox-paragraph-macro 'lisp-indent-function 0)
 618 (defmacro tinymailbox-paragraph-macro (&rest body)
 619   "Set paragraph values locally while executing BODY."
 620   (`
 621    (let* ((sentence-end         "[.?!]*[ \n]+")
 622           (paragraph-start      "^[ \t]*$")
 623           (paragraph-separate   paragraph-start))
 624      (,@ body))))
 625
 626 ;;}}}
 627 ;;{{{ misc
 628
 629 ;;; ----------------------------------------------------------------------
 630 ;;;
 631 (defun tinymailbox-header-p ()
 632   "Check if point is inside header."
 633   (interactive)
 634   (save-excursion
 635     (beginning-of-line)
 636     (looking-at "^[A-Z][^:]+: ")))
 637
 638 ;;; ----------------------------------------------------------------------
 639 ;;;
 640 (defun tinymailbox-overlay (act &optional beg end)
 641   "If ACT is 'hide, hide overlay, otherwise highlight BEG END."
 642   (let* ((ov
 643           (if (boundp 'mouse-drag-overlay) ;Emacs, use this by default
 644               'mouse-drag-overlay
 645             'primary-selection-extent)))
 646     (cond
 647      ((eq act 'hide)
 648       (ti::compat-overlay-move ov 1 1)
 649       (pop-mark))
 650      (t
 651       (ti::compat-overlay-move ov beg end)
 652       (setq ov (symbol-value ov))
 653       (when (ti::emacs-p)
 654         (push-mark
 655          (if (ti::emacs-p)
 656              (ti::funcall 'overlay-start ov)
 657            (ti::funcall 'extent-start-position ov))
 658          t t)
 659         (push-mark
 660          (if (ti::emacs-p)
 661              (ti::funcall 'overlay-end ov)
 662            (ti::funcall 'extent-end-position ov))
 663          t t)) ;; when
 664       (setq this-command 'set-mark)))))
 665
 666 ;;; ----------------------------------------------------------------------
 667 ;;;
 668 (defun tinymailbox-header-next ()
 669   "Find next header forward."
 670   (if (looking-at "^[^ \t\n]")
 671       (forward-line 1))
 672   (while (and (not (eobp)) (looking-at "^[ \t]"))
 673     (forward-line 1)))
 674
 675 ;;; ----------------------------------------------------------------------
 676 ;;;
 677 (defun tinymailbox-header-show-or-hide ()
 678   "Check `tinymailbox-:header-hide-mode' and act according to it."
 679   (if tinymailbox-:header-hide-mode
 680       (tinymailbox-header-hide)
 681     (tinymailbox-header-show)))
 682
 683 ;;; ----------------------------------------------------------------------
 684 ;;;
 685 (defun tinymailbox-header-show ()
 686   "Call `tinymailbox-header-hide' with argument SHOW."
 687   (interactive)
 688   (tinymailbox-header-hide 'show))
 689
 690 ;;; ----------------------------------------------------------------------
 691 ;;;
 692 (defun tinymailbox-header-hide (&optional show)
 693   "Hide or SHOW headers according to `tinymailbox-:header-show-regexp'."
 694   (interactive "P")
 695   (let* ((re     tinymailbox-:header-show-regexp)
 696          (prop   'invisible)
 697          (propl  (list 'owner 'timbx
 698                        'tinymailbox-stat 'hidden
 699                        prop t
 700                        'rear-nonsticky t))
 701          (prop-stat 'tinymailbox-stat)
 702          (opoint (point))
 703          point
 704          status-property
 705          put-property)
 706     (tinymailbox-header-macro
 707      (with-buffer-modified
 708        (goto-char beg)
 709        ;;  The hide on/off information is stored to the message beginning
 710        ;;  - We look if it says 'hidden or 'shown
 711        ;;  - If the user wants hidden headers, but they are already
 712        ;;    hidden, then this function does nothing.
 713        (setq status-property
 714              (memq prop-stat (text-properties-at (point))))
 715        (cond
 716         (show
 717          (setq put-property 'shown)
 718          (when (or (null status-property)
 719                    ;; If text is already shown, then do nothing.
 720                    (and status-property
 721                         (not (eq (nth 1 status-property) 'shown))))
 722            (ti::text-property-search-and-modify
 723             '(owner timbx) nil beg end)))
 724         (t
 725          (setq put-property 'hidden)
 726          (when (or (null status-property)
 727                    (and status-property
 728                         (not (eq (nth 1 status-property) 'hidden))))
 729            (while (< (point) end)
 730              (cond
 731               ((and (not (looking-at re))
 732                     ;; If this point has already marked visible, do nothing.
 733                     (or (null (eq 'timbx
 734                                   (get-text-property (point) 'owner)))
 735                         (null (get-text-property (point) prop))))
 736                (setq point (point))
 737                (tinymailbox-header-next)
 738                (with-buffer-modified
 739                  (let (buffer-read-only)
 740                    (set-text-properties point (point) propl))))
 741               (t
 742                (forward-line 1)))))))
 743        (put-text-property beg (1+ beg) 'owner 'timbx)
 744        (put-text-property beg (1+ beg) prop-stat put-property)))
 745     (goto-char opoint)))
 746
 747 ;;}}}
 748 ;;{{{ move
 749
 750 ;;; ----------------------------------------------------------------------
 751 ;;;
 752 (eval-and-compile
 753   (defun tinymailbox-fmacro-move-1 (func doc move-func re msg &rest body)
 754     "Use `tinymailbox-fmacro-move with FUNC DOC MOVE-FUNC RE MSG and BODY."
 755     (let* ((sym (intern (symbol-name (` (, func))))))
 756       (`
 757        (defun (, sym) (&optional arg)
 758          (, doc)
 759          (interactive "P")
 760          (let* ((Opoint  (point))
 761                 stat)
 762            (if (eq (, move-func) 're-search-backward)
 763                (beginning-of-line)
 764              (end-of-line))
 765            (cond
 766             ((setq stat (funcall (, move-func) (, re) nil t))
 767              (goto-char (match-end 0)))
 768             (t
 769              (goto-char Opoint)))
 770            (tinymailbox-header-show-or-hide)
 771            (,@ body)
 772            (if (interactive-p)
 773                (recenter 3))
 774            (when (and (null stat) (interactive-p))
 775              (message (, msg)))
 776            stat)))))
 777
 778   ) ;; eval-and-compile
 779
 780 ;;; ----------------------------------------------------------------------
 781 ;;;
 782 (defmacro tinymailbox-fmacro-move (func doc move-func re msg &optional body)
 783   "Create Move function FUNC DOC MOVE-FUNC RE MSG and BODY.
 784 Created function arguments: (&optional arg)"
 785   (` (, (tinymailbox-fmacro-move-1
 786          func doc move-func re msg body))))
 787
 788 ;;; ----------------------------------------------------------------------
 789 ;;;
 790 ;;;###autoload (autoload 'tinymailbox-forward "tinymailbox" "Go to next message." t)
 791 (tinymailbox-fmacro-move
 792  tinymailbox-forward
 793  "Go to next message."
 794  're-search-forward tinymailbox-:move-header-regexp
 795  "TinyMailbox: message forward stop.")
 796
 797 ;;; ----------------------------------------------------------------------
 798 ;;;
 799 ;;;###autoload (autoload 'tinymailbox-backward "tinymailbox" "Go to previous message." t)
 800 (tinymailbox-fmacro-move
 801  tinymailbox-backward
 802  "Go to previous message."
 803  're-search-backward tinymailbox-:move-header-regexp
 804  "TinyMailbox: message backward stop.")
 805
 806 ;;; ----------------------------------------------------------------------
 807 ;;;
 808 (tinymailbox-fmacro-move
 809  tinymailbox-forward-body
 810  "Go to next message body."
 811  're-search-forward "^From "
 812  "TinyMailbox: body forward stop."
 813  (and stat
 814       (setq stat (re-search-forward "^[ \t]*$" nil t))))
 815
 816 ;;; ----------------------------------------------------------------------
 817 ;;;
 818 (defun tinymailbox-backward-body ()
 819   "Go to previous message body."
 820   (interactive)
 821   (let* ((opoint (point))
 822          stat)
 823     ;;  We must move to message beginning first.
 824     (tinymailbox-message-move-beginning)
 825     (forward-line -1)
 826     (if (null (re-search-backward "^From " nil t))
 827         (message "TinyMailbox: body backward stop.")
 828       (setq stat (re-search-forward "^[ \t]*$" nil t)))
 829     (if (and stat
 830              (interactive-p))
 831         (recenter 3))
 832     ;;  If none found, return to original position
 833     (when (and (null stat)
 834                (not (eq (point) opoint)))
 835       (message "TinyMailbox: body backward stop.")
 836       (goto-char opoint))))
 837
 838 ;;; ----------------------------------------------------------------------
 839 ;;;
 840 (defun tinymailbox-header-hide-mode (arg &optional verb)
 841   "Toggle header hiding mode with ARG when moving between messages. VERB."
 842   (interactive "P")
 843   (ti::verb)
 844   (ti::bool-toggle tinymailbox-:header-hide-mode)
 845   (when verb
 846     (message "Header hiding mode is %s"
 847              (if tinymailbox-:header-hide-mode "on" "off")))
 848   (tinymailbox-header-show-or-hide))
 849
 850 ;;}}}
 851 ;;{{{ copy; delete
 852
 853 ;;; ----------------------------------------------------------------------
 854 ;;;
 855 ;;;###autoload
 856 (defun tinymailbox-begin (&optional backward)
 857   "Move to next message begin. Optionally BACKWARD."
 858   (interactive "P")
 859   (let* ((re tinymailbox:-header-begin-regexp)
 860          case-fold-search)
 861     (cond
 862      (backward
 863       (if (re-search-backward re nil t)
 864           (skip-chars-forward "^a-z") ;; Go to character
 865         (ti::pmin)))
 866      (t
 867       (goto-char (line-end-position))
 868       (unless (re-search-forward re nil t)
 869         (ti::pmax))))
 870     (beginning-of-line)))
 871
 872 ;;; ----------------------------------------------------------------------
 873 ;;;
 874 ;;;###autoload
 875 (defun tinymailbox-delete ()
 876   "Delete current message. point must be inside message."
 877   (interactive)
 878   (buffer-enable-undo)
 879   (tinymailbox-message-macro
 880    (forward-line 2)
 881    (kill-region beg (point))))
 882
 883 ;;; ----------------------------------------------------------------------
 884 ;;;
 885 ;;;###autoload
 886 (defun tinymailbox-copy ()
 887   "Copy current message. point must be inside message."
 888   (interactive)
 889   (tinymailbox-message-macro
 890    (copy-region-as-kill beg end)
 891    (tinymailbox-overlay 'show beg end)
 892    (sit-for 0.5)
 893    (tinymailbox-overlay 'hide beg end)
 894    (if (interactive-p)
 895        (message "TinyMailbox: Message copied as kill."))))
 896
 897 ;;; ----------------------------------------------------------------------
 898 ;;;
 899 ;;;###autoload
 900 (defun tinymailbox-copy-body ()
 901   "Copy body of current message. point must be inside message."
 902   (interactive)
 903   (buffer-enable-undo)
 904   (tinymailbox-message-macro
 905    ;;  body starts after all headers.
 906    (goto-char beg)
 907    (re-search-forward "^[ \t]*$")
 908    (forward-line 1)
 909    (setq beg (point))
 910    (copy-region-as-kill beg end)
 911    (tinymailbox-overlay 'show beg end))
 912   (if (interactive-p)
 913       (message "TinyMailbox: Message body copied.")))
 914
 915 ;;; ----------------------------------------------------------------------
 916 ;;;
 917 ;;;###autoload
 918 (defun tinymailbox-message-to-folder (file)
 919   "File current message by appending it to FILE."
 920   (interactive
 921    (list
 922     (read-file-name
 923      "Append to folder: "
 924      (if tinymailbox-:last-file
 925          (file-name-directory tinymailbox-:last-file))
 926      nil
 927      nil
 928      (if tinymailbox-:last-file
 929          (file-name-nondirectory tinymailbox-:last-file)))))
 930   (tinymailbox-message-macro
 931    (setq tinymailbox-:last-file file)
 932    (append-to-file beg (min (1+ end) (point-max)) file)
 933    (goto-char opoint)))
 934
 935 ;;; ----------------------------------------------------------------------
 936 ;;;
 937 ;;;###autoload
 938 (defun tinymailbox-message-write-file (file)
 939   (interactive
 940    (list
 941     (read-file-name
 942      "Write to file: "
 943      (if tinymailbox-:last-file
 944          (file-name-directory tinymailbox-:last-file))
 945      nil
 946      nil
 947      (if tinymailbox-:last-file
 948          (file-name-nondirectory tinymailbox-:last-file)))))
 949   (tinymailbox-message-macro
 950    (setq tinymailbox-:last-file file)
 951    (write-region beg (min (1+ end) (point-max)) file)
 952    (goto-char opoint)))
 953
 954 ;;; ----------------------------------------------------------------------
 955 ;;;
 956 (defun tinymailbox-occur (regexp)
 957   "Create Simple `Summary' buffer by running REGEXP `occur'.
 958 Try Subject: or From:"
 959   (interactive "sTinyMailbox: run occur by regexp: ")
 960   (cond
 961    ((ti::nil-p regexp)
 962     (when (interactive-p)
 963       (message "TinyMailbox: Occur cancelled. No REGEXP given.")))
 964    (t
 965     (save-excursion
 966       (ti::pmin)
 967       (occur regexp)))))
 968
 969 ;;; ----------------------------------------------------------------------
 970 ;;;
 971 (defun tinymailbox-occur-subject ()
 972   "Generate Subject summary."
 973   (interactive)
 974   (tinymailbox-occur "^Subject:.*"))
 975
 976 ;;; ----------------------------------------------------------------------
 977 ;;;
 978 (defsubst tinymailbox-user-mail-address-regexp ()
 979   "Return regexp from `user-mail-address' and `user-full-name'."
 980   (concat
 981    (or user-mail-address "####none###")
 982    "\\|"
 983    (or user-full-name "###none###")
 984    "\\|"
 985    (if user-login-name
 986        (concat user-login-name "@")
 987      "###none###")))
 988
 989 ;;; ----------------------------------------------------------------------
 990 ;;;
 991 (defsubst tinymailbox-mail-send-filter (list &optional regexp)
 992   "Remove all strings from LIST that match current user or REGEXP."
 993   (let ((user (tinymailbox-user-mail-address-regexp)))
 994     (remove-if (lambda (x)
 995                  (or (string-match user x)
 996                      (and (stringp regexp)
 997                           (string-match regexp x))))
 998                list)))
 999
1000 ;;; ----------------------------------------------------------------------
1001 ;;;
1002 (defun tinymailbox-mail-send-at-point ()
1003   "Compose mail using current message.
1004 References:
1005   `mail-mode-hook'"
1006   (interactive)
1007   (let* ((buffer (current-buffer))
1008          from
1009          from-email
1010          to-dest
1011          to
1012          to-list
1013          cc
1014          cc-list
1015          references
1016          subject
1017          start
1018          body)
1019     ;;  We must "require", because `mail-yank-prefix' is not otherwise
1020     ;;  defined.
1021     (if (not (boundp 'mail-yank-prefix))
1022         (require 'sendmail))
1023     (tinymailbox-message-macro
1024      (ti::narrow-safe beg end
1025        (ti::pmin)
1026        (setq from       (mail-fetch-field "From")
1027              from-email (car-safe (ti::mail-email-from-string from))
1028              to         (mail-fetch-field "to")
1029              reply-to   (mail-fetch-field "reply-to")
1030              to-list    (and to
1031                              (tinymailbox-mail-send-filter
1032                               (split-string
1033                                to
1034                                "[ \t\r\n]*,[ \t\r\n]*")
1035                               from-email))
1036              cc         (mail-fetch-field "CC")
1037              cc-list    (and cc
1038                              (tinymailbox-mail-send-filter
1039                               (split-string
1040                                cc
1041                                "[ \t\r\n]*,[ \t\r\n]*")
1042                               (regexp-quote from-email)))
1043              references (mail-fetch-field "References")
1044              subject    (mail-fetch-field "Subject")))
1045      (setq to-dest (or reply-to from))
1046      ;;  Sometimes the To field contains multiple addresses
1047      ;;  To: me@here.at, other@there.com
1048      ;;  => Move them to CC
1049      (dolist (elt to-list)
1050        (unless (dolist (eltc cc-list)
1051                  (if (string= elt eltc)
1052                      (return t)))
1053          (push elt cc-list)))
1054      (if cc-list
1055          (setq cc (mapconcat 'concat cc-list ", ")))
1056      (ti::pmin)
1057      (when (re-search-forward "^[ \t]*$")
1058        (forward-line 1)
1059        (setq body (buffer-substring (point) (point-max))))
1060      (if (and subject
1061               (not (ti::string-match-case "re:" subject 'ignore-case)))
1062          (setq subject (concat "Re: " subject))))
1063     (mail nil to-dest subject nil cc)
1064     (when references
1065       (mail-position-on-field "References")
1066       (insert references))
1067     (ti::pmax)
1068     (setq start (point))
1069     (insert (or body ""))
1070     (string-rectangle
1071      start
1072      (point-max)
1073      (if (stringp mail-yank-prefix)
1074          mail-yank-prefix
1075        "| "))
1076     (goto-char start)
1077     (run-hooks 'tinymailbox-:mail-setup-hook)))
1078
1079 ;;}}}
1080
1081 (add-hook  'tinymailbox-:mode-define-keys-hook 'tinymailbox-mode-define-keys)
1082 (provide   'tinymailbox)
1083
1084 (run-hooks 'tinymailbox-:load-hook)
1085
1086 ;;; tinymailbox.el ends here