emacs_el/tiny-tools/tiny/tinylibmail.el

   1 ;;; tinylibmail.el --- Library of mail related functions
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1995-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinylibmail-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  17 ;; This program is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2 of the License, or (at your option)
  20 ;; any later version.
  21 ;;
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  24 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with program; see the file COPYING. If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;;; Install:
  38
  39 ;; ........................................................ &t-install ...
  40 ;; Put this file on your Emacs-Lisp load path, add following into your
  41 ;; ~/.emacs startup file
  42 ;;
  43 ;;     (require 'tinylibm)
  44 ;;
  45 ;; No, there is no mistake here. The 'm' lib contains all autoloads
  46 ;; to this package.
  47
  48 ;;}}}
  49 ;;{{{ Documentation
  50
  51 ;;; Commentary:
  52
  53 ;;
  54 ;;      o   This is library. Package itself does nothing.
  55 ;;      o   Collection of functions to deal with Mail/News specific tasks.
  56
  57 ;;}}}
  58
  59 ;;; Change Log:
  60
  61 ;;; Code:
  62
  63 ;;{{{ setup: -- require
  64
  65 ;;;  ....................................................... &v-require ...
  66
  67 (require 'tinylibm)
  68 (require 'sendmail) ;; mail-header-separator
  69
  70 (eval-and-compile
  71   (defvar mail-abbrevs)                 ;Silence ByteCompiler
  72   (defvar mail-aliases)
  73   (defvar rmail-current-message nil)
  74   (cond
  75    ((ti::xemacs-p)
  76     (autoload 'build-mail-aliases "mail-abbrevs"))
  77    (t
  78     (autoload 'mail-abbrevs-setup "mailabbrev")
  79     (autoload 'build-mail-aliases "mailalias")
  80     (autoload 'build-mail-abbrevs "mailabbrev")))
  81   (autoload 'rmail-msgbeg                       "rmail")
  82   (autoload 'rmail-msgend                       "rmail")
  83   (autoload 'gnus-group-get-parameter           "gnus"))
  84
  85 (eval-when-compile
  86   (ti::package-use-dynamic-compilation))
  87
  88 ;;}}}
  89 ;;{{{ setup: -- private
  90
  91 ;;; ......................................................... &v-hooks ...
  92
  93 (defvar ti:mail-load-hook nil
  94   "Hook that is run when package is loaded.")
  95
  96 ;;; ....................................................... &v-private ...
  97
  98 (defvar ti:mail-ret nil
  99   "Global return value of this package.")
 100
 101 (defvar ti:mail-mail-buffer " *ti::mail-mail*"
 102   "*Temporary mail buffer name.")
 103
 104 ;;  Variables could be modified. defsubst makes them persistent
 105
 106 (defsubst ti::mail-pgp-signature-begin-line ()
 107   "Signature start line."
 108   "-----BEGIN PGP SIGNATURE-----")
 109
 110 (defsubst ti::mail-pgp-signature-end-line ()
 111   "Signature end line."
 112   "-----END PGP SIGNATURE-----")
 113
 114 ;; Signed message has:
 115 ;;
 116 ;; -----BEGIN PGP SIGNED MESSAGE-----
 117 ;; -----BEGIN PGP SIGNATURE-----
 118 ;; -----END PGP SIGNATURE-----
 119
 120 (defsubst ti::mail-pgp-signed-begin-line ()
 121   "Text for start of PGP signed messages."
 122   "-----BEGIN PGP SIGNED MESSAGE-----")
 123
 124 (defsubst ti::mail-pgp-signed-end-line ()
 125   "Text for start of PGP signed messages."
 126   (ti::mail-pgp-signature-end-line))
 127
 128 (defsubst ti::mail-pgp-pkey-begin-line ()
 129   "PGP public key begin line."
 130   "-----BEGIN PGP PUBLIC KEY BLOCK-----")
 131
 132 (defsubst ti::mail-pgp-pkey-end-line ()
 133   "PGP public key end line."
 134   "-----END PGP PUBLIC KEY BLOCK-----")
 135
 136 (defsubst ti::mail-pgp-msg-begin-line ()
 137   "PGP message, typically base64 signed, begin line."
 138   "-----BEGIN PGP MESSAGE-----")
 139
 140 (defsubst ti::mail-pgp-msg-end-line ()
 141   "PGP message, typically base64 signed, end line."
 142   "-----END PGP MESSAGE-----")
 143
 144 (defsubst ti::mail-pgp-any-pgp-line-regexp (&optional anchor-left)
 145   "Return regexp that match any pgp TAG.
 146 If ANCHOR-LEFT is non-nil; the regexp will contains left ^ anchor."
 147   ;;  The lines can be broken, when there is encrypted/signed message
 148   ;;  NOTE: there is no anchor by default; because sometimes use may have
 149   ;;  indented the whole PGP block (e.g. in his web page or in .doc file)
 150
 151   (concat
 152    (if anchor-left "^" "")
 153    "- -----\\(BEGIN\\|END\\) PGP.*-----"
 154    "\\|"
 155    (if anchor-left "^" "")
 156    "-----\\(BEGIN\\|END\\) PGP.*-----"))
 157
 158 ;;; ----------------------------------------------------------------------
 159 ;;;
 160 (defsubst ti::mail-ip-raw-p (ip)
 161   "Check raw nnn.nnn.nnn.nnn IP."
 162   (string-match "^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$" ip))
 163
 164 ;;; ----------------------------------------------------------------------
 165 ;;;
 166 (defsubst ti::mail-ip-top-level-domain (host)
 167   "Convert HOST a.b.c  => b.c domain.
 168 If HOST is raw numeric IP, do nothing."
 169   (cond
 170    ((ti::mail-ip-raw-p host)
 171     host)
 172    ((or (string-match "\\.\\([^.]+\\.[^.]+\\)$" host)
 173         (string-match "^\\([^.]+\\.[^.]+\\)$" host))
 174     (match-string 1 host))))
 175
 176 ;;; ----------------------------------------------------------------------
 177 ;;;
 178 (defsubst ti::mail-ip-3-level-domain (host)
 179   "Convert HOST a.b.c.d  => b.c.d domain."
 180   (when (string-match "\\.\\([^.]+\\.[^.]+\\.[^.]+\\)$" host)
 181     (match-string 1 host)))
 182
 183 ;;; ----------------------------------------------------------------------
 184 ;;;
 185 (defsubst ti::mail-ip-cleanup (word)
 186   "Clean WORD to format 'aa.bb.cc'. Remove offending characters.
 187 Remove all characters up till @: this@email.com => email.com
 188 Remove all not(alphanumeric, dash, dot) charcters.
 189
 190 For example a word at point may include anything:
 191
 192   <bb.com> \"bb.com\" this@bb.com
 193
 194 All of the above will become:
 195
 196   bb.com"
 197   (and word
 198        (replace-regexp-in-string
 199         "[^a-z0-9-.]" ""
 200         (replace-regexp-in-string "^.*@" "" word))))
 201
 202 ;;; ----------------------------------------------------------------------
 203 ;;;
 204 (defun ti::mail-ip-at-point-1 ()
 205   "Read only word containing characters [-.a-zA-z0-9]."
 206   (let (beg
 207         word)
 208     ;;  depending where the point is, from this word different part
 209     ;;  is read: foo.com[1.2.3.4]
 210     ;;             |       |
 211     ;;            (1)     (2)
 212     (save-excursion
 213       (skip-chars-backward "-.a-zA-Z0-9")
 214       (setq beg (point))
 215       (skip-chars-forward "-.a-zA-Z0-9")
 216       (unless (eq beg (point))
 217         (buffer-substring beg (point))))))
 218
 219 ;;; ----------------------------------------------------------------------
 220 ;;;
 221 (defun ti::mail-ip-at-point ()
 222   "Read domain ip IP name at point."
 223   (let* ((word (ti::mail-ip-at-point-1)))
 224     (when (not (ti::nil-p word))
 225       ;;  foo.com[1.2.3.4]
 226       (setq word (ti::mail-ip-cleanup word))
 227       (if (ti::mail-ip-raw-p word)
 228           word
 229         (ti::mail-ip-top-level-domain word)))))
 230
 231 ;;; ----------------------------------------------------------------------
 232 ;;;
 233 (defsubst ti::mail-news-group ()        ;ding & gnus compatible
 234   "Return newsgroup name if group exists."
 235   (if (boundp 'gnus-newsgroup-name)
 236       (symbol-value 'gnus-newsgroup-name)))
 237
 238 ;;; ........................................................ &v-public ...
 239 ;;; User configurable -- but not recommended.
 240
 241 ;;  See gnus.el or gnus-msg.el  gnus-required-headers
 242 ;;  The 'in-reply-to is for mail messages (additional)
 243
 244 (defconst ti:mail-required-headers
 245   '(from date newsgroups subject path message-id in-reply-to references)
 246   "*All required fields that RFC977 and RFC1036 requires.
 247 Make sure symbol names are all in lowercase.")
 248
 249 (defvar ti:mail-parse-name-not-accept
 250   (concat
 251    "[A-Z][/][A-Z]"                      ;company division PMR/TMS ?
 252    "\\|^[A-Z]+\\'"                      ;all in capitals
 253    "\\|^[-]$"                           ;single '-' word
 254    "\\|[.0-9]"                          ;maybe phone number ?
 255    "\\|com\\|org\\|edu")
 256   "*Regexp to exclude non-valid people names.
 257 We can't be sure that the names are really good names when we parse the
 258 senders From field. Let's see an example
 259
 260         \"Person Someone p. nnn-nnn-nnn\"
 261
 262 There obviously isn't 3rd name, it's used for phone abbrev. And the last
 263 word is the actual phone number.
 264
 265 This regexp tells which word matches are false name hits.
 266 In this example it'd leave:
 267         \"Person Someone\"
 268
 269 See `ti::mail-parse-name'")
 270
 271 ;;}}}
 272 ;;{{{ setup: -- version
 273
 274 (defconst tinylibmail-version (substring  "$Revision: 2.68 $" 11 16)
 275   "Latest version number.")
 276
 277 (defconst tinylibmail-version-id
 278   "$Id: tinylibmail.el,v 2.68 2007/05/07 10:50:08 jaalto Exp $"
 279   "Latest modification time and version number.")
 280
 281 ;;; ----------------------------------------------------------------------
 282 ;;;
 283 (defun tinylibmail-version (&optional arg)
 284   "Show version information. ARG tell to print message in echo area only."
 285   (interactive "P")
 286   (ti::package-version-info "tinylibmail.el" arg))
 287
 288 ;;; ----------------------------------------------------------------------
 289 ;;;
 290 (defun tinylibmail-submit-feedback ()
 291   "Submit suggestions, error corrections, impressions, anything..."
 292   (interactive)
 293   (ti::package-submit-feedback "tinylibmail.el"))
 294
 295 ;;}}}
 296 ;;{{{ misc
 297
 298 ;;; ----------------------------------------------------------------------
 299 ;;;
 300 (defun ti::mail-signature-p  ()
 301   "Return beginning of line point if \\n-- *\\n is found.
 302 The de facto, while not standardized by any RFC signature separator
 303 it \\n-- \\n. The trailing whitespace is very unfortunate evolution
 304 to separate signatures from message digests \\n--\\n.
 305
 306 This function accepts trailing spaces or just n\\--\\n"
 307   (let* ((point (point)))               ;avoid save-excursion.
 308     (ti::pmin)
 309     (prog1 (if (re-search-forward "\n-- *\n" nil t)
 310                (1+ (match-beginning 0)))
 311       (goto-char point))))
 312
 313 ;;; ----------------------------------------------------------------------
 314 ;;;
 315 (defun ti::mail-body-empty-p ()
 316   "Check if there is nothing in the body or if whole buffer is empty."
 317   (save-excursion
 318     (ti::mail-text-start 'move)
 319     (eq (point) (point-max))))
 320
 321 ;;; ----------------------------------------------------------------------
 322 ;;;
 323 (defun ti::mail-body-clear ()
 324   "Delete message body."
 325   (ti::mail-text-start 'move)
 326   (delete-region (point) (point-max)))
 327
 328 ;;; ----------------------------------------------------------------------
 329 ;;;
 330 (put 'ti::mail-set-region 'lisp-indent-function 1)
 331 (put 'ti::mail-set-region 'edebug-form-spec '(body))
 332 (defmacro  ti::mail-set-region (beg end)
 333   "Set BEG END to whole buffer if they don't have value."
 334   (`
 335    (progn
 336      (or (, beg)
 337          (setq (, beg) (ti::mail-text-start)))
 338      (or (, end)
 339          (setq (, end) (point-max))))))
 340
 341 ;;; ----------------------------------------------------------------------
 342 ;;;
 343 (put 'ti::mail-point-in-header-macro 'lisp-indent-function 0)
 344 (put 'ti::mail-point-in-header-macro 'edebug-form-spec '(body))
 345 (defmacro ti::mail-point-in-header-macro (&rest body)
 346   "Run BODY only if point is inside mail header area."
 347   (`
 348    (when (< (point) (ti::mail-text-start))
 349      (,@ body))))
 350
 351 ;;; ----------------------------------------------------------------------
 352 ;;;
 353 (defun ti::mail-message-length ()
 354   "Return message's body length, not including the headers.
 355 The message length is measured be counting character between the
 356 BODY begin and BODY end. Any amount of whitespaces around the body is
 357 skipped.
 358
 359 Exceptions:
 360
 361   The start point defaults to `point-min' if body can't be found.
 362
 363   If there is PGP signed block, then the body length is the text inside
 364   PGP signed block, not the original message body.
 365
 366   Signed headers are also skipped.
 367
 368     -----BEGIN PGP SIGNED MESSAGE-----
 369
 370     ##                                  < signed headers begin mark \\n##
 371     Subject: some subject
 372     Reply-to: somewhere
 373                                         < empty space ends headers
 374     Hi, I swanted to tell you...        < BODY BEGIN IS HERE"
 375   (let* ((end (ti::mail-pgp-signed-conventional-p))
 376          beg)
 377     (save-excursion
 378       (cond
 379        ((and end
 380              (null (ti::mail-pgp-signature-detached-p)))
 381         ;; Do not count empty lines at the end of body
 382         (goto-char end) (skip-chars-backward " \t\n") (setq end (point))
 383         (ti::pmin)
 384         (re-search-forward (ti::mail-pgp-signed-begin-line))
 385         (forward-line 1)
 386         ;;  now we're inside BODY of text, but it's not that simple yet. User
 387         ;;  may have signed headers and they are inserterted into body
 388         ;;  like this:
 389         ;;
 390         ;;  -----BEGIN PGP SIGNED MESSAGE-----
 391         ;;
 392         ;;  ##
 393         ;;  Subject: See this ma!
 394         ;;
 395         ;;  Body text starts here.
 396         ;;
 397         ;;  Note, there is no spaces, becasue the body is trimmed
 398         (when (looking-at "\n##\n")
 399           (goto-char (match-end 0))
 400           (re-search-forward "^$"))
 401         ;;  Ignore leading spaces
 402         (skip-chars-forward " \t\n")
 403         (- end (point)))
 404        (t
 405         (ti::mail-text-start 'move)
 406         (skip-chars-forward " \t\n") (setq beg (point))
 407         (goto-char (point-max))
 408         (if (eq beg (point))            ;Empty buffer
 409             0
 410           (skip-chars-backward " \t\n") (setq end (point))
 411           (- (point) beg)))))))
 412
 413 ;;; ----------------------------------------------------------------------
 414 ;;; #todo: this is old function and should be removed.
 415 ;;;
 416 (defun ti::mail-get-2re (re str)
 417   "Use RE and match STR. Return list ('' '') if not matched."
 418   (let ((m1 "")
 419         (m2 ""))
 420     (if (eq nil (string-match re str))
 421         t                               ;do nothing, not matched
 422       (if (match-end 1)
 423           (setq m1 (substring str (match-beginning 1)
 424                               (match-end 1))))
 425       (if (match-end 2)
 426           (setq m2 (substring str (match-beginning 2)
 427                               (match-end 2)))))
 428     (list m1 m2)))
 429
 430 ;;; ----------------------------------------------------------------------
 431 ;;;
 432 (defun ti::mail-required-headers ()
 433   "Return standard RFC header required when posting.
 434
 435 References:
 436
 437   `ti:mail-required-headers'
 438   `gnus-required-headers'
 439
 440 Return:
 441
 442   list          '(header-name-symbol .. )
 443   nil           gnus not loaded ?"
 444   (cond
 445    ((listp ti:mail-required-headers)
 446     ti:mail-required-headers)
 447    ((boundp 'gnus-required-headers)
 448     (symbol-value 'gnus-required-headers))
 449    (t
 450     nil)))
 451
 452 ;;; ----------------------------------------------------------------------
 453 ;;;
 454 (defun ti::mail-mail-mode-p ()
 455   "Check if some mail MUA mode is tuned on this buffer: RMAIL, VM, MH ..."
 456   (string-match
 457    "^\\(vm-\\|rmail-\\|mh-\\|gnus-article-\\|message\\).*mode"
 458    (symbol-name major-mode)))
 459
 460 ;;; ----------------------------------------------------------------------
 461 ;;;
 462 (defun ti::mail-mailbox-p ()
 463   "Check if two first lines look like Berkeley mailbox format."
 464   (save-excursion
 465     (ti::pmin)
 466     ;; From foo@some.com  Wed Dec 19 19:19:41 2001
 467     ;; Received: from some.com ([000.22.68.000])
 468     (and (looking-at "^\\(From:?\\|Return-Path:\\) .*@")
 469          (forward-line 1)
 470          (not (eobp))
 471          (looking-at "^[a-zA-Z-]+:[ \t]+[^ \r\r\n]"))))
 472
 473 ;;; ----------------------------------------------------------------------
 474 ;;;
 475 (defun ti::mail-mail-p ()
 476   "Check if first line contain left flushed header 'Header:'.
 477 This is a sign that current buffer is in mail-like.
 478 You should also check the mode name to get more reliable results."
 479   (or (memq major-mode '(message-mode mail-mode))
 480       (save-excursion
 481         (ti::pmin)
 482         (looking-at "^[-A-Za-z0-9][-A-Za-z0-9]+:"))))
 483
 484 ;;; ----------------------------------------------------------------------
 485 ;;;
 486 (defun ti::mail-header-area-size ()
 487   "Count size of header area.
 488 This function can only be called from a buffer that has
 489 `mail-header-separator'. Function count the characters in the header  area.
 490 You can use this information to determine if the headers have been
 491 changed after the last check.
 492
 493 Return:
 494
 495  nbr
 496  nil        can't find `mail-header-separator'"
 497   (save-excursion
 498     (ti::pmin)
 499     (when (re-search-forward (regexp-quote mail-header-separator) nil t)
 500       (- (point) (point-min)))))
 501
 502 ;;; ----------------------------------------------------------------------
 503 ;;; - This is suitable for RMAIL, GNUS and for individual buffers
 504 ;;;   holding mail or news messages.
 505 ;;;
 506 (defun ti::mail-hmax (&optional move noerr)
 507   "Search max point of header, optionally MOVE and NOERR.
 508 Order is: `mail-header-separator' or find all \"Headers:\" and then
 509 return next line after them. The header must start at `point-min'.
 510
 511 If no point can be found, return `point-min'."
 512   (let ((point (point-min)))
 513     (when (ti::mail-mail-p)
 514       (save-excursion
 515         (ti::pmin)
 516         ;;  VM's "t" key shows all headers, including the
 517         ;;  "From xxxx"foo.com" line which is not actual header, because
 518         ;;  it has no colon. Skip ovber it if we see it.
 519         (if (looking-at "From")
 520             (forward-line 1))
 521         ;;  GNUS 4 sets the mail-header-separator to "" ??
 522         (if (and (not (ti::nil-p mail-header-separator))
 523                  (re-search-forward (regexp-quote mail-header-separator) nil t))
 524             (setq point (match-beginning 0))
 525           ;;  Header:
 526           ;;    Continuing line here
 527           ;;  Header2:
 528           (while (and (looking-at "^[0-9a-zA-z-]+:")
 529                       (progn
 530                         (end-of-line)
 531                         (not (eobp))))
 532             ;;  If this function doesn't move anuy more, then the headers
 533             ;;  have ended.
 534             (if (null (ti::mail-next-field-start 'move))
 535                 (forward-line 1))
 536             (setq point (point))))))
 537     (if (and move point)
 538         (goto-char point))
 539     point))
 540
 541 ;;; ----------------------------------------------------------------------
 542 ;;;
 543 (defun ti::mail-text-start (&optional move)
 544   "Return starting point or text in BODY. Optionally MOVE to it.
 545 If buffer is not mail-like, then return `point-min'.
 546
 547 References:
 548   `mail-header-separator'"
 549   (let ((re         (regexp-quote mail-header-separator))
 550         (point      (point-min)))
 551     (when (ti::mail-mail-p)
 552       (cond
 553        ((save-excursion                 ;Do we find the separator?
 554           (ti::pmin)
 555           (when (re-search-forward re nil t)
 556             (forward-line 1)
 557             (setq point (point)))))
 558        ((setq point (ti::mail-hmax))
 559         (save-excursion
 560           (goto-char point)
 561           (forward-line 1)
 562           (setq point (point))) )
 563        (t
 564         (error "Can't find position.")))
 565       (if (eq point (point-min))        ;Not found
 566           (error "mail-header-separator not found or headers not found.")))
 567     (if (and move point)
 568         (goto-char point))
 569     point))
 570
 571 ;;; ----------------------------------------------------------------------
 572 ;;;
 573 (defun ti::mail-point-at-header-p ()
 574   "Return non-nil if point is at HEADER area of mail."
 575   (< (point) (ti::mail-text-start)))
 576
 577 ;;; ----------------------------------------------------------------------
 578 ;;;
 579 (defun ti::mail-point-at-body-p ()
 580   "Return non-nil if point is at BODY of mail."
 581   (not (ti::mail-point-at-header-p)))
 582
 583 ;;; ----------------------------------------------------------------------
 584 ;;; - Many std emacs dist. functions work so that you have to narrow
 585 ;;;   to headers before you can call the functions.
 586 ;;;
 587 (defun ti::mail-narrow (&optional text)
 588   "Narrows to the headers only. Optionally to TEXT portion."
 589   (if text
 590       (narrow-to-region (ti::mail-text-start 'move) (point-max))
 591     (narrow-to-region (point-min) (ti::mail-hmax))))
 592
 593 ;;; ----------------------------------------------------------------------
 594 ;;; - This is for both GNUS and RMAIL
 595 ;;;
 596 (defun ti::mail-mail-buffer-name ()
 597   "Find original mail buffer whether in GNUS or in RMAIL.
 598
 599 Return:
 600
 601    string       buffer name
 602    nil          if not exist."
 603
 604   ;;  It's amazing that GNUS uses pointers and RMAIL uses string ...
 605   (let ((buffer (if (boundp 'mail-reply-buffer)
 606                     (symbol-value 'mail-reply-buffer))))
 607     (cond                          ;what is the mail YANK buffer name?
 608      ((stringp buffer)
 609       buffer)
 610      ((and (not (null buffer))
 611            (bufferp buffer))
 612       (buffer-name buffer))
 613      (t
 614       nil))))
 615
 616 ;;; ----------------------------------------------------------------------
 617 ;;;
 618 (defun ti::mail-generate-buffer-name (&rest ignore)
 619   "Rename the *mail* buffer to \"*mail* SENDER\". IGNORE args.
 620 You can install this function e.g. into
 621 `my-message-generate-new-buffers' or `mail-setup-hook'"
 622   (interactive "Pbuffer name: ")
 623   (let ((to  (if (string= (buffer-name) " *gnus article copy*") ;; See gnus-msg.el
 624                  (mail-fetch-field "From")
 625                (mail-fetch-field "To")))
 626         (str "*mail*"))
 627     (unless (ti::nil-p to)
 628       (cond
 629        ((setq str (ti::string-match "\\([^@<]+\\)," 1 to))
 630         (setq str (concat str ", ...")))
 631        ((setq str (ti::string-match "\\([^@<]+\\)" 1 to)))
 632        (t
 633         (setq str to)))
 634
 635       (setq str (replace-regexp-in-string "['\"]" "" str)) ;remove extra cruft
 636
 637       (setq str
 638             (concat
 639              (if (ti::mail-news-buffer-p)
 640                  "*post* "
 641                "*mail* ")
 642              str)))
 643     str))
 644
 645 ;;; ----------------------------------------------------------------------
 646 ;;; - The idea is to find three fields and see what they contain,
 647 ;;;   and do they exist?
 648 ;;; - What's the use of this function? Well, when you post an article
 649 ;;;   or mail it, you can call this function from some of those
 650 ;;;   posting hooks to determine what to do with the buffer.
 651 ;;;
 652 ;;; - code lines disabled now so that it buffer can be checked any time
 653
 654 (defun ti::mail-mail-simple-p ()
 655   "Check if buffer contain headers belonging to simple \\[mail].
 656 You can call this only once, just after the buffer is initially created"
 657   (require 'mail-utils)
 658   (let* ((sub (mail-fetch-field "Subject"))
 659          ;;   mail-fetch-field doesn't return nil if field is empty.
 660          (to  (mail-fetch-field "to"))
 661          (news (mail-fetch-field "Newsgroups")))
 662     ;;  When you're replying to message in NEWS, RMAIL, the SUBJ and
 663     ;;  TO fields are already filled.
 664     ;;
 665     ;;  That's why you can only call this function once.
 666     ;;  When you use C-x m, and fill the fields, there is no way
 667     ;;  to detect afterwards if the mail buffer was simple mail or not
 668
 669     (cond
 670      ((or (string-match "news" (symbol-name 'major-mode))
 671           news)
 672       nil)
 673      ((and (ti::nil-p sub)
 674            (ti::nil-p to))
 675       t))))
 676
 677 ;;; ----------------------------------------------------------------------
 678 ;;;
 679 (defun ti::mail-to-list-p ()
 680   "Check if message is meant to be sent to a mailing list.
 681 In GNUS you need to add Group parameter `to-list' containing address
 682 to mailing list or otherwise Group is not considered mailing list."
 683   (when (featurep 'gnus)
 684     (let* ((group (ti::mail-news-group)))
 685       (when (stringp group)
 686         (gnus-group-get-parameter group 'to-list) ))))
 687
 688 ;;}}}
 689 ;;{{{ macros: VM, RMAIL, GNUS
 690
 691 ;;; ----------------------------------------------------------------------
 692 ;;;
 693 (put 'ti::mail-vm-macro 'lisp-indent-function 0)
 694 (put 'ti::mail-vm-macro 'edebug-form-spec '(body))
 695 (defmacro ti::mail-vm-macro (&rest body)
 696   "Do BODY in VM's active buffer.
 697 The `save-excursion' -- set buffer form is executed."
 698   (`
 699    (let* ((BuffeR-S  (when (boundp 'vm-mail-buffer)
 700                        (symbol-value 'vm-mail-buffer))))
 701      (if (or (null BuffeR-S)
 702              (not (buffer-live-p (get-buffer BuffeR-S))))
 703          (error "vm-mail-buffer invalid")
 704        (with-current-buffer BuffeR-S
 705          (,@ body))))))
 706
 707 ;;; ----------------------------------------------------------------------
 708 ;;;
 709 (put 'ti::mail-mh-macro 'lisp-indent-function 0)
 710 (put 'ti::mail-mh-macro 'edebug-form-spec '(body))
 711 (defmacro ti::mail-mh-macro (&rest body)
 712   "Do BODY in MH's active buffer.
 713 The `save-excursion' -- set buffer form is executed."
 714   (`
 715    (let* ((BuffeR-S  (when (boundp 'mh-show-buffer)
 716                        (symbol-value 'mh-show-buffer))))
 717      (if (or (null BuffeR-S)
 718              (not (buffer-live-p (get-buffer BuffeR-S))))
 719          (error "mh-show-buffer invalid")
 720        (with-current-buffer BuffeR-S
 721          (,@ body))))))
 722
 723 ;;; ----------------------------------------------------------------------
 724 ;;;
 725 (put 'ti::mail-gnus-macro 'lisp-indent-function 0)
 726 (put 'ti::mail-gnus-macro 'edebug-form-spec '(body))
 727 (defmacro ti::mail-gnus-macro (&rest body)
 728   "Do BODY in Gnus `gnus-article-buffer' if it exists.
 729 The `save-excursion' -- set buffer form is executed."
 730   (`
 731    (let* ((BuffeR-S  (when (boundp 'gnus-article-buffer)
 732                        (symbol-value 'gnus-article-buffer))))
 733      (if (or (null BuffeR-S)
 734              (not (buffer-live-p (get-buffer BuffeR-S))))
 735          (error "gnus-article-buffer invalid")
 736        (with-current-buffer BuffeR-S
 737          (,@ body))))))
 738
 739 ;;; ----------------------------------------------------------------------
 740 ;;;
 741 (put 'ti::mail-rmail-macro 'lisp-indent-function 0)
 742 (put 'ti::mail-rmail-macro 'edebug-form-spec '(body))
 743 (defmacro ti::mail-rmail-macro (&rest body)
 744   "Do BODY in RMAIL's active buffer. You have be in RMAIL summary."
 745   (`
 746    (let* ((BuffeR-R
 747            ;;  This variable is available in Rmail-summary
 748            ;;
 749            (or (if (boundp 'rmail-buffer) (symbol-value 'rmail-buffer))
 750                (get-buffer "RMAIL"))))
 751      (if (or (null BuffeR-R)
 752              (not (buffer-live-p (get-buffer BuffeR-R))))
 753          (error "rmail-buffer buffer invalid")
 754        (with-current-buffer BuffeR-R
 755          (,@ body))))))
 756
 757 ;;; ----------------------------------------------------------------------
 758 ;;;
 759 (put 'ti::mail-rmail-do-message-macro 'lisp-indent-function 2)
 760 (put 'ti::mail-rmail-do-message-macro 'edebug-form-spec '(body))
 761 (defmacro ti::mail-rmail-do-message-macro (nbr mode &rest body)
 762   "Go to message without showing it and execute body.
 763 Must be in RMAIL buffer already.
 764
 765 Input:
 766  NBR    message number, like `rmail-current-message'
 767  MODE   if non-nil then the area narrows to full stored message
 768         with original headers. If nil, then area narrows to displayed
 769         message.
 770  BODY   forms to execute in are narrowed to message."
 771   (`
 772    (let ((beg (rmail-msgbeg (, nbr)))
 773          (end (rmail-msgend (, nbr))))
 774      (save-window-excursion
 775        (ti::widen-safe
 776          (goto-char beg)
 777          (forward-line 1)
 778          (if (null (, mode))
 779              (search-forward "\n*** EOOH ***\n" end t))
 780          (narrow-to-region (point) end)
 781          (goto-char (point-min))
 782          (,@ body))))))
 783
 784 ;;; ----------------------------------------------------------------------
 785 ;;;
 786 (defun ti::mail-rmail-copy-message (&optional nbr separate)
 787   "Copy message NBR with header. Defaults to `rmail-current-message'.
 788 Current buffer must me in RMAIL already.
 789
 790 Input:
 791
 792   NBR       message number
 793   SEPARATE  if non-nil, then the headers and message body are returned
 794             separately in format (hdr-string . body-string)
 795
 796 Return:
 797
 798  string
 799  list       see mode."
 800   (interactive)
 801   (let* (beg
 802          end
 803          hdr
 804          ret)
 805     (setq nbr  (or nbr rmail-current-message)
 806           beg  (rmail-msgbeg nbr)
 807           end  (rmail-msgend nbr))
 808
 809     (or (integerp nbr)
 810         (error "NBR %s" nbr))
 811     ;; The BEG isn't exactly the message beginning, skip 3 lines,
 812     ;; also don't copy the original heades only.
 813     ;;
 814     ;; \1f\f
 815     ;; 1, answered,,
 816     ;; Summary-line: 23-Mar #Please Help Yourself, Help Ot...
 817     ;; <ORIGINAL HEADERS>
 818     ;;
 819     ;; *** EOOH ***
 820     ;; <HEADERS SHOWN IN RMAIL>
 821     ;;
 822     ;; <MESSAGE BODY>
 823     (ti::widen-safe
 824       (goto-char beg) (forward-line 3)
 825       (setq beg (point))
 826       (re-search-forward "^[ \t]*$")
 827       (setq hdr (buffer-substring beg (point)))
 828       ;;  Already sitting at empty line, move away.
 829       (forward-line 1)
 830       (re-search-forward "^[ \t]*$")
 831       (setq beg (point))
 832       ;;  Now make HDR + BODY of message
 833       (if separate
 834           (setq ret (cons hdr (buffer-substring beg end)))
 835         (setq ret (concat hdr (buffer-substring beg end)))))
 836     ret))
 837
 838 ;;}}}
 839
 840 ;;{{{ PGP general, tests
 841
 842 ;;; ----------------------------------------------------------------------
 843 ;;;
 844 (defun ti::mail-pgp-v3xx-p ()
 845   "Check if X-Pgp v3.xx header signing is in use.
 846 It should have VALUE = KEYWORD; statement."
 847   (save-excursion
 848     (ti::pmin)
 849     (when (re-search-forward "X-Pgp-signed" nil t)
 850       (forward-line 1)
 851       ;;
 852       ;; KEYWORD=VALUE;
 853       (looking-at "^[ \t]+.*=.*;"))))
 854
 855 ;;; ----------------------------------------------------------------------
 856 ;;;
 857 (defun ti::mail-pgp-p ()
 858   "Check if buffer contain PGP. It must have left flushed regexp:
 859 \"^-----BEGIN.*PGP +\\(SIGNATURE\\|SIGNED\\\\|MESSAGE)\", otherwise this
 860 string may be inside quoted text.
 861
 862 If there is X-pgp-sig.*: header, then it's also considered PGP message."
 863   (let ((max (ti::mail-hmax)))          ;headers ?
 864     ;;  if headers was found use that.
 865
 866     (setq max (if (eq (point-min) max)
 867                   nil
 868                 max))
 869     (save-excursion
 870       (ti::pmin)
 871       (or (let (case-fold-search)
 872             (re-search-forward
 873              "^-----BEGIN PGP \\(SIGNATURE\\|SIGNED\\|MESSAGE\\)"
 874              nil t))
 875           (progn
 876             ;;  The New PGP in headers standard.
 877             (re-search-forward "^X-Pgp-Sig.*:" max t))))))
 878
 879 ;;; ----------------------------------------------------------------------
 880 ;;;
 881 (defun ti::mail-pgp-signed-conventional-p ()
 882   "Return t if message is conventionally signed."
 883   (save-excursion (ti::pmin) (ti::mail-pgp-re-search 'sig)))
 884
 885 ;;; ----------------------------------------------------------------------
 886 ;;;
 887 (defun ti::mail-pgp-signature-detached-p  ()
 888   "Return (beg . end) if there is detached signature."
 889   (let* ((point  (point))
 890          beg
 891          end)
 892     (prog1 (save-excursion
 893              (ti::pmin)
 894              (unless (ti::mail-pgp-re-search 'msg) ;Must not exist
 895                (and (setq beg (ti::mail-pgp-re-search 'sig))
 896                     (setq end (ti::mail-pgp-re-search 'sige))
 897                     (cons beg end))))
 898       (goto-char point))))
 899
 900 ;;; ----------------------------------------------------------------------
 901 ;;;
 902 (defun ti::mail-pgp-signed-conventional-multi-p ()
 903   "Return t if message is signed conventionally multiple times."
 904   (save-excursion
 905     (ti::pmin)
 906     (ti::mail-pgp-re-search 'sig 'move)
 907     (forward-line 1)
 908     (ti::mail-pgp-re-search 'sig 'move)))
 909
 910 ;;; ----------------------------------------------------------------------
 911 ;;;
 912 (defun ti::mail-pgp-signed-xpgp-p ()
 913   "Return t if message is X-pgp signed.
 914 There may be X-Pgp headers, but if the message is already
 915 verified, that removes the signature around encrypted
 916 message  \"- -----BEGIN PGP MESSAGE-----\"
 917        --> \"-----BEGIN PGP MESSAGE-----\"
 918 In this case the message is no more in signed format,
 919 but in encrypted format."
 920   (and (ti::mail-pgp-headers-p)
 921        ;;  See documentation above
 922        (save-excursion
 923          (ti::pmin)
 924          (null (re-search-forward
 925                 (concat "^" (ti::mail-pgp-msg-begin-line))
 926                 nil t)))))
 927
 928 ;;; ----------------------------------------------------------------------
 929 ;;;
 930 (defun ti::mail-pgp-signed-p ()
 931   "Return t is message is conventionally or X-pgp signed."
 932   (or (ti::mail-pgp-signed-xpgp-p)
 933       (ti::mail-pgp-signed-conventional-p)))
 934
 935 ;;; ----------------------------------------------------------------------
 936 ;;;
 937 (defun ti::mail-pgp-public-key-p (&optional point)
 938   "Find public key delimiter from current point forward or using POINT."
 939   (save-excursion
 940     (goto-char (or point (point)))
 941     (re-search-forward (ti::mail-pgp-pkey-begin-line) nil t)))
 942
 943 ;;; ----------------------------------------------------------------------
 944 ;;;
 945 (defun ti::mail-pgp-remail-p ()
 946   "Check if This is remailer message."
 947   (save-excursion
 948     (ti::pmin)
 949     (re-search-forward "[:#][:#]+\nReply-To" nil t)))
 950
 951 ;;; ----------------------------------------------------------------------
 952 ;;;
 953 (defun ti::mail-pgp-comment-file-p (&optional point)
 954   "You can send binary files with base64 signing.
 955 This function checks if comment block has have words 'File: FILE '.
 956
 957 Example:
 958
 959  -----BEGIN PGP MESSAGE-----
 960  Version: 2.6.3ia
 961  Comment: Base64 signed. File: tm.tar uncompresses to approx. 20K
 962
 963 Input:
 964
 965   POINT     search start point
 966
 967 Return:
 968
 969   nil
 970   file"
 971   (save-excursion
 972     (if point (goto-char point))
 973     (when (re-search-forward "^Comment:.*File:? +\\([^ \t,]+\\)" nil t)
 974       (match-string 1))))
 975
 976 ;;; ----------------------------------------------------------------------
 977 ;;;
 978 (defun ti::mail-pgp-encrypted-p (&optional check-pgp-dash-line)
 979   "Check if there is encrypted PGP message.
 980 It must have left flushed tag. The start point of match is returned.
 981 The following tag will tell if if the message is encrypted.
 982
 983   ::
 984   Encrypted: PGP
 985
 986 Input:
 987
 988   CHECK-PGP-DASH-LINE   if the tag is not found, message _could_ be signed
 989                         if there is -----BEGIN PGP MESSAGE----- tag.
 990                         When this flag is non-nil, it also checks this
 991                         case. Beware: message could be base64 signed too,
 992                         so the encrypted-p test may not be exactly right."
 993   (save-excursion
 994     (ti::pmin)
 995     (if (re-search-forward "::[ \t]*\nEncrypted:[ \t]*PGP" nil t)
 996         (match-beginning 0)
 997       (when check-pgp-dash-line
 998         (ti::pmin)
 999         (car-safe (ti::mail-pgp-block-area 'msg))))))
1000
1001 ;;; ----------------------------------------------------------------------
1002 ;;;
1003 (defun ti::mail-pgp-normal-p (&optional point)
1004   "Check if there is any PGP in current buffer from POINT forward.
1005 The beginning point of PGP is returned."
1006   ;; Must find at least two lines, maybe BEG and END
1007   (let ((re   (ti::mail-pgp-any-pgp-line-regexp 'acnhor))
1008         ret)
1009     (save-excursion
1010       (ti::pmin)
1011       (when (re-search-forward re nil t)
1012         (setq ret (match-beginning 0))
1013         (if (null (re-search-forward re nil t))
1014             (setq ret nil)))
1015       ret)))
1016
1017 ;;; ----------------------------------------------------------------------
1018 ;;;
1019 (defun ti::mail-pgp-headers-p ()
1020   "Return t if PGP information is in headers.
1021 Searches string 'X-Pgp-Signed:' and return end of match or nil."
1022   (let ((psig           "^X-Pgp-Signed:")
1023         (hmax           (ti::mail-hmax)))
1024     (save-excursion
1025       (ti::pmin)
1026       (re-search-forward psig hmax t))))
1027
1028 ;;; ----------------------------------------------------------------------
1029 ;;;
1030 (defun ti::mail-pgp-re (str)
1031   "Add possible beginning anchor if STR doesn't have one."
1032   (if (not (char= (aref str 0) ?^))
1033       (concat "^" str)))
1034
1035 ;;; ----------------------------------------------------------------------
1036 ;;;
1037 (defun ti::mail-pgp-block-area-kill-forward (mode &optional move)
1038   "Search PGP block forward and kill it. If no block found, do nothing.
1039
1040 Input:
1041   MODE      choices are explained in `ti::mail-pgp-block-area'.
1042   MOVE      if non-nil, move to killed region begin point."
1043   (let* (reg)
1044     (when (setq reg (ti::mail-pgp-block-area mode))
1045       (delete-region (car reg) (cdr reg))
1046       (when move (goto-char (car reg))))))
1047
1048 ;;; ----------------------------------------------------------------------
1049 ;;;
1050 (defun ti::mail-pgp-block-area (mode &optional inside max nstrict)
1051   "Return (beg . end) of PGP block from current point forward.
1052
1053 Input:
1054   MODE      nil   search signed start line..
1055             'sig  search signature start instead.
1056             'signed  search signed message area
1057             'pkey search public key block start instead.
1058             'msg  search for pgp base64 signed \"message\"
1059             'any  go to `point-min' and search beginning of any
1060                   PGP line, then go to the end of buffer and search
1061                   backward any PGP line.  The lines must not be at
1062                   same position.  This gives you the whole PGP
1063                   region.
1064
1065   INSIDE    if non-nil, beg and end are 'inside' without the PGP tags.
1066   MAX       max point to search
1067   NSTRICT   If non-nil; then the pgp bounds must not be left flushed,
1068             but can contains \"- -\".
1069 Return:
1070   (beg . end)
1071   nil"
1072   (let ((re1
1073          (cond
1074           ((null mode)      (ti::mail-pgp-signed-begin-line))
1075           ((eq 'sig  mode)  (ti::mail-pgp-signature-begin-line))
1076           ((eq 'pkey mode)  (ti::mail-pgp-pkey-begin-line))
1077           ((eq 'msg  mode)  (ti::mail-pgp-msg-begin-line))
1078           ((eq 'any  mode)  (ti::mail-pgp-any-pgp-line-regexp (not nstrict)))
1079           ((eq 'signed  mode)  (ti::mail-pgp-signed-begin-line))
1080           (t
1081            (error "unknown mode"))))
1082         (re2
1083          (cond
1084           ((null mode)      (ti::mail-pgp-signed-end-line))
1085           ((eq 'sig  mode)  (ti::mail-pgp-signature-end-line))
1086           ((eq 'pkey mode)  (ti::mail-pgp-pkey-end-line))
1087           ((eq 'msg  mode)  (ti::mail-pgp-msg-end-line))
1088           ((eq 'signed  mode)  (ti::mail-pgp-signed-end-line))))
1089         ret
1090         beg
1091         end)
1092     (save-excursion
1093       (cond
1094        ((eq mode 'any)
1095
1096         (when (re-search-forward re1 max t)
1097           (setq beg (match-beginning 0))
1098           (when (re-search-forward re1 max t)
1099             (beginning-of-line)
1100             (when (not (eq beg (point)))
1101               (forward-line 1)
1102               (setq ret (cons beg (point)))))))
1103        (t
1104         (if nstrict
1105             (setq re1    (concat "^-? ?" re1)
1106                   re2    (concat "^-? ?" re2))
1107           (setq re1    (concat "^" re1)
1108                 re2    (concat "^" re2)))
1109         (when (re-search-forward re1 max t)
1110           (if inside
1111               (forward-line 1)
1112             (beginning-of-line))
1113           (setq beg (point))
1114
1115           (when (re-search-forward re2 max t)
1116             (if inside
1117                 (beginning-of-line)
1118               (forward-line 1))
1119
1120             (setq end (point))
1121             (setq ret (cons beg end)))))))
1122     ret))
1123
1124 ;;; ----------------------------------------------------------------------
1125 ;;;
1126 (defun ti::mail-pgp-re-search (&optional mode move end no-anchor)
1127   "Re-search-forward to find -----BEGIN.*SIGNED.
1128
1129 Input:
1130   MODE          nil     search signed start line.
1131                 'sig    search signature start.
1132                 'sige   search signature block end.
1133                 'pkey   search public key block start.
1134                 'pkeye  search public key block end.
1135                 'msg    search for pgp base64 signed \"message\"
1136                         This also finds conventionally crypted tag.
1137                 'kid    search for  'Key for user ID: '
1138                 'kpub   search for 'pub   512/47141D35 1996/06/03 ...'
1139                         note: match level 1 matches 0x code 47141D35
1140   MOVE          flag    non-nil moves point to found point
1141   END           flag    use `match-end' instead of math-beginning.
1142   NO-ANCHOR     flag    non-nil disables using '^' anchor.
1143
1144 Return:
1145   point         ,beginning of line
1146   nil           ,if not found"
1147   (let ((re   (cond
1148                ((null     mode)  (ti::mail-pgp-signed-begin-line))
1149                ((eq 'sig  mode)  (ti::mail-pgp-signature-begin-line))
1150                ((eq 'sige mode)  (ti::mail-pgp-signature-end-line))
1151                ((eq 'pkey mode)  (ti::mail-pgp-pkey-begin-line))
1152                ((eq 'pkeye mode) (ti::mail-pgp-pkey-end-line))
1153                ((eq 'msg  mode)  (ti::mail-pgp-msg-begin-line))
1154                ((eq 'kid  mode)  "Key for user ID: ")
1155                ((eq 'kpub mode)
1156                 "pub[ \t]+[0-9]+/\\([A-Z0-9]\\)+[ \t]+.*/.*/[0-9]")
1157                (t
1158                 (error "unknown mode"))))
1159         point)
1160     (when (and (null no-anchor)
1161                (not (memq mode '(kid))))
1162       ;;  suppose encrypted and signed message
1163       ;;  - -----END PGP MESSAGE-----
1164       ;;
1165       (setq re (concat "^-? ?" re)))
1166     (save-excursion
1167       (if (or (looking-at re)
1168               (re-search-forward re nil t))
1169           (if end
1170               (setq point (match-end 0))
1171             (setq point (match-beginning 0)))))
1172     (if (and move point)
1173         (goto-char point))
1174     point))
1175
1176 ;;}}}
1177 ;;{{{ PGP misc
1178
1179 ;;; ----------------------------------------------------------------------
1180 ;;;
1181 (defun ti::mail-pgp-exe-version-string (&optional exe-file-location)
1182   "Call pgp/gpg executable to find out its version number.
1183 EXE-FILE-LOCATION defaults to \"pgp\" but can also be absolute path."
1184   (with-temp-buffer
1185     (call-process (or exe-file-location "pgp")
1186                   nil
1187                   (current-buffer)
1188                   nil
1189                   ;;  - With PGP will say "illegal option", but will print
1190                   ;;    the logo screen.
1191                   ;;  - With GPG will print logo screen.
1192                   "--help")
1193     (ti::pmin)
1194     (when (or (re-search-forward
1195                "Pretty Good Privacy(tm) +\\([^\r\n ]+\\)" nil t)
1196               (re-search-forward
1197                "gpg (GnuPG) +\\([^\r\n ]+\\)" nil t))
1198       (match-string 1))))
1199
1200 ;;; ----------------------------------------------------------------------
1201 ;;;
1202 (defun ti::mail-pgp-data-type ()
1203   "Examine pgp data packet type by searching _forward_.
1204 Return:
1205   'base64 'pgp 'conventional or nil"
1206   (let ((re  (ti::mail-pgp-any-pgp-line-regexp 'anchor))
1207         char)
1208     (save-excursion
1209       (when (and (re-search-forward re nil t)
1210                  (re-search-forward "^$" nil t))
1211         ;;  #todo: Check first character. Actually we should check bit mask...
1212         ;;
1213         ;;  -----BEGIN PGP MESSAGE-----
1214         ;;  Version: 2.6.2
1215         ;;  Comment: Encrypted by xxx
1216         ;;
1217         ;;  hEwDYCggxO/bFq0
1218         (forward-line 1)
1219         (setq char (following-char))
1220         (cond
1221          ((char= char ?p) 'conventional)
1222          ((char= char ?h) 'pgp)
1223          ((char= char ?o) 'base64))))))
1224
1225 ;;; ----------------------------------------------------------------------
1226 ;;;
1227 (defun ti::mail-pgp-trim-buffer ()
1228   "Trim buffer: pgp blocks are left flushed and junk around them is removed."
1229   (let ((stat  t)
1230         region)
1231     (save-excursion
1232       (ti::pmin)
1233       (while (and stat
1234                   (setq region (ti::mail-pgp-block-area 'any)))
1235
1236         (when (setq stat (ti::mail-pgp-chop-region (car region) (cdr region)))
1237           (goto-char (cdr stat)))))))
1238
1239 ;;; ----------------------------------------------------------------------
1240 ;;; - This is needed after finger or http call to clean up all unnecessary
1241 ;;;   tags around the PGP key.
1242 ;;;
1243 (defun ti::mail-pgp-chop-region (beg end)
1244   "Delete junk around BEG END from pgp public key block.
1245 Area BEG END that correspond to pgp begin and end
1246 lines (call `ti::mail-pgp-block-area' with argument 'any),
1247 then we chop the public key region so that only the pgp area
1248 is left without additional garbage.
1249
1250 Return
1251  (beg .end)         the canonilized area of PGP block
1252
1253 Example:
1254
1255 <PRE>
1256 <SAMP>      -----BEGIN PGP PUBLIC KEY BLOCK-----</SAMP>
1257 <SAMP>      Version: 2.6.3ia</SAMP>
1258 </PRE>
1259 <PRE>
1260 <SAMP>      mQBNAzGzQ2MAAAECAM4p2THKCpNjYXDLpsg4sLHyEiNxJwQuEYfipdTj</SAMP>
1261 <SAMP>      p5CPHN+0LkphcmkgQWFsdG8sIEZpbmxhbmQgPGphcmkuYWFsdG9AbnRj</SAMP>
1262 <SAMP>      LmNvbT6JAFUDBRAxs0O+wLrt1UcUHTUBAbMhAf9Qgh6EznEcY2OUOIPg</SAMP>
1263 <SAMP>      =46gx</SAMP>
1264 <SAMP>      -----END PGP PUBLIC KEY BLOCK-----</SAMP>
1265
1266 This is converted into
1267
1268 -----BEGIN PGP PUBLIC KEY BLOCK-----
1269 Version: 2.6.3ia</SAMP>
1270
1271 mQBNAzGzQ2MAAAECAM4p2THKCpNjYXDLpsg4sLHyEiNxJwQuEYfipdTj
1272 p5CPHN+0LkphcmkgQWFsdG8sIEZpbmxhbmQgPGphcmkuYWFsdG9AbnRj
1273 LmNvbT6JAFUDBRAxs0O+wLrt1UcUHTUBAbMhAf9Qgh6EznEcY2OUOIPg
1274 =46gx
1275 -----END PGP PUBLIC KEY BLOCK-----"
1276   (save-excursion
1277     (goto-char beg) (beginning-of-line)
1278     (ti::narrow-safe (point) (progn
1279                                (goto-char end)
1280                                (end-of-line)
1281                                (point))
1282       (ti::buffer-fill-region-spaces (point-min) (point-max))
1283       (ti::pmin)
1284       (re-search-forward "-----END")
1285       (goto-char (match-beginning 0))
1286       (if (> (current-column) 0)     ;Nothing to do, it's left flushed
1287           (delete-rectangle (point-min) (point)))
1288       (ti::pmin)
1289       (ti::buffer-replace-regexp "<.*$" 0 "")
1290       ;;  Because the last line does not have newline, the
1291       ;;  previous regexp doesn't match. Fix the last line too.
1292       (goto-char (point-max))
1293       (beginning-of-line)
1294       (let (case-fold-search)           ;be sensitive
1295         ;;  -----END PGP PUBLIC KEY BLOCK-----
1296         (if (and (looking-at ".*[A-Z]-----\\(.*\\)")
1297                  (match-end 1))
1298             (ti::replace-match 1)))
1299       (setq beg (point-min)
1300             end (point-max))))
1301   (cons beg end))
1302
1303 ;;}}}
1304 ;;{{{ PGP signed headers
1305
1306 ;;; ...................................................... &pgp-header ...
1307
1308 ;;; ----------------------------------------------------------------------
1309 ;;;
1310 (defun ti::mail-pgp-header-kill-in-body ()
1311   "Kill headers that are inserted into the body of message.
1312 If there is no headers, this function does nothing.
1313
1314 --text follows this line--  [or empty line after headers]
1315 ##<no spaces>
1316 Header1: content
1317 Header2: content
1318 <empty line>
1319 BODY"
1320   (let* (beg)
1321     (save-excursion
1322       (ti::mail-text-start 'move)
1323       (setq beg (point))
1324       (when (and (looking-at "^##\n")
1325                  (re-search-forward "^$" nil t))
1326         (delete-region beg (point))))))
1327
1328 ;;}}}
1329 ;;{{{ PGP ASCII armor
1330
1331 ;;; ....................................................... &pgp-armor ...
1332
1333 ;;; ----------------------------------------------------------------------
1334 ;;;
1335 (defun ti::mail-pgp-data-char-to-int (char)
1336   "Process PGP ascii armor data.
1337 Input is ASCII armor CHAR (as one string). Function return respective int."
1338   (let* ((table (concat "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
1339                         "abcdefghijklmnopqrstuvwxyz0123456789+/"))
1340          case-fold-search
1341          str)
1342     (if (null (setq str (ti::string-match
1343                          (concat ".*" (regexp-quote char)) 0 table)))
1344         (error "Armor char is invalid %s " char)
1345       (1- (length str)))))
1346
1347 ;;; ----------------------------------------------------------------------
1348 ;;;
1349 (defun ti::mail-pgp-data-string-to-bin-string (string)
1350   "Process PGP ascii armor data.
1351 Convert quoted printable ASCII armor STRING into binary string."
1352   (let* ((len (length string))
1353          (i    0)
1354          (ret  "")
1355          ch
1356          int
1357          bin)
1358     (while (< i len)
1359       (setq ch (substring string i (1+ i)))
1360       (setq int (inline (ti::mail-pgp-data-char-to-int ch)))
1361       (setq bin (inline (int-to-bin-string int 6)))
1362       (setq ret (concat ret bin))
1363       (incf i))
1364     ret))
1365
1366 ;;; ----------------------------------------------------------------------
1367 ;;;
1368 (defun ti::mail-pgp-data-bin-string-to-int-list(string)
1369   "Process PGP ascii armor data.
1370 Convert 8bit binary byte string \"000001...\" into list of ints."
1371   (let* ((len (/ (length string) 8))
1372          (i   0)
1373          ret
1374          bin
1375          int)
1376     (while (< i len)
1377       (setq bin (substring string (* i 8) (+ 8 (* i 8))))
1378       (setq int (inline (bin-string-to-int bin)))
1379       (incf i)
1380       (push int ret))
1381     (nreverse ret)))
1382
1383 ;;; ----------------------------------------------------------------------
1384 ;;;
1385 (defsubst ti::mail-pgp-data-ascii-armor-convert (string)
1386   "Convert PGP ascii armor STRING(quoted printable) into list of ints."
1387   (ti::mail-pgp-data-bin-string-to-int-list
1388    (ti::mail-pgp-data-string-to-bin-string string)))
1389
1390 ;;; ----------------------------------------------------------------------
1391 ;;;
1392 (defun ti::mail-pgp-data-study-ctb-byte (int)
1393   "From single INT, examine the PGP CTB structure.
1394 Return
1395  nil    ,input was not CTB byte
1396  '(ctb-type length-field)
1397         ctb-type  is
1398         'enc      (pgp encrypted message)
1399         'signed   (signed message)
1400         'secring  (secret keyring)
1401         'pring    (public keyring)
1402         'base64   (base 64 signed)
1403         'crypt    (conventionally crypted)
1404         'raw      (raw literal plaintext)
1405         'trust    (keyring trust packet)
1406         'uid      (user id packet)
1407         'comment  (comment packet)
1408         'unknown  (none of the above...)
1409
1410         length is
1411         nil       no length, unknown length
1412         1 2 4     byte packet length"
1413   (let* ((length-mask   3)     ;; 00000011b
1414          (type-mask     60)    ;; 00111100b
1415          (ctb-mask      128)   ;; 10000000b
1416          (table
1417           '((1  . enc)
1418             (2  . signed)
1419             (5  . secring)
1420             (6  . pring)
1421             (8  . comp)
1422             (9  . crypt)
1423             (11 . raw)
1424             (12 . trust)
1425             (13 . uid)
1426             (14 . comment)))
1427          (type 'unknown)
1428          val
1429          ret)
1430     (when (logand int ctb-mask)
1431
1432       ;; shift to the right 2 bits
1433
1434       (when (setq val (assq (lsh (logand int type-mask) -2) table))
1435         (setq type (cdr val)))
1436
1437       (setq val (logand int length-mask))
1438       (cond
1439        ((eq 0 val)  (setq val 1))
1440        ((eq 1 val)  (setq val 2))
1441        ((eq 1 val)  (setq val 4))
1442        ((eq 3 val)  (setq val nil)))
1443       (setq ret (cons type val)))
1444     ret))
1445
1446 ;;; ----------------------------------------------------------------------
1447 ;;;
1448 (defsubst ti::mail-pgp-stream-study-1-ver (int)
1449   "Return pgp version string from stream INT."
1450   (cond
1451    ((eq 2 int) "2.5")
1452    ((eq 3 int) "2.6")
1453    (t          (error "Invalid Data format."))))
1454
1455 ;;; ----------------------------------------------------------------------
1456 ;;;
1457 (put 'ti::mail-pgp-stream-study-1-key-id 'lisp-indent-function 1)
1458 (put 'ti::mail-pgp-stream-study-1-key-id 'edebug-form-spec '(body))
1459 (defmacro ti::mail-pgp-stream-study-1-key-id (stream result)
1460   "Read MSB and LSB key-id from STREAM to RESULT.
1461 STREAM will be advanced during read."
1462   (`
1463    (let* ((i 0))
1464      (while (< i 4)
1465        (setq (, result) (concat (or (, result)  "")
1466                                 (format "%02x" (car (, stream))))
1467              (, stream) (cdr (, stream))
1468              i          (1+ i)))
1469      (setq (, result) (upcase (, result))))))
1470
1471 ;;; ----------------------------------------------------------------------
1472 ;;;
1473 (defun ti::mail-pgp-stream-study-1-time (stream)
1474   "Read TIME from STREAM to RESULT."
1475   (let* (val1
1476          val2)
1477     ;;  There must be easier way to do, but right now it goes like this
1478     ;;  '(51 158 95 145)
1479     ;;  --> hex 339E 5F91
1480     ;;  --> int 13214  24464  which is in (current-time) format
1481     ;;
1482
1483     (setq val1 (hexl-hex-string-to-integer
1484                 (concat
1485                  (int-to-hex-string (car stream))
1486                  (int-to-hex-string (car (cdr stream)))))
1487
1488           stream (cdr (cdr stream))
1489           val2  (hexl-hex-string-to-integer
1490                  (concat
1491                   (int-to-hex-string (car stream))
1492                   (int-to-hex-string (car (cdr stream))))))
1493     (ti::date-standard-date nil (list val1 val2))))
1494
1495 ;;; ----------------------------------------------------------------------
1496 ;;;
1497 (defun ti::mail-pgp-stream-study-enc (length stream)
1498   "Study the 'enc packet, which has known LENGTH.
1499 STREAM is list of ints, minimum 11 integers, 13 is the full 'enc packet.
1500
1501 Return:
1502  '(version-string
1503    key-msb-hex-string
1504    key-lsb-hex-string
1505
1506    rsa-algorithm                 ;; nil if stream is not long enough
1507    rsa-int (encrypted integer))   ;; nil if stream is not long enough."
1508   (let* ((msb "")
1509          (lsb "")
1510          ver
1511          val
1512          rsa-alg
1513          rsa-int)
1514     ;;  Skip to begin of real data
1515     ;;  CTB   LENGTH     VERSION KEY-MSB KEY-LSB
1516     ;;  1byte 1-4bytes   1byte   4bytes  4bytes
1517     (setq stream (nthcdr (1+ length) stream))
1518     (setq val    (car stream)   stream (cdr stream))
1519     (setq ver (ti::mail-pgp-stream-study-1-ver val))
1520     (ti::mail-pgp-stream-study-1-key-id stream msb)
1521     (ti::mail-pgp-stream-study-1-key-id stream lsb)
1522     (setq rsa-alg (car stream)
1523           rsa-int (cadr stream))
1524     (list ver msb lsb rsa-alg rsa-int)))
1525
1526 ;;; ----------------------------------------------------------------------
1527 ;;;
1528 (defun ti::mail-pgp-stream-study-signed (length stream)
1529   "Study the 'sign packet, which has known LENGTH. STREAM is list of ints.
1530
1531 Return:
1532
1533  '(version-string
1534    md-length
1535    sig-class
1536    timestamp
1537
1538    key-msb-hex-string
1539    key-lsb-hex-string
1540
1541    alg-rsa                  ;; nil if stream is not long enough
1542    alg-md5                  ;; nil if ...
1543    digest                   '(int int);; nil if ...
1544
1545    rsa-algorithm                 ;; nil if stream is not long enough
1546    rsa-int (encrypted integer)   ;; nil if stream is not long enough)"
1547   (let* ((msb "")
1548          (lsb "")
1549          ver
1550          md-length
1551          sig-class
1552          timestamp
1553          alg-rsa
1554          alg-md5
1555          digest)
1556     ;;  Skip to begin of real data
1557     ;;  CTB   LENGTH     VERSION KEY-MSB KEY-LSB
1558     ;;  1byte 1-4bytes   1byte   4bytes  4bytes
1559
1560     (setq stream (nthcdr (1+ length) stream))
1561     (setq ver       (ti::mail-pgp-stream-study-1-ver (car stream))
1562           stream    (cdr stream)
1563           md-length (car stream)
1564           stream    (cdr stream)
1565           sig-class (car stream)
1566           stream    (cdr stream))
1567     (setq timestamp
1568           (ti::mail-pgp-stream-study-1-time stream))
1569     (setq stream (nthcdr 4 stream))
1570     (ti::mail-pgp-stream-study-1-key-id stream msb)
1571     (ti::mail-pgp-stream-study-1-key-id stream lsb)
1572     (setq alg-rsa (car stream)
1573           stream  (cdr stream)
1574           alg-md5 (car stream)
1575           stream  (cdr stream)
1576           digest  (list (car stream) (car (cdr stream))))
1577     (list ver md-length sig-class timestamp msb lsb
1578           alg-rsa alg-md5 digest)))
1579
1580 ;;; ----------------------------------------------------------------------
1581 ;;;
1582 (defun ti::mail-pgp-stream-study-pring (length stream)
1583   "Study the 'pring packet, which has known LENGTH. STREAM is list of ints.
1584
1585 Return:
1586
1587  '(version-string
1588    timestamp
1589    key-msb-hex-string
1590    key-lsb-hex-string)"
1591   (let* ((msb "")
1592          (lsb "")
1593          ver
1594          timestamp
1595          validity)
1596     ;;  Skip to begin of real data
1597     ;;  CTB   LENGTH     VERSION TIME    VALIDITY RSA-ALG
1598     ;;  1byte 1-4bytes   1byte   4bytes  2bytes   1byte
1599     (setq stream (nthcdr (1+ length) stream))
1600     (setq ver       (ti::mail-pgp-stream-study-1-ver (car stream))
1601           stream    (cdr stream))
1602     (setq timestamp
1603           (ti::mail-pgp-stream-study-1-time stream))
1604     (setq stream    (nthcdr 4 stream)
1605           validity  (car stream)
1606           stream    (cdr stream))
1607     ;;  PGP format spec is not clear enough here!
1608     ;;  Don't know where the User ID is...
1609 ;;;    (ti::mail-pgp-stream-study-1-key-id stream msb)
1610 ;;;    (ti::mail-pgp-stream-study-1-key-id stream lsb)
1611     (list ver timestamp validity msb lsb)))
1612
1613 ;;; ----------------------------------------------------------------------
1614 ;;;
1615 (defun ti::mail-pgp-stream-study (ctb stream)
1616   "Study PGP data.
1617
1618 Input:
1619
1620  CTB            in format `ti::mail-pgp-data-study-ctb-byte'
1621  STREAM         dearmored int stream (list of ints including ctb-byte)
1622
1623 Return:
1624
1625   LIST          depends on the ctb, see conversion functions."
1626   (let* ((type  (car ctb))
1627          (len   (cdr ctb)))
1628
1629 ;;;    (ti::d! type)
1630     (cond
1631      ((eq type 'enc)
1632       (ti::mail-pgp-stream-study-enc len stream))
1633      ((eq type 'signed)
1634       (ti::mail-pgp-stream-study-signed len stream))
1635      ((eq type 'base64)
1636       ;; #todo
1637       nil)
1638      ((eq type 'crypt)
1639       ;; #todo
1640       nil)
1641      ((eq type 'pring)
1642       (ti::mail-pgp-stream-study-pring len stream)))))
1643
1644 ;;; ----------------------------------------------------------------------
1645 ;;;
1646 (defun ti::mail-pgp-stream-forward-xpgp ()
1647   "If there is X-Pgp-Signed field, goto signature stream."
1648   (let* ((point (ti::mail-pgp-headers-p)))
1649     (when point
1650       (goto-char point)
1651       ;;  must exist, this call dies if not found
1652       (re-search-forward "Signature[ \t]*=[ \t\n\"]+"))))
1653
1654 ;;; ----------------------------------------------------------------------
1655 ;;;
1656 (defun ti::mail-pgp-stream-forward (&optional any)
1657   "Find PGP data stream block start forward. PGP block must be left flushed.
1658
1659 Input:
1660
1661   ANY       if non-nil, then find any stream (not necessarily left flushed)
1662
1663 Return:
1664
1665   point     cursor is placed in front of stream
1666   nil       If there is no PGP stream block, do nothing."
1667   (let* ((beg   (ti::mail-pgp-msg-begin-line))
1668          (sig   (ti::mail-pgp-signature-begin-line))
1669          (pkey  (ti::mail-pgp-pkey-begin-line))
1670          (re    (concat (if any "" "^") "-----BEGIN"))
1671          (point (point))
1672          (loop  t)
1673          col
1674          ret)
1675     ;; base64
1676     ;; -----BEGIN PGP MESSAGE-----
1677     ;; Version: 2.6.3ia
1678     ;;
1679     ;; owEBbACT/4kAVQMFATOb
1680
1681     ;; normal signature
1682     ;; -----BEGIN PGP SIGNATURE-----
1683     ;; Version: 2.6.3ia
1684     ;; Charset: noconv
1685     ;;
1686     ;; iQBVAwUBM55fkcC67dVHFB01AQGnHwIAqe2OfkdcnQviGzCmy3KddnsE8uFkAeaV
1687
1688     ;; conventional crypt
1689     ;; -----BEGIN PGP MESSAGE-----
1690     ;; Version: 2.6.3ia
1691     ;;
1692     ;; pgAAACN9WXlrJFURU5Xgi+YyN
1693
1694     ;; encrypted
1695     ;; -----BEGIN PGP MESSAGE-----
1696     ;; Version: 2.6.3ia
1697     ;;
1698     ;; hEwDwLrt1UcUHTUBAf9
1699     ;;
1700
1701     ;; Extracted public key
1702     ;; -----BEGIN PGP PUBLIC KEY BLOCK-----
1703     ;; Version: 2.6.3ia
1704     ;;
1705     ;; mQBNAzOW770AAAECANDkXBfEbJk0gW41o52nLiktpThcBY+BMQCY5zyGCyUIbrDp
1706     (while (and loop (re-search-forward re nil t))
1707       (goto-char (match-beginning 0))
1708
1709       (when (or (looking-at beg)
1710                 (looking-at sig)
1711                 (looking-at pkey))
1712         (setq col (current-column))
1713         (when (re-search-forward "^[ \t]*$" nil t)
1714           (setq loop nil)
1715           (forward-line 1)
1716           (move-to-column col)
1717           (setq ret (point))))
1718       (if loop
1719           (end-of-line)))               ;wrong match, Continue search
1720     (unless ret
1721       ;;  none found, return to original position.
1722       (goto-char point))
1723     ret))
1724
1725 ;;; ----------------------------------------------------------------------
1726 ;;;
1727 (defun ti::mail-pgp-stream-forward-and-study (&optional search any)
1728   "Find PGP data stream forward and study it.
1729
1730 If normal search fails, then find X-Pgp-Signed field's first
1731 data stream.
1732
1733 Input:
1734
1735   SEARCH    if non-nil, then search PGP starting from `point-min' if
1736             forward lookup fails.
1737   ANY       if non-nil, find also non-left flushed stream.
1738
1739 Return:
1740
1741   '(CTB . (INFO-LIST))  the CTB type and data for CTB
1742   nil                   no stream found forward."
1743   (interactive)
1744   (let* ((point (point))
1745          ctb
1746          line
1747          list
1748          data
1749          ret)
1750     (when (or (ti::mail-pgp-stream-forward any)
1751               (and search
1752                    (ti::pmin)
1753                    (ti::mail-pgp-stream-forward any))
1754               (ti::mail-pgp-stream-forward-xpgp))
1755       ;;  Will match all base64 characters (approx.)
1756       (setq line (ti::buffer-match "[^ \t\n\"\']+" 0)
1757             list (ti::mail-pgp-data-ascii-armor-convert line)
1758             ctb  (ti::mail-pgp-data-study-ctb-byte (car list))
1759             data (ti::mail-pgp-stream-study ctb list))
1760       (setq ret (cons (car ctb) data)))
1761     (unless ret (goto-char point))     ;Nothing found, return to point
1762     ret))
1763
1764 ;;; ----------------------------------------------------------------------
1765 ;;;
1766 (defun ti::mail-pgp-stream-forward-info (&optional search any)
1767   "Find PGP data stream and read some information. Return string.
1768
1769 Input:
1770
1771   SEARCH    if non-nil, then search PGP starting from `point-min' if
1772             forward lookup fails.
1773   ANY       if non-nil, find also non-left flushed stream."
1774   (let* (ver
1775          time key-id
1776          data
1777          type
1778          ret)
1779     (when (setq data (ti::mail-pgp-stream-forward-and-study search any))
1780       (setq type (car data))
1781       (cond
1782        ((eq type 'signed)
1783         (setq ver       (ti::mail-pgp-stream-data-elt data 'ver)
1784               time      (ti::mail-pgp-stream-data-elt data 'time)
1785               key-id    (ti::mail-pgp-stream-data-elt data 'key-id))
1786         (setq ret (format "Signed by 0x%s %s [v%s.x]" key-id time ver)))
1787        ((eq type 'enc)
1788         (setq ver       (ti::mail-pgp-stream-data-elt data 'ver)
1789               key-id    (ti::mail-pgp-stream-data-elt data 'key-id))
1790         (setq ret (format "Encrypted to 0x%s [v%s.x]" key-id ver)))
1791        ((eq type 'pring)
1792         (setq ver       (ti::mail-pgp-stream-data-elt data 'ver)
1793               time      (ti::mail-pgp-stream-data-elt data 'time))
1794         (setq ret (format "Public key %s [v%s.x]" time ver)))))
1795     ret))
1796
1797 ;;; ----------------------------------------------------------------------
1798 ;;;
1799 (defun ti::mail-pgp-stream-data-elt (data elt)
1800   "Study DATA and Return packet ELT.
1801 DATA must be in the format of `ti::mail-pgp-stream-forward-and-study'
1802 ELT  can be 'ver 'time 'key-id"
1803   (let* ((type (car data))
1804          (pos  (assq
1805                 elt
1806                 (nth
1807                  1
1808                  (assq type
1809                        '(
1810                          (signed ((ver 0) (time 3) (key-id 5)))
1811                          (pring  ((ver 0) (time 1) (key-id 4)))
1812                          (enc    ((ver 0) (key-id 2))) ;No TIME field
1813                          ;; #todo, not ready
1814                          (base64 ((ver 0) (time 3) (key-id 5)))
1815                          (crypt  ((ver 0) (time 3) (key-id 5)))))))))
1816     (if (null pos)
1817         (error "Wrong specification %s %s %s" type elt data)
1818       (nth (nth 1 pos) (cdr data)))))
1819
1820 ;;; Test suite with live data: first ASCII armor bytes
1821 ;;
1822 ;; (setq list (ti::mail-pgp-data-ascii-armor-convert "hEwDwLrt1UcUHTUBA"))
1823 ;; (setq ctb  (ti::mail-pgp-data-study-ctb-byte (car list)))
1824 ;; (setq data (ti::mail-pgp-stream-study ctb list))
1825
1826 ;; Sig data
1827 ;; (setq s "iQBVAwUBM55fkcC67dVHFB01AQGnHwIAqe2OfkdcnQviGzCmy3KddnsE8uFkAeaV")
1828 ;;
1829 ;; (setq list (ti::mail-pgp-data-ascii-armor-convert s))
1830 ;; (setq ctb  (ti::mail-pgp-data-study-ctb-byte (car list)))
1831 ;; (setq data (ti::mail-pgp-stream-study ctb list))
1832
1833 ;;}}}
1834 ;;{{{ PGP key info
1835
1836 ;;; ----------------------------------------------------------------------
1837 ;;;
1838 (defun ti::mail-pgpk-id-lines-in-region (beg end)
1839   "Search all lines in BEG END matching pgp -kvc and -kx lines.
1840
1841 Option -kvc
1842
1843   pub  1024/01234567 1997/05/01 Mar Bar <Bar@bar.com>
1844
1845 Option -kx
1846
1847   Key for user ID: Mr. Bar <bar@bar.com>
1848   1024-bit key, key ID 01234567, created 1997/05/01
1849
1850 And return list of those lines."
1851   (let ((l1
1852          (ti::buffer-grep-lines
1853           "pub[ \t:]+[0-9]+/[A-Z0-9]+[ \t:]+.*/.*/[0-9]" beg end))
1854         (l2 (ti::buffer-grep-lines "[0-9]-bit key, Key ID " beg end)))
1855     (cond
1856      ((and l1 l2) (ti::list-merge-elements l1 l2))
1857      (l1 l1)
1858      (l2 l2))))
1859
1860 ;;; ----------------------------------------------------------------------
1861 ;;;
1862 (defun ti::mail-pgpk-id-0x-lines-in-region (beg end)
1863   "Call `ti::mail-pgpk-id-lines-in-region' on BEG END, return only Key HEX ids."
1864   (let* (ret)
1865     (dolist (line (ti::mail-pgpk-id-lines-in-region beg end))
1866       (when (stringp line)
1867         (push
1868          (or
1869           (ti::string-match "pub[ \t]+[0-9]+/\\([^ \t]+\\)" 1 line)
1870           (ti::string-match "Key ID \\([0-9A-F]+\\)" 1 line))
1871          ret)))
1872     ret))
1873
1874 ;;; ----------------------------------------------------------------------
1875 ;;;
1876 (defun ti::mail-pgpk-public-get-region (&optional beg end buffer relax)
1877   "Get all keys in BEG END from BUFFER and build list of key data.
1878 The blocks searched are in following format.
1879
1880   Key for user ID: Mr. Foo <foo@example.com>
1881   512-bit key, key ID 123456789, created 1996/06/03
1882   Also known as: Mr Foo <bar@bar.com>
1883
1884   -----BEGIN PGP PUBLIC KEY BLOCK-----
1885   [...]
1886   -----END PGP PUBLIC KEY BLOCK-----
1887
1888 Note1:
1889
1890   If there _no_ 'Key for user ID:' string in the buffer, this function
1891   can't find the public key block while it may be there. It is
1892   assumed that each p-key block is _preceded_ by that string.
1893
1894   All anonymous p-key block are skipped.
1895
1896 Note2:
1897
1898   If there are two sequential key-id strings, like
1899   Key for user ID:       <<A
1900   Key for user ID:       <<B
1901   -----BEGIN PGP PUBLIC KEY BLOCK-----
1902
1903   The p-key block in the list for A will be nil.
1904
1905 Note3:
1906
1907    If RELAX argument is non-nil, then the 'Key for user ID:'
1908    must not exit. Only the Public key tags are searched.
1909
1910    Recommended way of informing public keys is however displaying
1911    full public key information and not just PK block
1912
1913 Return:
1914
1915   '((KEY-ID-STRING PUBLIC-KEY_BLOCK)"
1916   (let ((opt  (if relax 'pkey 'kid))
1917         id
1918         block
1919         region
1920         ret
1921         max)
1922     (with-current-buffer (or buffer (current-buffer))
1923       (ti::narrow-safe (or beg (point-min)) (or end (point-max))
1924         (ti::pmin)
1925         (while (ti::mail-pgp-re-search opt 'move)
1926           (setq id (ti::read-current-line))
1927
1928           ;;  If there are two
1929           ;;    Key for user ID:
1930           ;;    Key for user ID:
1931           ;;
1932           ;;  And there is no public key between these two, set the
1933           ;;  search limit to stop to next Key-id line.
1934           (setq max
1935                 (save-excursion
1936                   (end-of-line)
1937                   (setq max (ti::mail-pgp-re-search 'kid))))
1938 ;;;       (ti::d! ">>" id ">>" max (ti::mail-pgp-block-area 'pkey nil max))
1939           (cond
1940            ((setq region (ti::mail-pgp-block-area 'pkey nil max))
1941             (setq block (buffer-substring (car region) (cdr region)))
1942             (goto-char (cdr region)))
1943            (t
1944             ;; Continue search
1945             (end-of-line)))
1946           (push (list id block) ret)
1947           (setq id nil   block nil))))
1948     (nreverse ret)))
1949
1950 ;;}}}
1951 ;;{{{ PGP signature info
1952
1953 ;;; ................................................... &pgp-signature ...
1954
1955 ;;; ----------------------------------------------------------------------
1956 ;;;
1957 (defun ti::mail-pgp-signature-remove (&optional add no-cnv)
1958   "Remove PGP signature (and headers that have included in there).
1959 Below, only lines 7 and 8 are left in buffer.
1960
1961   1   -----BEGIN PGP SIGNED MESSAGE----
1962   2
1963   3   ##                            << Header start mark
1964   4   Header1: content
1965   5   Header2: Content
1966   6                                 << space here
1967   7   test
1968   8
1969   9   -----BEGIN PGP SIGNATURE-----
1970
1971 With ADD flag
1972
1973   The tag lines are reassembled and point sits at the beginning of line 6
1974   and whitespaces around (email) buffer text are deleted.
1975   If tag lines are found while ADD, this function does nothing.
1976
1977 With NO-CNV
1978
1979   When removing signature, do not convert '- -' back into '-'.
1980   Eg. If message is encrypted and signed; it is not desirable to
1981   do this conversion if you just want to strip out the signature to Xpgp.
1982   The '- -' lines must stay there."
1983   (let* ((beg (save-excursion (ti::pmin) (ti::mail-pgp-re-search))))
1984     (cond
1985      ((and add (null beg))
1986       (ti::mail-trim-buffer)
1987       (ti::mail-text-start 'move)
1988       (insert (ti::mail-pgp-signed-begin-line) "\n\n")
1989       (ti::pmax)
1990       (insert "\n" (ti::mail-pgp-signature-begin-line) "\n"))
1991      ((null add)
1992       ;;  there is one thing to fix first, PGP converts lines that have
1993       ;;  double '--' at front
1994       ;;
1995       ;;                --text follows
1996       ;;        -->
1997       ;;                - --text follows
1998       ;;
1999       ;;        Let's correct those lines too.
2000       (when (null no-cnv)
2001         (save-excursion (ti::buffer-replace-regexp "^- -" 0 "-")))
2002       (when beg                         ;Thre is regular PGP sig
2003         ;;  note: We don't trim BODY here, we only remove
2004         ;;  the pgp tag lines. The receiving end should do
2005         ;;  the trimming. (we save one function call)
2006         (goto-char beg)                         ;One newline at beg
2007         (ti::buffer-kill-line 'del 2)           ;TWO lines; important
2008         ;;  Kill included headers
2009         (when (and (looking-at "##\n.*: ")
2010                    (re-search-forward "^$" nil t))
2011           (delete-region beg (1+ (point))))
2012
2013         (when (and (prog1 (setq beg (ti::mail-pgp-re-search 'sig 'move))
2014                      (ti::buffer-kill-line))
2015                    (ti::mail-pgp-re-search 'sige 'move))
2016           (forward-line 1)
2017           (delete-region beg (point))))))))
2018
2019 ;;; ----------------------------------------------------------------------
2020 ;;;
2021 (put 'ti::mail-pgp-signature-normal-do-region 'lisp-indent-function 0)
2022 (put 'ti::mail-pgp-signature-normal-do-region 'edebug-form-spec '(body))
2023 (defmacro ti::mail-pgp-signature-normal-do-region (&rest body)
2024   "Execute BODY and calculate pgp signature region.
2025 In the macro you can use following variables:
2026
2027   `limits'      (area-beg . area-end)
2028   `area-beg'
2029   `area-and'
2030
2031 This macro does nothing if there is no normal PGP signature."
2032   (`
2033    (let (limits
2034          area-beg
2035          area-end)
2036      (setq limits (ti::mail-pgp-block-area 'sig))
2037      (when limits
2038        ;;   Set values
2039        (setq area-beg (car limits)
2040              area-end (cdr limits))
2041        ;;  If these are no used in BODY: no-op Quiet XE ByteCompiler
2042        (if (null area-beg)  (setq area-beg nil))
2043        (if (null area-end)  (setq area-end nil))
2044        (,@ body)))))
2045
2046 ;;; ----------------------------------------------------------------------
2047 ;;;
2048 (defsubst ti::mail-get-article-buffer ()
2049   "Do `set-buffer' to *Article* if it exists. Return nil if no buffer."
2050   (if (boundp 'gnus-article-buffer)
2051       (symbol-value 'gnus-article-buffer)))
2052
2053 ;;; ----------------------------------------------------------------------
2054 ;;;
2055 (put 'ti::mail-with-article-buffer 'lisp-indent-function 0)
2056 (put 'ti::mail-with-article-buffer 'edebug-form-spec '(body))
2057 (defmacro ti::mail-with-article-buffer (&rest body)
2058   "Run BODY in *Article* buffer if it exists."
2059   (`
2060    (let* ((buffer  (ti::mail-get-article-buffer)))
2061      (when (buffer-live-p buffer)
2062        (with-current-buffer buffer
2063          (,@ body))))))
2064
2065 ;;; ----------------------------------------------------------------------
2066 ;;;
2067 (defun ti::mail-pgp-signature-normal-info ()
2068   "Return signature information from normal PGP format.
2069 Return:
2070  ((beg . end) (fld fld ..) (signarure-data sig ..))"
2071   (let (sig-list
2072         info-list
2073         ret)
2074     (ti::mail-pgp-signature-normal-do-region
2075      (save-excursion
2076        (goto-char area-beg)
2077        (forward-line 1)
2078        ;;  Here are the comments and other PGP headers
2079        (while (looking-at "^[^ \t]+:+ .*")
2080          (ti::nconc info-list (ti::read-current-line))
2081          (forward-line 1))
2082        ;; Here is the signature itself
2083        (while (not (>= (point) (cdr limits)))
2084          (if (looking-at "^[^ \t\n]+$")
2085              (ti::nconc sig-list (match-string 0)))
2086          (forward-line 1))
2087        (setq ret (list limits info-list sig-list))))
2088     ret))
2089
2090 ;;; ----------------------------------------------------------------------
2091 ;;;
2092 (defun ti::mail-pgp-sig-header-info-v2xx ()
2093   "Return signature information from X-pgp v2.xx headers.
2094
2095 Reads format:
2096
2097 X-Pgp-Comment: Processed by TinyPgp.el 1.56
2098 X-Pgp-Version: 2.6.3ia
2099 X-Pgp-Charset: noconv
2100 X-Pgp-Signed:
2101         iQBVAwUBMoijBMC67dVHFB01AQGf3QH/dmgc47fx1tvHYPcuKWIz0Fe7HnWXmd63
2102         3IBA6vhSqzbUT4nkKL2QJQX/0Z8I9dkmOahSQNKvU/7qsB9Iw8JwpQ==
2103         =9yu9
2104
2105 Return:
2106  ((beg . end) (fld fld ..) (signature-data sig ..))"
2107   (let* ((case-fold-search t)
2108          (pbase         "X-Pgp-")
2109          (p-re          (concat "^" pbase)) ;pgp regexp for hdrs
2110          (psig          (concat p-re "Signed:"))
2111          (fld-re        (concat
2112                          p-re
2113                          "\\(Version:\\|Charset:\\|Comment:\\|Signed:\\)"))
2114          (hmax          (ti::mail-hmax))
2115          val
2116          sig-list
2117          info-list
2118          beg
2119          end
2120          ret)
2121     (save-excursion
2122       (ti::pmin)
2123       (while (and
2124               hmax
2125               (< (point) hmax)    ;those fwl-line calls may go past...
2126               (re-search-forward fld-re hmax t))
2127         (beginning-of-line)
2128         (if (null beg)                  ;record it NOW
2129             (setq beg (point)))
2130         (cond
2131          ((looking-at (concat psig "[ \t]*\\([^ \t\n]*\\)"))
2132           ;;  Is this the signature itself ? Special handling,
2133           ;;  because spreads multiple lines.
2134           (setq val (ti::remove-properties (match-string 1)))
2135           (if (not (string= "" val))
2136               (ti::nconc sig-list val))
2137           (forward-line 1)
2138           (while (looking-at "^[ \t]+\\([^ \t\n]+\\)")
2139             (ti::nconc sig-list (ti::remove-properties (match-string 1)))
2140             (forward-line 1)))
2141          ;; Nope, some additional PGP header
2142          (t
2143           (ti::nconc info-list (ti::remove-properties (ti::read-current-line)))))
2144         ;;  Because there is already one while loop that says fwd-line,
2145         ;;  we don't want to go furher if it stopped us.
2146         (if (looking-at (concat p-re  "\\|^\t+"))
2147             (forward-line 1)))
2148       (beginning-of-line)
2149       (setq end (point)))
2150
2151     (if sig-list
2152         (setq ret (list (cons beg end) info-list sig-list)))
2153
2154     ret))
2155
2156 ;;; ----------------------------------------------------------------------
2157 ;;;
2158 (defun ti::mail-pgp-signature-header-info-v3xx ()
2159   "Return signature information from X-pgp v3.xx headers.
2160
2161 Return:
2162  '((nil . nil)
2163    (\"Version: x.x.x\" \"Charset: xxxx\" ...)
2164    (signature-string sig-string ..))"
2165   (let ((field  (ti::remove-properties (ti::mail-get-field "X-Pgp-signed")))
2166         info-list
2167         sig-list
2168         elt
2169         list)
2170     (when field
2171       (setq list (ti::mail-mime-parse-header field 'downcase))
2172       ;;  Push adds to the front of list, so beware order of elements
2173       (if (setq elt (assoc "signature" list))
2174           (setq sig-list  (cdr elt)))
2175       (if (setq elt (assoc "comment" list))
2176           (push (concat "Comment: " (car (cdr elt))) info-list))
2177       (if (setq elt (assoc "charset" list))
2178           (push (concat "Charset: " (car (cdr elt))) info-list))
2179       (if (setq elt (assoc "version" list))
2180           (push  (concat "Version: " (car (cdr elt))) info-list  ))
2181       (if info-list
2182           (list (cons nil nil) info-list sig-list)))))
2183
2184 ;;; ----------------------------------------------------------------------
2185 ;;;
2186 (defun ti::mail-pgp-signature-header-info ()
2187   "Return X-pgp header info if X-Pgp header exist."
2188   (if (ti::mail-pgp-v3xx-p)
2189       (ti::mail-pgp-signature-header-info-v3xx)
2190     (ti::mail-pgp-sig-header-info-v2xx)))
2191
2192 ;;; ----------------------------------------------------------------------
2193 ;;;
2194 (defun ti::mail-mime-parse-header (header-string &optional downcase)
2195   "Parse Variable=value HEADER-STRING like and optionally DOWNCASE keywords.
2196
2197 Header-this: var1=value2; var2= val2; var3=\"starts here \"
2198   \" continues here\"; var4= v1,v2,v3;
2199
2200 The VAL returned is different for continued string. It is a list of
2201 individual parts in the parsed. In this case the whole returned value
2202 would be:
2203
2204 '((var1 . (val1))
2205   (var2 . (val2))
2206   (var3 . (\"starts here \" \" continues here\"))
2207   (var4 . (\" v1,v2,v3\")))
2208
2209 Return:
2210   ((var . VAL) (var . VAL) ..)"
2211   (let ((tag-re  "^[ \t]*\\([^ \t\n]+\\)[ \t\"]*=")
2212         (val-re  "[ \t\"]*\\([^\n\"]+\\)")
2213         (buffer  (ti::temp-buffer "*tmp*" 'clear))
2214         name
2215         val
2216         ret)
2217     (with-current-buffer buffer
2218       (insert header-string)
2219       ;; put into same line
2220       (ti::pmin) (ti::buffer-replace-regexp "[ \t]*;[ \t]*" 0 "\n")
2221       ;; Okay now it's in canonical format. First
2222       ;; pick up signature, then delete it and parse other fields.
2223       ;;  Version=2.6.3ia
2224       ;;  Charset=noconv
2225       (ti::pmin)
2226       (while (re-search-forward tag-re nil t)
2227         (setq name (match-string 1)   val nil)
2228         (cond
2229          ((looking-at val-re)           ;VALUE at the same line
2230           (ti::nconc val (match-string 1))
2231           (forward-line 1))
2232          (t
2233           ;;  Multiline
2234           (while (progn (forward-line 1)
2235                         (looking-at val-re))
2236             (ti::nconc val (match-string 1)))))
2237         (if downcase
2238             (setq name (downcase name)))
2239         (push (cons name val) ret)))
2240     (nreverse ret)))
2241
2242 ;;}}}
2243 ;;{{{ PGP public key
2244
2245 ;;; ........................................................ &pgp-pkey ...
2246
2247 ;;; ----------------------------------------------------------------------
2248 ;;;
2249 (defun ti::mail-pgp-pkey-read (&optional raw kill-file)
2250   "Read public key block from current point forward. Point is moved.
2251
2252 Input:
2253
2254   RAW           If non-nil, return only raw public key block.
2255   KILL-FILE     if non-nil, kill temporary file after statement
2256                 'Key extracted to file ...' Once the file is killed the
2257                 message will be removed from buffer."
2258   (let* (beg
2259          end
2260          file
2261          ret)
2262     ;;  No temp files are left on disk
2263     ;;  Remove also the file message from buffer before we read the
2264     ;;  content.
2265     ;;
2266     ;;       Extracting from key ring: '/users/xxx/.pgp/pubring.pgp',\
2267     ;;       userid "xxx".
2268     ;;
2269     ;;       Key for user ID: <xxx@some.fi>
2270     ;;       512-bit key, key ID 8125CAAA, created 1997/06/05
2271     ;;
2272     ;;       -----BEGIN PGP PUBLIC KEY BLOCK-----
2273     (when (and kill-file
2274                (re-search-forward "Key extracted to file.*'\\(.*\\)'" nil t))
2275       (setq file (match-string 1))
2276       (ti::buffer-kill-line)
2277       (ti::file-delete-safe file))
2278     (goto-char (point))
2279     (when (re-search-forward (ti::mail-pgp-pkey-begin-line) nil t)
2280       (re-search-backward "Key for user ID:") (beginning-of-line)
2281       (when raw
2282         (re-search-forward "^-----BEGIN")
2283         (beginning-of-line))
2284       (setq beg (point))
2285       (when (ti::mail-pgp-re-search 'pkeye 'move)
2286         (forward-line 1)
2287         (setq end (point)))
2288       (when (and beg end)
2289         (setq ret (buffer-substring beg end))))
2290     ret))
2291
2292 ;;}}}
2293 ;;{{{ PGP remail
2294
2295 ;;; ----------------------------------------------------------------------
2296 ;;;
2297 (defun ti::mail-pgpr-close ()
2298   "Close reply block by adding '**' to the end.
2299 If there already is '**', do nothing."
2300   (save-excursion
2301     (ti::pmax)
2302     ;;  Remailers need "**" at the end of encrypted block
2303     (if (not (re-search-backward "^\\*\\*" nil t))
2304         (insert "\n**\n"))))
2305
2306 ;;; ----------------------------------------------------------------------
2307 ;;;
2308 (defun ti::mail-pgpr-anonymize-headers (mode &optional no-ins arg1 arg2 hash)
2309   "Destroy header information according to mode and move it to message body.
2310 This function does nothing if first line is not header.
2311
2312 Input:
2313
2314   MODE       'move-to-body moves, all headers to body
2315              'move-to-body-maybe, all headers to body only if
2316              there is not already hash marks.
2317              arg1 is used for subject       defaults to 'dummy'
2318              arg2 is used for organisation  defaults to 'dummy'
2319
2320   NO-INS     Do not insert the hash headers into body, but return them
2321              as list instead.
2322
2323   ARG1 ARG2  used by MODE
2324
2325   HASH       Use hash marks string other that \"##\"
2326
2327 Return:
2328
2329   list"
2330   (let ((hlist  '("In-reply-to"
2331                   "Organization"
2332                   "Subject"))
2333         (empty  " dummy")
2334         (full-string "")
2335         done
2336         ptr
2337         list
2338         str
2339         ret)
2340     (setq hash (or hash "##")
2341           arg1 (or arg1 empty)
2342           arg2 (or arg2 empty))
2343     (save-excursion
2344       (when (ti::mail-mail-p)
2345         (cond
2346          ((memq mode '(move-to-body move-to-body-maybe))
2347           ;;  First check if hash mark is already there
2348           ;;  If mode is "maybe" we don't add new headers.
2349           ;;
2350           ;;  The regexp matches to the end of line, because you may have
2351           ;;  quoted the message
2352           ;;
2353           ;;  jerry>  ##
2354           ;;  jerry>  Subject:  this here
2355           (ti::pmin)
2356           (unless (and (eq mode 'move-to-body-maybe)
2357                        (re-search-forward (concat hash "[ \t]*$") nil t))
2358             (setq ptr hlist)
2359             (dolist (elt ptr)
2360               (setq str (ti::mail-get-field elt))
2361               (when (and str (not (string= empty str)))
2362                 (setq elt (format "%s: %s\n" elt str))
2363                 (push elt list)
2364                 ;;  so that we can match against this later
2365                 ;;
2366                 (setq full-string (concat full-string elt))))
2367             (ti::mail-text-start 'move)
2368             (when list
2369               (setq ret list  done t)
2370               (unless no-ins
2371                 ;;  Remailer hash mark
2372                 (insert hash "\n"))))
2373           ;;  Anonymize some headers
2374           (if arg1
2375               (ti::mail-kill-field "^subject"  arg1))
2376           (if arg2
2377               (ti::mail-kill-field "^organization" arg2))
2378           (when (and done (null no-ins))
2379             (dolist (elt list)
2380               ;;  Copy headers inside message
2381               (insert elt))))
2382          (t
2383           (error "Invalid mode [%s]" mode)))))
2384     ret))
2385
2386 ;;; ----------------------------------------------------------------------
2387 ;;;
2388 (defun ti::mail-pgpr-reply-type (property-string)
2389   "Return remailer reply block type from PROPERTY-STRING.
2390 The 'post' type is not checked, because it relates to Usenet
2391 and can be mixed with other types."
2392   (if (string-match "cpunk\\|eric\\|penet" property-string)
2393       (match-string 0 property-string)))
2394
2395 ;;; ----------------------------------------------------------------------
2396 ;;; used to be: cpunk   Request-Remailing-To
2397 ;;; but nowadays instructions say "Anon-To"
2398 ;;;
2399 (defun ti::mail-pgpr-block (mode &optional type email key latent)
2400   "Return remailer header string defined by mode.
2401 be sure to have <> in the email, which defaults to `user-mail-address'.
2402
2403 Input:
2404
2405   MODE      'epgp -- return encrypted pgp tag.
2406             'post -- return simple Newsgroup post block. 'email'
2407             contains the address of post remailer.
2408             If there is not enough
2409             parameters, say for 'tk, the previous one is used: 't
2410
2411   TYPE      cpunk   Anon-To
2412             eric    Anon-Send-To
2413             penet   X-Anon-To
2414             post    Anon-Post-To Usenet
2415
2416   EMAIL     Parameter for type
2417   KEY       Parameter for type
2418   LATENT    Parameter for type"
2419   (let* ((reply
2420           (cond
2421            ((string= type "cpunk")  "Anon-To")
2422            ((string= type "eric")   "Anon-To")
2423            ((string= type "penet")  "X-Anon-To")
2424            ((string= type "post")   "Anon-Post-To")
2425            ((memq mode '(epgp post)))   ;Ok; skip
2426            ((error "Unknown type '%s'" type)))))
2427     (setq email (or email user-mail-address))
2428     (cond
2429      ((equal mode 'epgp)
2430       "::\nEncrypted: PGP\n\n")
2431      ((equal mode 'post)
2432       (concat
2433        "::\n"
2434        "Anon-Post-To: " (or email (error "invalid args.")) "\n"
2435        "Cutmarks: --\n"))
2436      ((and (stringp email) (stringp key) (stringp latent))
2437       (format "::\n%s: %s\nEncrypt-Key: %s\nLatent-Time: %s\n"
2438               reply email key latent))
2439      ((and (stringp email) (stringp latent))
2440       (format "::\n%s: %s\nLatent-Time: %s\n" reply email latent))
2441      ((and (stringp email) (stringp key))
2442       (format "::\n%s: %s\nEncrypt-Key: %s\n" reply email key))
2443      ((or (stringp email))
2444       (format "::\n%s: %s\n" reply email))
2445      (t
2446       (error "Wrong args '%s' '%s'" mode type )))))
2447
2448 ;;; ----------------------------------------------------------------------
2449 ;;;
2450 (defun ti::mail-pgpr-reply-block (pgp-email)
2451   "Return reply block header.
2452 Should be inserted just before PGP crypted message to PGP-EMAIL."
2453   (format "Reply-Block:\n::\nAnon-To: %s\n\n" pgp-email))
2454
2455 ;;; ----------------------------------------------------------------------
2456 ;;;
2457 (defun ti::mail-pgpr-parse-levien-list (&optional buffer control-list)
2458   "Parse remailer list finger <remailer-list@kiwi.cs.berkeley.edu>.
2459 The parsing starts from current point forward.
2460
2461 Input:
2462
2463   BUFFER            defaults to current buffer
2464   CONTROL-LIST      '(remailer-alias  (prop-no-list) [(prop-add-list)])
2465                     This control list says 'if REGEXP matches the
2466                     email address, remove all properties listed in
2467                     prop-no-list and add all properties listed in
2468                     prop-add-list.
2469
2470                     So, if you're sure that the levien-list has some
2471                     faulty entries, e.g. say remailer@replay.com doesn't
2472                     have feature 'ek' although levien list contains that,
2473                     your control-list is like this. The ek property
2474                     is removed even if the list says otherwise.
2475
2476                     '(\"replay\" '(\"ek\"))
2477
2478 Return:
2479
2480   '((alias remailer property_string (property property ...))
2481     (alias remailer property_string (p p p ..)))
2482
2483   The properties are sorted: cpunk mix pgp..."
2484   (let ((re  (concat
2485               "^[ \t]*$remailer{[\"']\\(.*\\)[\"']}.*=[ \t]*[\"']"
2486               "<\\(.*\\)>[ \t]+\\(.*\\)[\"']"))
2487         a
2488         r
2489         p
2490         blocks
2491         ret
2492         elem
2493         list)
2494     ;;  The list is in Perl hash array format in case you're interested...
2495     (with-current-buffer (or buffer (current-buffer))
2496       (while (re-search-forward re nil t)
2497         (setq a (match-string 1)
2498               r (match-string 2)
2499               p (match-string 3))
2500         (setq blocks (split-string p))
2501         (setq blocks (sort blocks 'string<))
2502         (when (and control-list
2503                    (setq elem (assoc a control-list)))
2504           (setq list (nth 1 elem))
2505           (dolist (elt list)
2506             (setq blocks (delete elt blocks)))
2507           (setq list (nth 2 elem))
2508           (dolist (elt list) (push elt blocks))
2509           ;;  We used this now, remove from list
2510           (setq control-list (delete elem control-list))
2511           (setq p            (mapconcat 'concat blocks " ")))
2512         ;; features In alphabetic order
2513         (setq p (mapconcat 'concat blocks " "))
2514         (push (list a r p blocks) ret)))
2515     ret))
2516
2517 ;;}}}
2518
2519 ;;{{{ email addresses
2520
2521 ;;; ----------------------------------------------------------------------
2522 ;;;
2523 (defun ti::mail-email-make-anti-spam-address (email)
2524   "Make an anti-spam address from EMAIL."
2525   (let* ((add [ "uce"
2526                 "ube"
2527                 "spam"
2528                 "commercials"
2529                 "advertisements"
2530                 "ads"
2531                 "junk"
2532                 "garbage"
2533                 ])
2534          (base  ["no"
2535                  "stop"
2536                  "die"
2537                  "hang"
2538                  "anti.address"
2539                  "yuck"
2540                  "dislike"
2541                  "go-away"
2542                  "stay-away"
2543                  "delete"
2544                  "nothanks"
2545                  "erase"
2546                  "zap-this"
2547                  "wipe-this"
2548                  "exterminate"
2549                  "ignore"
2550                  "bypass"
2551                  "keep-out"
2552                  "keep-away"
2553                  "none"
2554                  "nada"
2555                  "zero"
2556                  "not-any"
2557                  "zelt"
2558                  "no-thank-you"
2559                  "remove-this"
2560                  "rip-off-this"
2561                  "disregard"
2562                  "throw-away"
2563                  ])
2564          (vec  (vector
2565                 (concat
2566                  (elt (shuffle-vector base ) 1)
2567                  "-"
2568                  (elt (shuffle-vector add) 1))
2569                 (concat
2570                  (elt (shuffle-vector add) 1)
2571                  "-"
2572                  (elt (shuffle-vector base ) 1))))
2573          (this (elt (shuffle-vector vec) 0))
2574          login
2575          domain)
2576     (string-match "\\(.*\\)@\\(.*\\)"  email)
2577     (setq login  (match-string 1 email)
2578           domain (match-string 2 email))
2579     (format  "%s%s%s"
2580              login
2581              (if (zerop (randij 0 1))
2582                  (concat "." this "@")
2583                (concat "@" this "."))
2584              domain)))
2585
2586 ;;; ----------------------------------------------------------------------
2587 ;;;
2588 (defun ti::mail-email-domain (string)
2589   "Return only the top level domain name from email STRING.
2590 xx.yy..domain.com --> domain.com
2591 xx.domain.co.uk   --> domain.co.uk"
2592   (cond
2593    ;;  This match tries to catch those domains that don't have 3 parts,
2594    ;;
2595    ;;      aa.bb.co.uk
2596    ;;            |
2597    ;;            We expect this part to be longer than 2 characters
2598
2599    ((string-match "[^.][^.][^.]+\\.\\(..\\|...\\)$" string)
2600     (match-string 0 string))
2601    ;;  This is domain that requires 3 parts: co.uk or au jp
2602    ((string-match "[^.]+\\.[^.]+\\.\\(..\\|...\\)$" string)
2603     (match-string 0 string))
2604    ((string-match "[^@]+$" string)
2605     (match-string 0 string))))
2606
2607 ;;; ----------------------------------------------------------------------
2608 ;;;
2609 (defun ti::mail-email-domain-canonilize (list)
2610   "Canonilize list of addresses to top level domain names only
2611 Eg: '(\"aa.foo.com\" \"bb.foo.com\") --> '(\"foo.com\")"
2612   (let* (ret
2613          domain)
2614     (dolist (elt list)
2615       (setq domain (ti::mail-email-domain elt))
2616       (add-to-list 'ret domain))
2617     ret))
2618
2619 ;;; ----------------------------------------------------------------------
2620 ;;;
2621 (defun ti::mail-email-find-region (&optional beg end no-dupes)
2622   "Find all email addresses within region BEG END (defaults to buffer).
2623 The email addresses must contain @. Surrounding <> characters are removed.
2624
2625 Input:
2626
2627   BEG       region start; defaults to `point-min'
2628   END       region end; defaults to `point-min'
2629   NO-DUPES  flag; if non-nil then cache only unique entries."
2630   (let (list
2631         elt)
2632     (save-excursion
2633       (setq beg (or beg (point-min))
2634             end (or end (point-max)))
2635       (ti::keep-lower-order beg end)
2636       (goto-char beg)
2637       ;;  Intangible text property case:
2638       ;;  - When you do a limited search and cursor land somewhere in
2639       ;;    intangible char, it immediately slides to next char
2640       ;;    position. Like if you'd do
2641       ;;
2642       ;;    (progn (goto-char 10) (point))
2643       ;;    --> 20
2644       ;;
2645       ;;    This is not suprise, if point 10 had intangible text until
2646       ;;    19th pos. If there were no intangible text in point 10,
2647       ;;    the result would be expected 10.
2648       (while (and (<= (point) end) ;; intangible test
2649                   (re-search-forward
2650                    "[^ '\",:<\t\n(]+@[^ '\">:,\t\n)]+"
2651                    end
2652                    t))
2653         (setq elt (ti::remove-properties (match-string 0)))
2654
2655         (if (and (stringp elt)
2656                  (or (or (null no-dupes)
2657                          (not (member elt list)))))
2658             (push elt list)))
2659       list)))
2660
2661 ;;; ----------------------------------------------------------------------
2662 ;;;
2663 (defun ti::mail-email-from-string (string)
2664   "Return list of email addresses from STRING.
2665 The addresses must have @ character. Surrounding <> characters are removed.
2666 If STRING is nil this function does nothing."
2667   ;; Using buffer is faster that reading string
2668   (when string
2669     (with-temp-buffer
2670       (insert string)
2671       (ti::mail-email-find-region))))
2672
2673 ;;}}}
2674 ;;{{{ parsing
2675
2676 ;;; ......................................................... &parsing ...
2677
2678 ;;; ----------------------------------------------------------------------
2679 ;;;   (ti::mail-test-parse-name)
2680 ;;;
2681 (defun ti::mail-test-parse-name ()
2682   "This is a test function, do not call from programs.
2683
2684 Because the `ti::mail-parse-name' is quite complicated,
2685 and slightest modification may render it, this functions tests
2686 that the old functionality is preserved in spite of changes."
2687   (let (list
2688         e1
2689         e2
2690         stat
2691         ptr)
2692     (setq list
2693           '("<jdoe@examole.com> (Finland, pgp id 512/47141D35)"
2694             "(Rune Juntti[FRONTEC Pajala]) <jdoe@example.se>"
2695             "shahramn@wv.mentorg.com (jdoe@example.com)"
2696             "(jdoe@example.com)"
2697             "Jerome Santini <doe@this-example.here.com>"
2698             "jdoe@example.com (Harry Halladay - EDS St. Louis)"
2699             "jdoe@example.com (Ake Stenhoff TM/PMD 83442 3003)"
2700             "CEO-executive this here jdoe@example.com"
2701             "JDOE <\"VAX::SOME@example.com\""
2702             "\"VAX::LOGIN\"@example.com"
2703             "john.doe@example.com"
2704             "John=Doe%aoa.rdt%OS.DC@example.com"
2705             "jdoe@example.com (John Doe)"
2706             "\"/G=Name/S=Surname/OU=comlab/O=oxford/PRMD=UK.AC/ADMD= /C=GB/\"@example.fi\""
2707             "\"wayne (w.d.) bell\" <jdoe@example>"
2708             "John doe <example@example.com>"
2709             "\"Joseph B. Ottinger\" <j.doe@example.com>"
2710             "\"Name Foo puh. 111 600\" <LOGIN@example.com>"
2711             "\"stephane (s.) boucher\" <jdoe@example.com>"
2712             "jdoe@example.com (J.D \"John\" Doe)"
2713             "jd@example-com (J.D doe)"
2714             "doe@example.com \(John Doe\)"
2715             "jdoe@example.com \(John D. Doe\)"
2716             "\"J. doe Ph.d \" jdoe@john.doe.example.com"
2717             "\"John D. Doe\" <foo@example.com>"))
2718     (setq ptr list)
2719     (dolist (n ptr)
2720       (setq stat  (ti::mail-parse-name n))
2721       (setq e1 (nth 0 stat)) (setq e2 (nth 1 stat))
2722       (read-from-minibuffer (concat "TEST>>" e1 "," e2 "<")))))
2723
2724 ;;; ----------------------------------------------------------------------
2725 ;;; (ti::mail-t-parse-name)
2726 ;;;
2727 (defun ti::mail-parse-name (line)
2728   "Try to parse various formats of 'From:' fields.
2729 Supposes that the 'From:' keyword is removed from the LINE.
2730
2731 Return:
2732   list          '(firstname surname)
2733   nil           if cannot parse both"
2734   (let* ((re-A          "[-a-zA-Z0-9.{|]")
2735          (re-AG         (concat "\\("  re-A "+\\)"))
2736
2737          ;;  'From: Mr-CEO John Doe <jdoe@example.com'
2738          (fs-re2  (concat re-AG " +" re-AG))
2739
2740          ;;  'USER <\"CLUSTER::VAX\@site.cm\"'
2741          (fs-vax  (concat "^" re-AG "[ \t<\"]+[A-Z]+::" re-AG))
2742
2743          ;;  '\"CLUSTER::LOGIN\"@example.com'
2744          ;;  This is incomplete Name, it does not contain NAMES at all, but
2745          ;;  we consider mail name as surname. The first group-RE is dummy.
2746          (fs-vax2 (concat re-AG "::" re-AG))
2747
2748          ;;  'Job.Ganzevoort@cwi.nl', where person's name is complete
2749          ;;  address
2750          (fs-fse    (concat re-AG "\\." re-AG "@" ))
2751
2752          ;;  matches gateway-type addresses
2753          ;;  'Marla=Bush%aoa.rdt%OS.DC@Ban-Gate.AoA.DHHS.EDU'
2754          (gtw-re1    (concat re-AG "=" re-AG "%" ))
2755
2756          (q-no-re   ti:mail-parse-name-not-accept)
2757
2758          (mail      (or (ti::mail-parse-email line) ""))
2759          (account   (if (= 2 (length mail))
2760                         (nth 0 mail)
2761                       "#@$@#$@#$"))     ;just some dummy
2762
2763          fn
2764          sn                             ;first, surname
2765          pick
2766          w
2767          w1
2768          w2
2769          D                              ;debug
2770          beg
2771          end
2772          beg1
2773          end1
2774          beg2
2775          end2
2776          tmp
2777          list)
2778
2779     (if D
2780         (setq D D))                 ;XE 19.14 ByteComp silencer, no-op
2781
2782     (catch 'found
2783
2784       ;;  It's most important that the match test are made IN THIS ORDER
2785       ;;  - Quote test cannot precede vax name test.
2786       ;;  - Try most restrictive first.
2787
2788       ;; ..............................................................
2789       ;;  VAX is identified by "::" marks
2790
2791       (when (string-match "::" line)
2792         (setq list (ti::mail-get-2re fs-vax line))
2793         (when (not (string= "" (nth 0 list)))
2794           (setq D "vax1")
2795           (throw 'found t))
2796         (setq list (ti::mail-get-2re fs-vax2 line))
2797         (when (not (string= "" (nth 0 list)))
2798           (setq D "vax2")
2799           (throw 'found t)))
2800
2801       ;; ............................................................
2802       ;; Try gateway addresses, rare, but seen in net still
2803
2804       (when (string-match "%" line)
2805         (setq list (ti::mail-get-2re gtw-re1 line))
2806         (when (not (string= "" (nth 0 list)))
2807           (setq D "gtw1")
2808           (throw 'found t)))
2809
2810       ;; X.400 address
2811
2812       (when (string-match "/G=\\(.*\\)/S=\\([^/]+\\).*C=" line)
2813         (setq fn (match-string 1 line)
2814               sn (match-string 2 line))
2815         (when (and fn sn)
2816           (setq list (list fn sn)   D "gateX400")
2817           (throw 'found t)))
2818
2819       ;; .................................................................
2820       ;; foo.bar@example.com
2821
2822       (when (string-match fs-fse line)
2823         (setq list (ti::mail-get-2re fs-fse line))
2824         (when (not (string= "" (nth 0 list)))
2825           (setq D "mike.gordon")
2826           (throw 'found t)))
2827
2828       ;; ............................................................
2829       ;; And the rest , is there paren or ""  somewhere ?
2830       ;;
2831
2832       ;;  If this is a full email string Joe@foo.com
2833       ;;  then get only the first part.
2834
2835       (when (and (setq tmp (ti::string-match "^\\([^ \t]+\\)[@%][^ \t]+$" 1 line))
2836                  (setq tmp (ti::string-match re-AG 1 tmp)))
2837         (setq D "email")
2838         (setq list (list tmp ""))
2839         (throw 'found t))
2840
2841       ;;   - if we get multiple match "stephane (s.) boucher" ,
2842       ;;     (L.G. \"Ted\" Stern) , pick the one that's longer.
2843
2844       (if (string-match "\"\\(.*\\)\"" line)
2845           (setq beg1 (match-beginning 1)  end1  (match-end 1)))
2846
2847       (if (string-match "[(]\\(.*\\)[)]" line)
2848           (setq beg2 (match-beginning 1)  end2  (match-end 1)))
2849
2850       (cond
2851        ((and beg1 beg2)
2852         (if (> (- end1 beg1) (- end2 beg2))
2853             (setq beg beg1  end end1)
2854           (setq beg beg2  end end2)))
2855        (beg1
2856         (setq beg beg1  end end1))
2857        (beg2
2858         (setq beg beg2  end end2)))
2859
2860       ;; ...  ...  ...  ...  ...  ...  ...  ...  ...  ...  ...  ...  ...
2861
2862       (cond
2863        (beg
2864         ;;   - Get list of words into W
2865         ;;   - Someone wrote M. "Mack" Monroe, so the " is included
2866         ;;     in words separate list
2867         ;;   - The latter picks only NON-ABBREVIATED names, non-phones..
2868         ;;     M. "Mack" Monroe --> Mack Monroe
2869         ;;
2870
2871         (setq pick (substring line beg end))
2872         (setq w (split-string pick "[][@%. \"]+"))
2873
2874         (setq D "standard")
2875 ;;;     (ti::d! "w-1" w)
2876
2877         (let ((case-fold-search nil))   ;case is important !!
2878           (setq w                       ;returned word list
2879                 (ti::list-find
2880                  w
2881                  q-no-re
2882                  (function
2883                   (lambda (arg elt)
2884                     (not (string-match arg elt))))
2885                  'all-items)))
2886
2887 ;;;     (ti::d! "w-2" w)
2888
2889         (cond
2890          ((> (length w) 2)              ;too much abbrev names
2891           ;;  pick first and account or last word
2892
2893 ;;;       (setq W w AC account)
2894
2895           (setq w1 (nth 0 w)  w2 (nth (1-(length w)) w)  )
2896
2897           (setq tmp (ti::list-find
2898                      w account
2899                      (function
2900                       (lambda (arg elt)
2901                         (string-match elt arg)))))
2902
2903           (if tmp                       ;account name found
2904               (setq w2 tmp))
2905
2906           (setq list (list w1 w2)))
2907
2908          ((= 2 (length w))
2909           (setq w1 (nth 0 w)  w2 (nth 1 w))
2910           (setq list (list w1 w2)))
2911
2912          ((eq 1 (length w))
2913           (setq list w))
2914
2915          (t
2916           nil))
2917
2918         (if list
2919             (throw 'found t))))
2920
2921       ;; .................................................................
2922
2923       (setq list (ti::mail-get-2re fs-re2 line))
2924       (when (not (string= "" (nth 0 list)))
2925         (setq D "2.1")
2926         (throw 'found t))) ;; Catch end
2927
2928 ;;;    (ti::d! "parsed" D  list)
2929
2930     ;;   what should we return ?
2931     (if (and (string= (nth 0 list) "")
2932              (string= (nth 1 list) ""))
2933         nil
2934       list)))
2935
2936 ;;; ----------------------------------------------------------------------
2937 ;;;
2938 (defun ti::mail-parse-email (line)
2939   "Try to parse various formats of 'From:' field from LINE.
2940 Input is full LINE, possibly containing 'From' keyword.
2941
2942 Return:
2943
2944   list          '(usrname site)
2945   nil           if cannot parse."
2946   (let* (account
2947          site
2948          tmp
2949
2950          ;; '.' is for firstname & surname combination
2951          ;; '=' is for gateway form
2952          ;; '|{' are scandinavian characters in name
2953          ;; '+' Believe or not, but I just saw account name like
2954          ;;     "Stephen M. Lacy" <sl31+@andrew.cmu.edu>
2955
2956          (A "[-a-zA-Z|{0-9_=.+]+")      ; alphabet
2957          (As "[-a-zA-Z0-9.%]+")         ; site name
2958
2959          ;;  Note that username can have scandinavian {| marks
2960          ;;  Normal site name
2961          ;;  o   Simon.Marshall@mail.bar.foo.fi (Simon Marshall)
2962          (re1 (concat "\\(" A "\\)@\\(" As "\\)"  ))
2963
2964          ;;  Marla=Bush%aoa.rdt%OS.DC@Ban-Gate.AoA.DHHS.EDU
2965          (re2 (concat "\\(" A "\\)\\(%" As "\\)"  ))
2966
2967          ;;  VAX address <"TNCLUS::TSYVANEN"@mailer.foo.fi>
2968          (re-vax (concat "\\(\"" A "::" A "\"\\)@\\(" As "\\)"  ))
2969          em                             ; email
2970
2971          ;;  "/G=Jamie/S=Lokier/OU=comlab/O=oxford/PRMD=UK.AC...
2972          (re-x400
2973           (concat "/G=\\([^/]+\\)/S=\\([^/]+\\)" ;fn sn
2974                   "/OU=\\([^/]+\\)/O=\\([^/]+\\)"
2975                   "/PRMD=\\([^/]+\\)")))
2976     (catch 'found
2977 ;;;      (setq LINE line RE re-x400)
2978
2979       (if (null (string-match re-x400 line)) nil
2980         (setq account (concat (match-string 1 line) "." (match-string 2 line)))
2981         (setq site    (concat (match-string 3 line) "." (match-string 4 line)))
2982
2983         ;;  Now switch the last items PRMD=UK.AC --> ac.uk
2984         (setq tmp (match-string 5 line))
2985         (setq tmp (split-string tmp "[.]"))
2986         (setq site (downcase (concat site "." (nth 1 tmp) "." (nth 0 tmp))))
2987         (setq em (list account site))
2988         (throw 'found t))
2989
2990       (setq em (ti::mail-get-2re re-x400 line))
2991       (if (not (string= "" (nth 0 em)))           (throw 'found t))
2992
2993       (setq em (ti::mail-get-2re re1 line))
2994       (if (not (string= "" (nth 0 em)))           (throw 'found t))
2995
2996       (setq em (ti::mail-get-2re re2 line))
2997       (if (not (string= "" (nth 0 em)))           (throw 'found t))
2998
2999       (setq em (ti::mail-get-2re re-vax line))
3000       (if (not (string= "" (nth 0 em)))           (throw 'found t)))
3001
3002     (if (< (length (nth 0 em)) 1)
3003         (setq em nil))
3004     em))
3005
3006 ;;; ----------------------------------------------------------------------
3007 ;;;
3008 (defun ti::mail-parse-received-regexp-list ()
3009   "Return list of regexps that match `Received:' header content.
3010 The Return ed list content is
3011
3012 '((3  (re re re ..))
3013   (2  (re re re ..))
3014   (1  (re re re ..)))
3015
3016 Where the number indicated how many submatches can be read. E.g. Number
3017 3 means, 3 submatches."
3018   (let* ((from  "[ \t]+from")
3019          (spc   "[ \t\r\n]*")
3020          (spc+  "[ \t\r\n]+")
3021          (W     "[^][(){} \t\n]+")              ;;word
3022          (word  (concat "\\(" W "\\)"))         ;;capturing word
3023          (S     "[[({]+")                       ;;start
3024          (E     "[])}]+")                       ;;end
3025
3026          ;; mail.compuserve.com (mail.compuserve.com (209.5.81.86))
3027          ;; mail.msss.v.com [atl.asd.com [234.454.54]]
3028
3029          (re-word31
3030           (concat from
3031                   spc word
3032                   spc S spc word
3033                   spc S spc word  spc
3034                   E))
3035
3036          ;;  Received: from [209.151.131.35] (HELO mx04.hotmail.com)
3037          ;;     by elysium.ca (CommuniGate Pro SMTP 3.5)
3038
3039          (re-word32
3040           (concat from
3041                   spc+ S word E         ;; from [209.151.131.35]
3042                   spc+ S W spc+ word E  ;; (HELO mx04.hotmail.com)
3043                   spc+ "by" spc+ word))
3044
3045          ;;  from hdn86-021.hil.compuserve.com(206.175.97.21) by
3046
3047          (re-word2a
3048           (concat from
3049                   spc word
3050                   spc S spc word
3051                   spc E))
3052
3053          ;;   Propably faked received header?
3054          ;;
3055          ;;   from usinet cziegle (1Cust144.tnt1.coeur-dalene.id.da.uu.net
3056          ;;       [208.254.107.144]) by ns.peace1.co.jp
3057
3058          (re-word2b
3059           (concat from
3060                   "[^([{]+"
3061                   S spc word spc
3062                   S spc word spc
3063                   E))
3064
3065          ;;  Received: from usa.net - 206.133.11.158 by
3066          ;;     ciudad.com.ar with Microsoft SMTPSVC; Mon, 2 Feb 1998 21:03:25
3067
3068          (re-word2c
3069           (concat from
3070                   spc word spc+ "-"
3071                   spc+ word spc+ "by"))
3072
3073          ;; Received: from foo by relay1.UU.NET with SMTP
3074          ;;    (peer crosschecked as: 1Cust185.tnt10.nyc3.da.uu.net
3075          ;;     [153.37.131.185])
3076
3077          (re-word2d
3078           (concat from
3079                   spc word spc "by"
3080                   spc word spc "with"))
3081
3082          ;;  from [206.102.180.52] by springfield.k12.il.us with ESMTP
3083
3084          (re-word2e
3085           (concat from
3086                   spc S word E spc "by"
3087                   spc word spc "with"))
3088
3089          ;; Received: by SERVER02 with Internet Mail Service (5.5.2650.21)
3090          ;; id <FVLHVM1Q>; Thu, 28 Feb 2002 16:26:29 -0500
3091
3092          (re-word11
3093           (concat spc+ "by" spc+ W spc+ "with" spc+ W spc+ W spc+ W
3094                   spc+ S word E))
3095
3096          ;; from papaguena.upc.es by rita.upc.es
3097
3098          (re-word12 (concat from spc word spc "by" )))
3099     (list
3100      (list 3 (list re-word31
3101                    re-word32))
3102      (list 2 (list re-word2a
3103                    re-word2b
3104                    re-word2c
3105                    re-word2d
3106                    re-word2e))
3107      (list 1 (list re-word11
3108                    re-word12)))))
3109
3110 ;;; ----------------------------------------------------------------------
3111 ;;;
3112 (defun ti::mail-parse-received-line (regexp-list)
3113   "Parse all `Received:' IPs from current line with REGEXP-LIST.
3114 The point must be placed just after the colon in header:
3115
3116   Received:-!-
3117
3118 The -!- indicates the location of point."
3119   (let* (candidates)
3120     (catch 'done
3121       (dolist (elt regexp-list)
3122         (multiple-value-bind (submatch-max regexp-list)
3123             elt
3124           (dolist (regexp regexp-list)
3125             (when (looking-at regexp)
3126               (dotimes (count submatch-max) ;; starts counting from 0
3127                 (push (match-string (1+ count)) candidates))
3128               ;; Regexp-list
3129               (throw 'done t))))))
3130     (nreverse candidates)))
3131
3132 ;;; ----------------------------------------------------------------------
3133 ;;;
3134 (defun ti::mail-parse-received-string-smtp (string)
3135   "Parse SMTP field from 'Received:' STRING."
3136   ;; from 111.npgco.com (HELO NAZ-AZPIRE1) (24.121.15.77)
3137   (when (string-match
3138          (concat
3139           "\\<from[ \t\r\n]+[^ \t\r\n]+[ \t\r\n]+"
3140           "(\\"           ;; BEGIN
3141           "([^()]+)"      ;; First paren, required
3142           "\\([ \t\r\n]+" ;; Second, optional
3143           "([^()]+)\\)*"
3144           "\\)") ;; END capture
3145          string)
3146     (let* ((str  (match-string 1 string))
3147            (list (list str))
3148            ret)
3149       (if (string-match " " str)
3150           (setq list (split-string str)))
3151       (dolist (elt list)
3152         (push (replace-regexp-in-string "\\[\\|\\]\\|[()\r\n]" "" elt)
3153               ret))
3154       (nreverse ret))))
3155
3156 ;;; ----------------------------------------------------------------------
3157 ;;;
3158 (defsubst ti::mail-parse-received-string-clean (string)
3159   "Remove () and newlines from STRING."
3160   (replace-regexp-in-string "[()\r\n]" "" string))
3161
3162 ;;; ----------------------------------------------------------------------
3163 ;;;
3164 (defsubst ti::mail-parse-received-string-from (string)
3165   "Parse 'from' field from 'Received:' STRING."
3166   (when (string-match "\\<from[ \t\r\n]+\\([^ \t\r\n]+\\)" string)
3167     ;;  from cm-24-121-15-77.flagstaff.az.npgco.com (HELO NAZ-AZPIRE1)
3168     (match-string 1 string)))
3169
3170 ;;; ----------------------------------------------------------------------
3171 ;;;
3172 (defsubst ti::mail-parse-received-string-by (string)
3173   "Parse 'from' field from 'Received:' STRING."
3174   (when (string-match "\\<by[ \t\r\n]+\\([^ \t\r\n]+\\)" string)
3175     (match-string 1 string)))
3176
3177 ;;; ----------------------------------------------------------------------
3178 ;;;
3179 (defsubst ti::mail-parse-received-string-smtp-id (string)
3180   "Parse 'from' field from 'Received:' STRING."
3181   (cond
3182    ((string-match
3183      "[ \t\r\n]+id[ \t\r\n]+\\([^ ;\t\r\n]+\\)" string)
3184     (match-string 1 string))))
3185
3186 ;;; ----------------------------------------------------------------------
3187 ;;;
3188 (defsubst ti::mail-parse-received-string-for (string)
3189   "Parse 'from' field from 'Received:' STRING."
3190   (when (string-match "\\<for[ \t\r\n]+\\([^ ;\t\r\n]+\\)" string)
3191     (match-string 1 string)))
3192
3193 ;;; ----------------------------------------------------------------------
3194 ;;;
3195 (defsubst ti::mail-parse-received-string-date (string)
3196   "Parse 'from' field from 'Received:' STRING."
3197   (when (string-match
3198          "^.+;[ \t\r\n]+\\(.+[^ \t\r\n]\\)" string)
3199     (match-string 1 string)))
3200
3201 ;;; ----------------------------------------------------------------------
3202 ;;; (ti::mail-parse-date-string "Thu, 18 Jul 1996 12:18:06 -0600")
3203 ;;; (ti::mail-parse-date-string "21 Aug 2003 20:41:15 -0000")
3204 (defun ti::mail-parse-date-string (date)
3205   "Parse DATE notation.
3206 Recognized format are:
3207
3208   Thu, 18 Jul 1996 12:18:06 -0600
3209   21 Aug 2003 20:41:15 -0000
3210
3211 The timezone value is optional.
3212
3213 Returns alist;
3214
3215    '(weekday
3216      dd
3217      mon
3218      mm           ;; numeric string, like \"07\" for \"Jul\"
3219      yyyy
3220      HH
3221      MM
3222      SS
3223      tz)"
3224   (cond
3225    ((string-match
3226      (concat "^[ \t\r\n]*"
3227              "\\([A-Z]..\\),?[ \t\r\n]+"
3228              "\\([0-9]+\\)[ \t\r\n]+"
3229              "\\([A-Z]..\\)[ \t\r\n]+"
3230              "\\([0-9][0-9][0-9][0-9]\\)[ \t\r\n]+"
3231              "\\([0-9][0-9]\\):"
3232              "\\([0-9][0-9]\\):"
3233              "\\([0-9][0-9]\\)"
3234              "[ \t]*\\(.*\\)")
3235      date)
3236     (list
3237      (match-string 1 date)
3238      (format "%02d" (string-to-int (match-string 2 date)))
3239      (match-string 3 date)
3240      (format "%02d"
3241              (ti::month-to-number (match-string 3 date)))
3242      (match-string 4 date)
3243      (match-string 5 date)
3244      (match-string 6 date)
3245      (match-string 7 date)
3246      (match-string 8 date)))
3247    ((string-match
3248      (concat
3249       "^[ \t\r\n]*"
3250       "\\([0-9][0-9]?\\)[ \t\r\n]+"
3251       "\\([A-Z]..\\)[ \t\r\n]+"
3252       "\\([0-9][0-9][0-9][0-9]\\)[ \t\r\n]+"
3253       "\\([0-9][0-9]\\):"
3254       "\\([0-9][0-9]\\):"
3255       "\\([0-9][0-9]\\)"
3256       "[ \t]*\\(.*\\)")
3257      date)
3258     (list
3259      nil
3260      (match-string 1 date)
3261      (match-string 2 date)
3262      (format "%02d"
3263              (ti::month-to-number (match-string 2 date)))
3264      (match-string 3 date)
3265      (match-string 4 date)
3266      (match-string 5 date)
3267      (match-string 6 date)
3268      (match-string 7 date)))))
3269
3270 ;;; ----------------------------------------------------------------------
3271 ;;; (ti::mail-parse-date-string-iso8601 "Thu, 18 Jul 1996 12:18:06 -0600")
3272 (defun ti::mail-parse-date-string-iso8601 (date &optional tz)
3273   "Parse DATE. See supported values in `ti::mail-parse-date-string'.
3274 Return ISO 8601 date
3275
3276     YYYY-MM-DD HH:MM:SS
3277
3278 If TZ is non-nil, add timezone information to the end."
3279   (interactive)
3280   (multiple-value-bind
3281       (dd
3282        mm
3283        yyyy
3284        HH
3285        MM
3286        SS
3287        tzone)
3288       (ti::mail-parse-date-string date)
3289     (format "%s-%s-%s %s:%s:%s%s"
3290             yyyy mm dd HH MM SS (if tzone
3291                                     (or tz "")
3292                                   ""))))
3293
3294 ;;; ----------------------------------------------------------------------
3295 ;;;
3296 (defun ti::mail-parse-received-string (string)
3297   "Parse 'Received:' Header STRING.
3298 From this STRING
3299
3300     Received: from host1 (host2 [ww.xx.yy.zz]) by host3
3301      (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
3302
3303 Return list:
3304
3305     '((from    . HOST1)
3306       (smtp    . (HOST2 ...))
3307       (by      . HOST3)
3308       (smtp-id . ID)
3309       (for     . FOR)
3310       (date    . DATE))
3311
3312 The `cdr' of a key may be nil if no value was found.
3313
3314 References:
3315
3316   `ti::with-mail-received-heade'."
3317   (list
3318    (cons 'from    (ti::mail-parse-received-string-from string))
3319    (cons 'smtp    (ti::mail-parse-received-string-smtp string))
3320    (cons 'by      (ti::mail-parse-received-string-by   string))
3321    (cons 'smtp-id (ti::mail-parse-received-string-smtp-id string))
3322    (cons 'for     (ti::mail-parse-received-string-for  string))
3323    (cons 'date    (ti::mail-parse-received-string-date string))))
3324
3325 ;;; ----------------------------------------------------------------------
3326 ;;;
3327 (defun ti::mail-parse-received (&optional not-matching no-dupes)
3328   "Search all 'Receive:' fields and read site names followed by 'from' 'by'.
3329 Duplicate entries are not added.
3330
3331 Point must be at the beginning of headers to search, and
3332 point is advanced.
3333
3334 It is possible to can this function to find out from where the mail
3335 originated and send complaint to postmasters of all those sites.
3336
3337 Input:
3338
3339   NOT-MATCHING  string, If read entry matches this regexp it is not included in
3340                 returned list
3341   NO-DUPES      flag, if non-nil then do not include duplicate addresses.
3342
3343 Return:
3344
3345     '((IP IP IP) (IP IP) ..)   as they appear in Received fields.
3346
3347 Received headers explained:
3348
3349     Received: from host1 (host2 [ww.xx.yy.zz]) by host3
3350      (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
3351
3352     This Shows four pieces of useful information (reading from back to front,
3353     in order of decreasing reliability):
3354
3355      - The host that added the Received line (host3)
3356      - The IP address of the incoming SMTP connection (ww.xx.yy.zz)
3357      - The reverse-DNS lookup of that IP address (host2)
3358      - The name of the sender used in the SMTP HELO command at the
3359        time of connection.
3360
3361 Real examples:
3362
3363 Received: from mailhost.worldnet.att.net ([206.85.117.127])
3364           by mtigwc02.worldnet.att.net (post.office MTA v2.0 0613 )
3365           with SMTP id AAD8244; Sun, 23 Mar 1997 23:03:10 +0000
3366 Received: from mail.msss.v.com [atl.asd.com [234.454.54]]
3367           by mediabrokers.cobracomm.com (8.8.5/8.6.5) with
3368           SMTP id GAA07901 for <box17@mediabrokers.cobracomm.com>"
3369   (let* ((regexp-list (ti::mail-parse-received-regexp-list))
3370          ret
3371          candidates
3372          ip-elt
3373          ip-all-list)
3374
3375     (while (re-search-forward "^Received:" nil t)
3376       (setq ip-elt nil)
3377       (setq candidates (ti::mail-parse-received-line regexp-list))
3378
3379       (dolist (elt candidates)
3380         (when (and (stringp elt)
3381                    (string-match "\\." elt) ;;from PAPAGUENA, require dot(.)
3382                    ;; Is exclude in effect?
3383                    (or (null not-matching)
3384                        (not (string-match not-matching elt)))
3385                    (if no-dupes
3386                        (not (member elt ip-all-list))
3387                      t))
3388           ;;  1) mailhost@inet.com --> inet.com
3389           ;;  2) remove some garbage from string
3390
3391           (setq elt (replace-regexp-in-string ".*@" "" elt))
3392           (setq elt (replace-regexp-in-string "[]()\n]" "" elt))
3393
3394 ;;;       (ti::d! elt)
3395
3396           (if no-dupes
3397               (push elt ip-all-list))   ;Needed for duplicate checking
3398
3399           (push elt ip-elt)))
3400       (if ip-elt
3401           (push ip-elt ret)))
3402     (nreverse ret)))
3403
3404 ;;; ----------------------------------------------------------------------
3405 ;;;
3406 (put 'ti::with-mail-received-header 'edebug-form-spec '(body))
3407 (put 'ti::with-mail-received-header 'lisp-indent-function 1)
3408 (defmacro ti::with-mail-received-header (string &rest body)
3409   "With Mail 'received:' heading in STRING, run BODY.
3410 For this STRING
3411
3412     Received: from host1 (host2 [ww.xx.yy.zz]) by host3
3413      (8.7.5/8.7.3) with SMTP id MAA04298; Thu, 18 Jul 1996 12:18:06 -0600
3414
3415 The following access variables are available within BODY:
3416
3417   received-header-data
3418   from              => host1
3419   smtp              => '(host2 ww.xx.yy.zz)
3420   smtp-id           => MAA04298
3421   by                => host3
3422   for               => host1
3423   date              => Thu, 18 Jul 1996 12:18:06 -0600
3424
3425 Note:
3426
3427   Any of the variables may be nil, if no value found.
3428
3429 References:
3430
3431   See functions ti::mail-parse-received-string-*
3432   and `ti::mail-parse-received-string'."
3433   `(let ((received-header-data (ti::mail-parse-received-string ,string)))
3434      (symbol-macrolet ((from     (cdr (assq 'from received-header-data)))
3435                        (smtp     (cdr (assq 'smtp received-header-data)))
3436                        (by       (cdr (assq 'by received-header-data)))
3437                        (smtp-id  (cdr (assq 'smtp-id received-header-data)))
3438                        (for      (cdr (assq 'for received-header-data)))
3439                        (date     (cdr (assq 'date received-header-data))))
3440        ,@body)))
3441
3442 ;;; ----------------------------------------------------------------------
3443 ;;;
3444 (defun ti::mail-whois-parse-cleanup (string)
3445   "Remove indentation and extra whitescape from STRING."
3446   ;;  Remove indentation
3447   (ti::string-remove-whitespace
3448    (replace-regexp-in-string
3449     "[\r\n][ \t]+" "\n"
3450     (replace-regexp-in-string "[ \t][ \t]+" " " string))))
3451
3452 ;;; ----------------------------------------------------------------------
3453 ;;;
3454 (defun ti::mail-whois-parse-paragraph (regexp &optional end-regexp)
3455   "Whois: Parse pragraph for the first REGEXP to END-REGEXP.
3456 See `ti::mail-whois-parse'."
3457   (when (re-search-forward regexp nil 'noerr)
3458     (let ((beg (match-beginning 0)))
3459       (if (null end-regexp)
3460           (forward-paragraph)
3461         (re-search-forward end-regexp)
3462         (beginning-of-line))
3463       (ti::mail-whois-parse-cleanup
3464        (buffer-substring beg (1- (point)))))))
3465
3466 ;;; ----------------------------------------------------------------------
3467 ;;;
3468 (defun ti::mail-whois-parse-referral ()
3469   "Parse referral if any. See `ti::mail-whois-parse'."
3470   (let ((point (point)))
3471     (cond
3472      ((and (goto-char point)
3473            (re-search-forward
3474             ;; Found a referral to example.com
3475             "^[ \t]*Found.*referral to \\([^ \t\r\n]+[a-z]\\)"
3476             nil 'noerr))
3477       (match-string 1))
3478      ((and (goto-char point)
3479            (re-search-forward
3480             ;; Referral URL: http://example.com
3481             "^[ \t]*referral[ \t]+URL:[ \]*\\([^ \t\r\n]+\\)"
3482             nil 'noerr))
3483       (match-string 1)))))
3484
3485 ;;; ----------------------------------------------------------------------
3486 ;;;
3487 (defun ti::mail-whois-parse-email ()
3488   "Whois: Parse unique email addresses from buffer.
3489 See `ti::mail-whois-parse'."
3490   ;; mailto:abuse@foo.com
3491   ;; trouble: Spam: <mailto:abuse@foo.com>
3492   ;; changed: 20030912 <migration@foo.com>
3493   (let ((kill-regexp
3494          (concat
3495           "E?-?mail:[ \t]*"
3496           "\\|\\(mailto\\|changed\\|updated\\):"
3497           "\\|\\<[0-9]+\\>"))<
3498           line
3499           email
3500           desc
3501           seen
3502           ret)
3503     (while (re-search-forward
3504             (concat
3505              "^[ \t]*.*[ ,;/\t]"
3506              "\\([^/,;<> \t\r\n]+@[^/,;<> \t\r\n]+\\)")
3507             nil 'noerr)
3508       ;; There is only one email at a line
3509       (setq email
3510             (replace-regexp-in-string
3511              "mailto:" ""
3512              (match-string 1)))
3513       (unless (member email seen)
3514         (push email seen)
3515         (setq line (ti::buffer-read-line))
3516         ;;  Remove that email from it
3517         (when (setq desc (replace-regexp-in-string
3518                           (regexp-quote email) "" line))
3519           (setq desc
3520                 (ti::string-remove-whitespace
3521                  (replace-regexp-in-string
3522                   "," " "
3523                   (replace-regexp-in-string
3524                    kill-regexp ""
3525                    (replace-regexp-in-string
3526                     "[ \t][ \t]+" " " desc))))))
3527         (if (and desc
3528                  (ti::nil-p desc))
3529             (setq desc nil))
3530         (push
3531          (list (if desc
3532                    (format "%s <%s>"
3533                            desc
3534                            email)
3535                  email)
3536                email
3537                desc)
3538          ret)))
3539     ;; preserve order
3540     (nreverse ret)))
3541
3542 ;;; ----------------------------------------------------------------------
3543 ;;;
3544 (defsubst ti::mail-whois-parse-paragraph-end-condition ()
3545   "Whois parse. See `ti::mail-whois-parse'."
3546   (concat
3547    "^[ \t]*\\(.+:[ \t]*[\r\n]"
3548    "\\|.*last update"
3549    "\\|.*servers in listed order\\)"))
3550
3551 ;;; ----------------------------------------------------------------------
3552 ;;;
3553 (defun ti::mail-whois-parse-registrant-1 ()
3554   "See `ti::mail-whois-parse-registrant'."
3555   (ti::mail-whois-parse-paragraph
3556    "^[ \t]*Registra\\(r\\|nt\\):.*[\r\n]+[ \t]*"
3557    (ti::mail-whois-parse-paragraph-end-condition)))
3558
3559 ;;; ----------------------------------------------------------------------
3560 ;;;
3561 (defun ti::mail-whois-parse-registrant-organization ()
3562   "See `ti::mail-whois-parse-registrant'."
3563   (ti::mail-whois-parse-paragraph
3564    "^[ \t]*Organi[zs]ation:[ \t]*[\r\n]+[ \t]*"
3565    (ti::mail-whois-parse-paragraph-end-condition)))
3566
3567 ;;; ----------------------------------------------------------------------
3568 ;;;
3569 (defun ti::mail-whois-parse-registrant-organization-2 ()
3570   "See `ti::mail-whois-parse-registrant'."
3571   ;; OrgName:    AT&T WorldNet Services
3572   ;; OrgID:      ATTW
3573   ;; Address:    400 Interpace Parkway
3574   ;; City:       Parsippany
3575   ;; StateProv:  NJ
3576   ;; PostalCode: 07054
3577   ;; Country:    US
3578   ;;
3579   ;;  ...
3580   ;;
3581   ;; # ARIN WHOIS database, last updated 2003-08-25 19:15
3582   ;; # Enter ? for additional hints on searching ARIN's WHOIS database.
3583   (ti::mail-whois-parse-paragraph
3584    "^OrgName:.*[\r\n]OrgID:"
3585    "^[ \t]*$"))
3586
3587 ;;; ----------------------------------------------------------------------
3588 ;;;
3589 (defun ti::mail-whois-parse-registrant-domain ()
3590   "See `ti::mail-whois-parse-registrant'."
3591   ;; domain:  AHA.RU
3592   ;; type:    CORPORATE
3593   ;; descr:   Mr. Postman BBS
3594   ;; admin-o: ZENON-ORG-RIPN
3595   ;; nserver: dns1.zenon.net.
3596   ;; nserver: dns2.zenon.net.
3597   ;; created: 1996.10.01
3598   ;; state:   Delegated till 2003.11.01
3599   ;; changed: 1998.08.11
3600   ;; mnt-by:  ZENON-MNT-RIPN
3601   ;; source:  RIPN
3602   (ti::mail-whois-parse-paragraph
3603    (concat
3604     "^domain:[ \t]+[a-z].*\\.[a-z0-9].+[ \t\r\n]"
3605     ;;Licensee:
3606     ;;   Name:     Belgacom Skynet DnsMasters
3607     ;;   Company:  Belgacom Skynet SA/NV
3608     "\\|^Licensee:[ \t]*$")
3609    "^[ \t]*$"))
3610
3611 ;;; ----------------------------------------------------------------------
3612 ;;;
3613 (defun ti::mail-whois-parse-registrant ()
3614   "Whois: Parse registrant from buffer. See `ti::mail-whois-parse'."
3615   (let ((point (point))
3616         ret)
3617     (flet ((search (func)
3618                    (goto-char point)
3619                    (funcall func)))
3620       (dolist (func '(ti::mail-whois-parse-registrant-1
3621                       ti::mail-whois-parse-registrant-domain
3622                       ti::mail-whois-parse-registrant-organization
3623                       ti::mail-whois-parse-registrant-organization-2))
3624         (when (setq ret (search func))
3625           (return ret))))))
3626
3627 ;;; ----------------------------------------------------------------------
3628 ;;;
3629 (defun ti::mail-whois-parse-tech ()
3630   "Whois: Parse tech from buffer. See `ti::mail-whois-parse'."
3631   (let ((point (point)))
3632     (or (ti::mail-whois-parse-paragraph
3633          "^[ \t]*.*Technical Contact.*:"
3634          (ti::mail-whois-parse-paragraph-end-condition))
3635         (cond
3636          ((and (goto-char point)
3637                (re-search-forward ":\\(.*tech.*@.*\\)" nil 'noerr))
3638           (ti::mail-whois-parse-cleanup
3639            (match-string 1)))))))
3640
3641 ;;; ----------------------------------------------------------------------
3642 ;;;
3643 (defun ti::mail-whois-parse-zone ()
3644   "Whois: Parse zone from buffer. See `ti::mail-whois-parse'."
3645   (let ((point (point)))
3646     (or (ti::mail-whois-parse-paragraph
3647          "^[ \t]*.*Zone Contact.*:"
3648          (ti::mail-whois-parse-paragraph-end-condition))
3649         (cond
3650          ((and (goto-char point)
3651                (re-search-forward ":\\(.*zone.*@.*\\)" nil 'noerr))
3652           (ti::mail-whois-parse-cleanup
3653            (match-string 1)))))))
3654
3655 ;;; ----------------------------------------------------------------------
3656 ;;;
3657 ;;; It the response is like this, there is no information
3658 ;;; about the created, expires
3659 ;;;
3660 ;;;     # ARIN WHOIS database, last updated 2003-08-25 19:15
3661 ;;;     # Enter ? for additional hints on searching ARIN's WHOIS database.
3662 ;;;
3663 (defun ti::mail-whois-parse-records ()
3664   "Whois: Parse records from buffer. See `ti::mail-whois-parse'.
3665 Values examined are: expires, created and updated."
3666   (let* ((date-info
3667           (list
3668            ;;  10-Aug-1998
3669            (list
3670             (concat
3671              "\\("
3672              "\\([0-9][0-9]?\\)"
3673              "-\\([A-Z][a-z][a-z]\\)"
3674              "-\\([0-9][0-9][0-9][0-9]\\)"
3675              "\\)")
3676             ;; day month year
3677             '(3 4 5))
3678            ;;  10-08-1998
3679            (list
3680             (concat
3681              "\\("
3682              "\\([0-9][0-9]?\\)"
3683              "-\\([0-9][0-9]?\\)"
3684              "-\\([0-9][0-9][0-9][0-9]\\)"
3685              "\\)")
3686             '(3 4 5))
3687            ;;  Mon, Aug 10, 1998
3688            (list
3689             (concat
3690              "\\("
3691              "[A-Z][a-z][a-z],[ \t]*"
3692              "\\([A-Z][a-z][a-z]\\)[ \t]+" ;; Mon
3693              "\\([0-9]+\\)[ \t]*,[ \t]*"   ;; day
3694              "\\([0-9][0-9][0-9][0-9]\\)"  ;; year
3695              "\\)")
3696             '(4 3 5))
3697            (list
3698             (concat
3699              ;; 2003-08-25 19:15
3700              "\\("
3701              "\\([0-9][0-9][0-9][0-9]\\)"
3702              "-\\([0-9][0-9]\\)"
3703              "-\\([0-9][0-9]\\)"
3704              "[ \t]+[0-9][0-9]:[0-9][0-9]"
3705              "\\)")
3706             '(5 4 3))
3707            (list
3708             (concat
3709              ;; 1998.08.11
3710              "\\("
3711              "\\([0-9][0-9][0-9][0-9]\\)"
3712              "[.]\\([0-9][0-9]\\)"
3713              "[.]\\([0-9][0-9]\\)"
3714              "\\)")
3715             '(5 4 3))
3716            (list
3717             (concat
3718              ;; changed:  20001107 15:03:09
3719              ;; changed:     registdom@tin.it 20030403
3720              ;;
3721              "\\(\\([0-9][0-9][0-9][0-9]\\)"
3722              "\\([0-9][0-9]\\)"
3723              "\\([0-9][0-9]\\)"
3724              "\\)")))
3725           '(5 4 3))
3726
3727          (search (list
3728                   (list
3729                    'expires
3730                    (concat
3731                     "\\("
3732                     "^[ \t]*Record[ \t]+expires[ \t]+on[ \t]+"
3733                     "\\|^[ \t]*Expires[ \t]+on"
3734                     "\\|^expire:[^\r\n0-9]+"
3735                     "\\|^[ \t]*expiration date:[ \t]+"
3736                     "\\)"))
3737                   (list
3738                    'created
3739                    (concat
3740                     "\\("
3741                     "^[ \t]*Record[ \t]+created[ \t]+on[ \t]+"
3742                     "\\|^[ \t]*Created[ \t]+on.*[ \t]+"
3743                     "\\|^created:[^\r\n0-9]+"
3744                     "\\|^[ \t]*creation date:[ \t]+"
3745                     "\\)"))
3746                   (list
3747                    'updated
3748                    (concat
3749                     "\\("
3750                     "^.*last.*updated?[ \t]+on[ \t]+"
3751                     "\\|^[ \t]*updated date:[ \t]+"
3752                     "\\|^changed:[^\r\n0-9]+"
3753                     "\\)"))))
3754          (beg    (point))
3755          ret)
3756     (dolist (elt search)
3757       (multiple-value-bind (type line)
3758           elt
3759         (dolist (date-data date-info)
3760           (multiple-value-bind (regexp pos-list)
3761               date-data
3762             (setq regexp (concat line regexp))
3763             ;;  The order of the fields can be anything, start over
3764             ;;  every time from the same point
3765             (goto-char beg)
3766             (when (re-search-forward regexp nil 'noerr)
3767               (multiple-value-bind (raw day month year)
3768                   (list
3769                    (match-string 2)
3770                    (match-string (nth 0 pos-list))
3771                    (match-string (nth 1 pos-list))
3772                    (match-string (nth 2 pos-list)))
3773                 (if (eq 3 (length month))
3774                     (setq month (ti::month-to-number
3775                                  (capitalize month)
3776                                  'zero)))
3777                 (push (list
3778                        type
3779                        (list (format "%s-%s-%s" year month day)
3780                              raw))
3781                       ret))
3782               (return))))))
3783     ret))
3784
3785 ;;; ----------------------------------------------------------------------
3786 ;;;
3787 (defun ti::mail-whois-parse-servers ()
3788   "Whois: Parse servers from buffer. See `ti::mail-whois-parse'."
3789   (when (re-search-forward "^[ \t]*Domain servers" nil t)
3790     (forward-line 1)
3791     (let ((beg (point))
3792           (end (progn
3793                  (forward-paragraph)
3794                  (point))))
3795       (let (ret)
3796         (goto-char beg)
3797         ;; Domain servers in listed order:
3798         ;;
3799         ;; NS1.GALLERYHOSTING.NET       209.19.90.117
3800         ;; GHZ.DDAHL.COM                209.19.90.118
3801         ;;
3802         (while (re-search-forward
3803                 (concat
3804                  "^[ \t]+"
3805                  "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)"
3806                  "[ \t]+"
3807                  "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)")
3808                 end 'noerr)
3809           (push (list (downcase (match-string 1))
3810                       (match-string 2))
3811                 ret))
3812         ;; Domain servers in listed order:
3813         ;;
3814         ;; Name Server: ns1.dr-parkingservices.com
3815         ;; Name Server: ns2.dr-parkingservices.com
3816         ;;
3817         (unless ret
3818           (goto-char beg)
3819           (while (re-search-forward
3820                   (concat
3821                    "^[ \t]+Name[ \t]+Server:"
3822                    "[ \t]+"
3823                    "\\([^ \t\r\n]+\\.[^ \t\r\n]+\\)")
3824                   end 'noerr)
3825             (push (list (downcase (match-string 1)) nil)
3826                   ret)))
3827         ret))))
3828
3829 ;;; ----------------------------------------------------------------------
3830 ;;;
3831 (defun ti::mail-whois-parse-admin ()
3832   "Whois: Parse Administrative Contact from buffer.
3833 See `ti::mail-whois-parse'."
3834   (let ((point (point)))
3835     (cond
3836      ((and (goto-char point)
3837            (re-search-forward "^[ \t]*Administrative Contact:" nil 'noerr))
3838       (forward-line 1)
3839       (let ((beg (point)))
3840         ;;  Search "Technical Contact:"
3841         (when (re-search-forward "^[ \t]*.+:[ \t]*$" nil 'noerr)
3842           (ti::mail-whois-parse-cleanup
3843            (buffer-substring
3844             beg (1- (line-beginning-position)))))))
3845      ((and (goto-char point)
3846            (re-search-forward ":\\(.*admin.*@.*\\)" nil 'noerr))
3847       (ti::mail-whois-parse-cleanup
3848        (match-string 1))))))
3849
3850 ;;; ----------------------------------------------------------------------
3851 ;;;
3852 (defun ti::mail-whois-error-p (string)
3853   "Check if Whois call failed by examining STRING"
3854   (not (string-match
3855         (concat
3856          "registra\\(nt\\|r\\):"
3857          ;; domain:  AHA.RU
3858          ;; type:    CORPORATE
3859          ;; descr:   Mr. Postman BBS
3860          ;; admin-o: ZENON-ORG-RIPN
3861          ;; nserver: dns1.zenon.net.
3862          ;; nserver: dns2.zenon.net.
3863          ;; created: 1996.10.01
3864          ;; state:   Delegated till 2003.11.01
3865          ;; changed: 1998.08.11
3866          ;; mnt-by:  ZENON-MNT-RIPN
3867          ;; source:  RIPN
3868          ;;
3869          ;; domain:   siemens.at
3870          ;; descr:    [organization]:Siemens AG
3871          ;; descr:    [street address]:Siemensstr. 92
3872          ;;
3873          "\\|^domain:[ \t]+[a-z].*\\..*[\n\r]"
3874          "\\(type\\|descr\\):"
3875          "\\|^address:.*[^ \t\r\n]"
3876          ;;
3877          "\\|^# ARIN WHOIS database")
3878         string)))
3879
3880 ;;; ----------------------------------------------------------------------
3881 ;;;
3882 (defun ti::mail-whois-parse (string)
3883   "Parse whois output STRING.
3884
3885 Return:
3886
3887    '((email      .  ((ADDED EMAIL REST)  ;; ADDED is \"REST <EMAIL>\"
3888                     ...))
3889      (registrant .  STRING)
3890      (admin      .  STRING)
3891      (tech       .  STRING)
3892      (records    .  ((expires DATE-ISO RAW-DATE)
3893                      (created DATE-ISO RAW-DATE)
3894                      (updated DATE-ISO RAW-DATE))
3895      (servers    .  ((host ip)
3896                      ...)))
3897
3898 Note:
3899
3900   All the keys, like 'admin', are present in returned list, but any of the
3901   `cdr' values or their components may be nil, if no value was found.
3902
3903   Do not relay in the order of these fields. They may change
3904   any time. Instead access the list entry with `assq'.
3905
3906 References:
3907
3908   See functions ti::mail-whois-parse-*
3909   and macro `ti::with-mail-whois'."
3910   (with-temp-buffer
3911     (insert string)
3912     (ti::buffer-text-properties-wipe)
3913     (let* ((referral   (progn (ti::pmin)
3914                               (ti::mail-whois-parse-referral)))
3915            (email      (progn (ti::pmin)
3916                               (ti::mail-whois-parse-email)))
3917            (registrant (progn (ti::pmin)
3918                               (ti::mail-whois-parse-registrant)))
3919            (admin      (progn (ti::pmin)
3920                               (ti::mail-whois-parse-admin)))
3921            (tech       (progn (ti::pmin)
3922                               (ti::mail-whois-parse-tech)))
3923            (zone       (progn (ti::pmin)
3924                               (ti::mail-whois-parse-zone)))
3925            (records    (progn (ti::pmin)
3926                               (ti::mail-whois-parse-records)))
3927            (servers    (progn (ti::pmin)
3928                               (ti::mail-whois-parse-servers))))
3929       (unless (and
3930                registrant)
3931         (error "TinyLibMail: Cannot parse Whois string %s" string))
3932       (list
3933        (cons 'referral    referral)
3934        (cons 'email       email)
3935        (cons 'registrant  registrant)
3936        (cons 'admin       admin)
3937        (cons 'tech        tech)
3938        (cons 'zone        zone)
3939        (cons 'records     records)
3940        (cons 'servers     servers)))))
3941
3942 ;;; ----------------------------------------------------------------------
3943 ;;;
3944 (put 'ti::with-mail-whois 'edebug-form-spec '(body))
3945 (put 'ti::with-mail-whois 'lisp-indent-function 1)
3946 (defmacro ti::with-mail-whois (string &rest body)
3947   "For full ´whois' output STRING run BODY.
3948
3949 The following access variables are available within BODY. Any
3950 of the values may be nil.
3951
3952   email
3953   admin         Administrative Contact
3954   tech          Technical Contact
3955   zone          Zone Contact
3956   records
3957   servers       Domain servers
3958
3959 References:
3960
3961   `ti::mail-whois-parse'."
3962   `(let ((whois-data (ti::mail-whois-parse ,string)))
3963      (symbol-macrolet (
3964                        (referral   (cdr (assq 'referral   whois-data)))
3965                        (registrant (cdr (assq 'registrant whois-data)))
3966                        (email      (cdr (assq 'email      whois-data)))
3967                        (admin      (cdr (assq 'admin      whois-data)))
3968                        (tech       (cdr (assq 'tech       whois-data)))
3969                        (zone       (cdr (assq 'zone       whois-data)))
3970                        (records    (cdr (assq 'records    whois-data)))
3971                        (servers    (cdr (assq 'servers    whois-data))))
3972        ,@body)))
3973
3974 ;;; ----------------------------------------------------------------------
3975 ;;;
3976 ;;; Registrant:
3977 ;;; David L. Dahl (DDAHL-DOM)
3978 ;;;    PO BOX
3979 ;;;    Chicago, IL 60657
3980 ;;;    US
3981 ;;;
3982 ;;;    Domain Name: DDAHL.COM
3983 ;;;
3984 ;;;    Administrative Contact:
3985 ;;;       Dahl, David  (DD4553)              ddahl@DDAHL.COM
3986 ;;;       3450 N. Lakeshore Dr. #2605
3987 ;;;       Chicago, IL 60657
3988 ;;;       US
3989 ;;;       773-934-1738 fax: 847-746-8841
3990 ;;;    Technical Contact:
3991 ;;;       Network Solutions, Inc.(HOST-ORG) customerservice@networksolutions.com
3992 ;;;       21355 Ridgetop Circle
3993 ;;;       Dulles, VA 20166
3994 ;;;       US
3995 ;;;       1-888-642-9675 fax: 123 123 1234
3996 ;;;
3997 ;;;    Record expires on 31-Mar-2005.
3998 ;;;    Record created on 18-Sep-2002.
3999 ;;;    Database last updated on 23-Aug-2003 04:47:44 EDT.
4000 ;;;
4001 ;;;    Domain servers in listed order:
4002 ;;;
4003 ;;;    NS1.GALLERYHOSTING.NET       209.19.90.117
4004 ;;;    GHZ.DDAHL.COM                209.19.90.118
4005 ;;;    WWW.CONDOSYSTEMS.COM         64.202.114.20
4006 ;;;
4007 ;;;
4008 (defun ti::mail-whois (site &optional options verb bin)
4009   "Call `whois' and return results.
4010 Web interface is at http://www.internic.net/whois.html
4011
4012 Input:
4013
4014   site          Top level domain. Make sure you have called
4015                 ´ti::mail-ip-top-level-domain' first.
4016   OPTIONS       list, additional options. E.g. -h HOST
4017   VERB          flag, if non-nil print verbose messages. (Recommended)
4018   BIN           Location of the binary."
4019   (let* ((path  (or bin
4020                     (get 'ti::mail-whois 'binary)
4021                     (executable-find "whois")
4022                     (error "No `whois' binary found.")))
4023          args)
4024     (put 'ti::mail-whois 'binary path)
4025     (when (and options
4026                (not (ti::listp options)))
4027       (error "OPTIONS must be a list."))
4028     (when (string-match "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" site)
4029       (setq args options)
4030       (push site args)
4031       (if verb
4032           (message "TinylibMail: whois %s ..." site))
4033       (with-temp-buffer
4034         (apply 'call-process
4035                path
4036                nil       ;; input
4037                '(t t)    ;; mix stdout and stderr
4038                nil       ;; display
4039                args)
4040         (if verb
4041             (message "TinylibMail: whois %s ...done." site))
4042         (buffer-string)))))
4043
4044 ;;; ----------------------------------------------------------------------
4045 ;;;
4046 (defun ti::mail-nslookup-parse ()
4047   "Parse nslookup output in current buffer forward.
4048
4049 Buffer contains:
4050
4051   Non-authoritative answer:
4052   Server:  this.server.com
4053   Address:  nnnn.nnn.nnn.nnn
4054
4055   Name:    NAME.ANSWER.COM
4056   Addresses:  NNN.NNN.NNN.NNN,NNN.NNN.NNN.NNN
4057
4058 Return:
4059
4060 '(NAME.ANSWER.COM (NNN.NNN.NNN.NNN  NNN.NNN.NNN.NNN ..))."
4061   (let* (name
4062          ip-list
4063          (re            "[ \t]+\\([^ \t\r\n]+\\)")
4064          (name-regexp   (concat "name:"  re))
4065          (regexp1       (concat "address:"   re))
4066          (regexp2       "addresses:[ \t]+\\([^\r\n]+\\)"))
4067     (when (re-search-forward "^[ \t]*$" nil t)
4068       (forward-line 1)
4069       (when (re-search-forward name-regexp nil t)
4070         (setq name (match-string 1))
4071         (cond
4072          ((re-search-forward regexp1 nil t)
4073           (setq ip-list (list (match-string 1))))
4074          ((re-search-forward regexp2 nil t)
4075           (let ((ip (match-string 1)))
4076             (setq ip-list
4077                   (if (not (string-match "," ip))
4078                       (list ip)
4079                     (list (split-string ip "[ \t,]+")))))))))
4080     (if ip-list
4081         (list name ip-list))))
4082
4083 ;;; ----------------------------------------------------------------------
4084 ;;;
4085 ;;;  % nslookup 204.253.213.3
4086 ;;;  Name Server:  example.com
4087 ;;;  Address:  131.228.134.50
4088 ;;;
4089 ;;;  Name:    librum.sourcery.com
4090 ;;;  Address:  204.253.213.3
4091 ;;;
4092 ;;;  Can also have string:
4093 ;;;
4094 ;;;  *** No address information is available for "mktg@inet.com"
4095 ;;;
4096 ;;;  NOTE: There may be "Addresses:"
4097 ;;;  =========================================================
4098 ;;;
4099 ;;;  Server:  ns3.tpo.fi
4100 ;;;  Address:  212.63.10.250
4101 ;;;
4102 ;;;  Name:    yahoo.com
4103 ;;;  Addresses:  216.115.109.6, 216.115.109.7
4104 ;;;
4105 (defun ti::mail-nslookup (ip &optional options verb bin)
4106   "Run `nslookup' for IP.
4107
4108 Note:
4109
4110   If IP address does not match 2-3 alphabetic character or max 3 digits
4111   at the end, then the address is not checked at all. It is immediately
4112   discarded.
4113
4114 Input:
4115
4116   IP            numeric on normal site address.
4117   OPTIONS       list, additional options. E.g. -query=any
4118   VERB          flag, if non-nil print verbose messages. (Recommended)
4119   BIN           Location of the binary
4120
4121 Return:
4122
4123   '(name . address)
4124
4125 If nslookup fails, the return value is '(ORIG-IP nil)"
4126   (let* ( ;;  It's faster to use absolute pathname.
4127          ;;
4128          (path  (or bin
4129                     (get 'ti::mail-nslookup 'binary)
4130                     (executable-find "nslookup")
4131                     (error "No `nslookup' binary found.")))
4132          args)
4133     (put 'ti::mail-nslookup 'binary path)
4134     (when (and options
4135                (not (ti::listp options)))
4136       (error "OPTIONS must be a list."))
4137     (with-temp-buffer
4138       (when verb
4139         (message "TinylibMail: nslookup %s ..." ip))
4140       (when (string-match
4141              "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" ip)
4142         (setq args options)
4143         (push ip args)
4144         (apply 'call-process
4145                path
4146                nil     ;; input
4147                '(t t)  ;; mix stdout and stderr
4148                nil     ;; display
4149                args))
4150       (when verb
4151         (message "TinylibMail: nslookup %s ...done." ip))
4152       (unless (ti::re-search-check "No address information")
4153         (ti::pmin)
4154         (ti::mail-nslookup-parse)))))
4155
4156 ;;; ----------------------------------------------------------------------
4157 ;;;
4158 (put 'ti::with-mail-nslookup 'edebug-form-spec '(body))
4159 (put 'ti::with-mail-nslookup 'lisp-indent-function 1)
4160 (defmacro ti::with-mail-nslookup (data &rest body)
4161   "with resault of `ti::mail-nslookup' DATA '(ip (ip ...)) run BODY.
4162 The following variables are available during looping within BODY:
4163
4164   ip-name  ip-found."
4165   `(multiple-value-bind (ip-name ip-list)
4166        (list
4167         (car ,data)
4168         (cdr ,data))
4169      (dolist (ip-found ip-list)
4170        ,@body)))
4171
4172 ;;; ----------------------------------------------------------------------
4173 ;;;
4174 (defun ti::mail-dig (ip &optional options verb bin)
4175   "Run `dig' for IP.
4176
4177 Note:
4178
4179   If IP address does not match 2-3 alphabetic character or max 3 digits
4180   at the end, then the address is not checked at all. It is immediately
4181   discarded.
4182
4183 Input:
4184
4185   IP            numeric on normal site address.
4186   OPTIONS       list, additional options. E.g. -query=any
4187   VERB          flag, if non-nil print verbose messages. (Recommended)
4188   BIN           Location of the binary
4189
4190 Return:
4191
4192   '(name . address)
4193
4194 If nslookup fails, the return value is '(ORIG-IP nil)"
4195   (let* ( ;;  It's faster to use absolute pathname.
4196          ;;
4197          (path  (or bin
4198                     (get 'ti::mail-dig 'binary)
4199                     (executable-find "dig")
4200                     (error "No `nslookup' binary found.")))
4201          args)
4202     (put 'ti::mail-dig 'binary path)
4203     (when (and options
4204                (not (ti::listp options)))
4205       (error "OPTIONS must be a list."))
4206     (with-temp-buffer
4207       (when verb
4208         (message "TinylibMail: dig %s ..." ip))
4209       (when (string-match
4210              "\\.[0-9][0-9]?[0-9]?$\\|\\.[a-z][a-z][a-z]*$" ip)
4211         (setq args options)
4212         (push ip args)
4213         (apply 'call-process
4214                path
4215                nil     ;; input
4216                '(t t)  ;; mix stdout and stderr
4217                nil     ;; display
4218                args))
4219       (when verb
4220         (message "TinylibMail: dig %s ...done." ip))
4221       (buffer-string))))
4222
4223 ;;}}}
4224 ;;{{{ misc
4225
4226 ;;; ............................................................ &misc ...
4227
4228 ;;; ----------------------------------------------------------------------
4229 ;;;
4230 (defun ti::mail-get-buffer  (&optional mode-list)
4231   "Return open mail buffer if one exists.
4232 MODE-LIST is the search order precedence. It can take values
4233 'mail-mode 'message-mode and any
4234 other valid mail like modes.
4235
4236 Example:
4237
4238   ;; Return some mail-mode buffer. If there is none, then
4239   ;; return some message-mode buffer.
4240
4241   (ti::mail-get-buffer '(mail-mode message-mode))"
4242   (let* (list
4243          buffer)
4244     (or mode-list
4245         (setq mode-list '(mail-mode message-mode mh-letter-mode)))
4246     (dolist (buffer (buffer-list))
4247       (with-current-buffer buffer
4248         (dolist (mode mode-list)
4249           (when (eq major-mode mode)
4250
4251             ;;  We keep the separate mode in the plist
4252             ;;
4253             ;;  LIST: plist 'MODE1 --> '(buffer buffer ...)
4254             ;;      : plist 'MODE2 --> '(buffer buffer ...)
4255
4256             (setq list (get 'list mode)) ;Read current list
4257             (push (current-buffer) list) ;Add one
4258             ;;  And update plist
4259             (put 'list mode list)))))
4260
4261     ;;  Step through mode lists and return first buffer
4262
4263     (dolist (mode mode-list)
4264       (when (setq buffer (car-safe (get 'list mode)))
4265         (return)))
4266     buffer))
4267
4268 ;;; ----------------------------------------------------------------------
4269 ;;;
4270 (defun ti::mail-signature-insert-break (&optional point)
4271   "Insert RFC signature break to current point or POINT if no sig break exist.
4272 According to RFC there must be \"-- \\n\" before signature. The extra space
4273 separates the signature from e.g. digest messages that come with \"--\\n\"
4274
4275 We try to find this string forward and it is not there we add one."
4276   (save-excursion
4277     (if point (goto-char point))
4278     (if (null (re-search-forward "^-- \n" nil t))
4279         (insert "-- \n"))))
4280
4281 ;;; ----------------------------------------------------------------------
4282 ;;;
4283 (defun ti::mail-yank (&optional prefix)
4284   "Yank message to current point and add optional PREFIX. GNUS/RMAIL."
4285   (let* (p
4286          (yb (ti::mail-mail-buffer-name)) ;where is the yank buffer ?
4287
4288          ;;  See this mail is called from GNUS
4289          ;;
4290          ;;  - If GNUS isn't loaded, set buf name to nil
4291
4292          (gnus-buf (and (boundp 'gnus-article-buffer)
4293                         (symbol-value 'gnus-article-buffer)))
4294
4295          ;;  Test if gnus-reply; the buffers are the same
4296
4297          (gnus-r (and gnus-buf
4298                       (string= gnus-buf yb))))
4299     (save-excursion
4300       (setq p (point))
4301
4302       ;;  (mail-yank-original '(4))     ; mimic C-u C-c C-y == no indent
4303       ;;  - bypass all, see sendmail::mail-yank-original
4304       ;;    this is more robust, and runs no extra hooks
4305       ;;  - If in GNUS, the buffer will be *Article*, which is
4306       ;;    narrowed to headers...widen the buffer before yanking.
4307
4308       (if (null gnus-r)
4309           (progn                        ; normal mail
4310             (mail-yank-original '(4)))
4311         (save-excursion (set-buffer yb) (widen))
4312         (insert-buffer yb))
4313       (ti::pmax)
4314       (delete-blank-lines)
4315       (if prefix
4316           (string-rectangle p (point-max)  prefix)))))
4317
4318 ;;; ----------------------------------------------------------------------
4319 ;;;
4320 (defun ti::mail-trim-buffer ()
4321   "Trim email message so that there are no trailing white spaces.
4322 - at the beginning of message
4323 - at the end of each line
4324 - at the end of message.
4325
4326 If cannot find text start point, uses `point-min'. The point is not preserved.
4327
4328 Return:
4329   t         there is no text. All white spaces were removed
4330   nil       trimming done."
4331   (let ((beg  (ti::mail-text-start))
4332         ret)
4333     (goto-char beg)
4334     (ti::buffer-replace-regexp "[ \t]+$" 0 "") ;right hand spaces (ragged lines)
4335     (goto-char beg)
4336
4337     ;;   Beginning of email message
4338
4339     (ti::buffer-trim-blanks beg (point-max))
4340     (ti::buffer-delete-until-non-empty-line nil beg)
4341
4342     (ti::buffer-delete-until-non-empty-line 'backward (point-max))
4343     (forward-line 1)
4344
4345     ;;  Any text left ? Signing empty file is not sensible...
4346
4347     (if (eq (point) beg)
4348         (setq ret t)
4349       ;;  Note: User may write message "123" to the body, but we must
4350       ;;  require final newline every time: "123\n", the trim
4351       ;;  command will remove any exeessive newlines.
4352       (ti::pmax)
4353       (if (not (char= (preceding-char) ?\n))
4354           (insert "\n")))
4355     ret))
4356
4357 ;;}}}
4358
4359 ;;{{{ fields, headers
4360
4361 ;;;  .......................................................... &fields ...
4362
4363 (defsubst ti::mail-field-space-count (field-name &optional field-value )
4364   "Check how many spaces is at the beginning of field.
4365 Input:
4366
4367   FIELD-NAME        If given, fetch FIELD-NAME like 'to' and check it's value.
4368   FIELD-VALUE       If given, use this string as field content. Argument
4369                     FIELD-NAME is ignored.
4370
4371 Return
4372
4373   N                 Number of space."
4374   (or field-value
4375       (and (or (stringp field-name) (error "Missing field-name"))
4376            (setq field-value (ti::mail-get-field field-name)))
4377       (error "No field"))
4378   (and field-value
4379        (length (ti::string-match "^[^ ]*\\( +\\)" 1 field-value))))
4380
4381 ;;; ----------------------------------------------------------------------
4382 ;;;
4383 (defun ti::mail-field-start (field-re &optional move max)
4384   "Return starting point of FIELD-RE or nil. Optionally MOVE to it.
4385
4386 Supposes that field has following format, the cursor -!- position
4387 signifies returned point.
4388
4389   field:-!-
4390
4391 Input:
4392
4393   FIELD-RE      field regexp
4394   MOVE          should we move to found point? (beginning-of-line)
4395   MAX           search until MAX point"
4396   (let (ret)
4397     (save-excursion
4398       (ti::pmin)
4399       (when (re-search-forward field-re max t)
4400         (beginning-of-line)
4401         (when (re-search-forward ":" max t)
4402           (setq ret (point)))))
4403     (if (and move ret)
4404         (goto-char ret))
4405     ret))
4406
4407 ;;; ----------------------------------------------------------------------
4408 ;;;
4409 (defun ti::mail-next-field-start (&optional move back max)
4410   "Return starting point of next field or nil. Optionally move to field.
4411
4412 Note:
4413
4414   If you're somewhere else than inside header area, the return value
4415   is not defined.
4416
4417 Input:
4418
4419   MOVE          move to point
4420   BACK          move backward (field start)
4421   MAX           search until this point. PLEASE USE THIS TO LIMIT SEARCH
4422
4423 Return:
4424
4425   point
4426   nil"
4427   (let ((func (if back 're-search-backward 're-search-forward))
4428         opoint
4429         point
4430         ret)
4431     (save-excursion
4432       (if (null back)
4433           (end-of-line))
4434
4435       (if (and (bobp) back)             ;first field
4436           (setq ret (point))
4437
4438         ;;   Next line must have text, otherwise the headers have ended
4439         ;;   alredy
4440         ;;
4441         ;;   Header1:
4442         ;;   Header2:
4443         ;;
4444         ;;   BODY-OF-TEXT
4445
4446         (cond
4447          ((save-excursion
4448             (forward-line 1)
4449             (looking-at ".*[a-zA-Z0-9]"))
4450           (setq opoint (point))
4451
4452           ;;  In the last field, the previsu regexp skips too much,
4453           ;;  see where the cursor (*) is. We search backward if possible
4454           ;;  to find header separator (empty line)
4455           ;;
4456           ;;  Header:
4457           ;;    last header text
4458           ;;
4459           ;;  *BODY
4460
4461           (when (progn
4462                   (when (and (setq point (funcall func "^[^ \t]" max t))
4463                              (eq func  're-search-forward))
4464                     (goto-char opoint)  ;Try again
4465                     (if (re-search-forward "^$" nil t)
4466                         ;; no, it was further ahead, use previous search pos
4467                         (if (< (point) point)
4468                             (setq point (point)))))
4469                   point)
4470             (goto-char point)
4471             (beginning-of-line)
4472             (setq ret (point))))
4473          (t
4474           ;;  Hm, next line is empty line, not a field for us any more.
4475           nil))))
4476
4477     (if (and move ret)
4478         (goto-char ret))
4479
4480     ret))
4481
4482 ;;; ----------------------------------------------------------------------
4483 ;;;
4484 (defsubst ti::mail-field-string-wrap (string)
4485   "Wrap i.e. delete embedded newlines in string.
4486
4487 X-My: one line
4488    two line
4489    three line.
4490
4491 =>
4492
4493 X-My: one line two line three line."
4494   (replace-regexp-in-string "[\r\n][ \t]+" " " string))
4495
4496 ;;; ----------------------------------------------------------------------
4497 ;;;
4498 (defsubst ti::mail-field-string-p (string)
4499   "Check if string starts with Field:
4500 Subexpression 1 contains field name and 2 contains rest."
4501   (string-match "^\\([A-Z][^:]+\\):\\(.*\\)" string))
4502
4503 ;;; ----------------------------------------------------------------------
4504 ;;; #todo:
4505 (defun ti::mail-field-line-p ()
4506   "Return `field' name if the bginning of line contains 'NNNN:'."
4507   (let ((str (buffer-substring
4508               (line-beginning-position)
4509               (line-end-position))))
4510     (when (ti::mail-field-string-p str)
4511       (match-string 1 str))))
4512
4513 ;;; ----------------------------------------------------------------------
4514 ;;;
4515 (defun ti::mail-field-read-line-at-point (&optional wrap)
4516   "Read whole header field at point. Field may continue in separate line.
4517 Point -!- must be at the beginning line of field.
4518
4519 X-More: this is one line-!-
4520   That is wrapped to send
4521   and even third.
4522
4523 If WRAP is non-nil, call `ti::mail-field-string-wrap'."
4524   (let ((beg (line-beginning-position))
4525         (end (ti::mail-next-field-start)))
4526     (when (and beg end)
4527       (let ((line (buffer-substring beg (1- end))))
4528         (if wrap
4529             (ti::mail-field-string-wrap line)
4530           line)))))
4531
4532 ;;; ----------------------------------------------------------------------
4533 ;;;
4534 (defun ti::mail-field-read-fuzzy (&optional wrap)
4535   "Read whole header field at point.
4536 The point can be anywhere in the field.
4537 If WRAP is non-nil, call `ti::mail-field-string-wrap'."
4538   (save-excursion
4539     (beginning-of-line)
4540     (unless (ti::mail-field-line-p)
4541       (ti::mail-next-field-start 'move 'back))
4542     (ti::mail-field-read-line-at-point wrap)))
4543
4544 ;;; ----------------------------------------------------------------------
4545 ;;; #todo:
4546 (defun ti::mail-current-field-name  ()
4547   "Return name of field at current point or nil."
4548   (save-excursion
4549     (when (or (not (bolp))
4550               (and (bolp)
4551                    ;;  Newly opened line - continuation of e.g. To: field.
4552                    (looking-at "^[ \t]*$")))
4553       (ti::mail-next-field-start 'move 'back))
4554     (ti::mail-field-line-p)))
4555
4556 ;;; ----------------------------------------------------------------------
4557 ;;;
4558 (defun ti::mail-field-email-send-p (&optional header-regexp)
4559   "Check if point is at field To, Cc or Bcc"
4560   (let ((field (ti::mail-current-field-name)))
4561     (when (and field
4562                (string-match
4563                 (or header-regexp
4564                     "^\\(to\\|cc\\|bcc\\)$")
4565                 field))
4566       field)))
4567
4568 ;;; ----------------------------------------------------------------------
4569 ;;;
4570 (defun ti::mail-field-email-address-p ()
4571   "Check if point is at field To, Cc, Bcc, From, Sender."
4572   (ti::mail-field-email-send-p
4573    "^\\(to\\|cc\\|bcc\\|from\\|sender\\)$"))
4574
4575 ;;; ----------------------------------------------------------------------
4576 ;;;
4577 (defun ti::mail-kill-field-in-body (list)
4578   "Kill LIST of field that are inserted into body of message."
4579   (ti::narrow-safe (ti::mail-text-start) (point-max)
4580     (dolist (header list)
4581       (ti::mail-kill-field header))))
4582
4583 ;;; ----------------------------------------------------------------------
4584 ;;;
4585 (defun ti::mail-kill-field (field-re &optional replace-str)
4586   "Delete header field. Remember to supply Anchor '^' in FIELD-RE.
4587
4588 Input:
4589
4590   FIELD-RE      any regexp matching a line
4591   REPLACE-STR   replace field content with this
4592
4593 Return:
4594
4595   t             field changed or killed
4596   nil           nothing done [field not exist]"
4597   (let ((hdr-end  (ti::mail-hmax))
4598         beg
4599         end)
4600
4601     (when hdr-end
4602       (if replace-str
4603           (setq replace-str (ti::string-verify-ends replace-str " " nil 'beg)))
4604
4605       (save-excursion
4606         (when (and (setq beg  (ti::mail-field-start field-re 'move))
4607                    (setq end  (ti::mail-next-field-start))
4608                    (<= end hdr-end))
4609 ;;;             (setq F field-re B beg E end)
4610           (if replace-str
4611               (progn
4612                 (delete-region beg end)
4613                 (insert (concat replace-str "\n")))
4614             (beginning-of-line)
4615             (delete-region (point) end)
4616             t))))))
4617
4618 ;;; ----------------------------------------------------------------------
4619 ;;;
4620 (defun ti::mail-get-field-1 (field)
4621   "Read FIELD by finding regexp matching '^FIELD:'.
4622 Starting searching from the beginning of buffer. You are encouraged to call
4623 this function instead of `ti::mail-get-field' if you want to get the
4624 field information fast e.g. in `post-command-hook'.
4625
4626 This function is not as reliable as `ti::mail-get-field', because
4627 the search is not limited to header area, but for regular headers
4628 you can use this function safely."
4629   (let ((re  (format "^%s:" field))
4630         beg
4631         end)
4632     (save-excursion
4633       (ti::pmin)
4634       (if (and (re-search-forward re nil t)
4635                (setq beg (point)
4636                      end (ti::mail-next-field-start)))
4637           (buffer-substring beg (1- end))))))
4638
4639 ;;; ----------------------------------------------------------------------
4640 ;;; - This is almost the same as mail-utils.el/mail-fetch-field,
4641 ;;;   but offers more control. It can get citated fields too, if
4642 ;;;   ANY parameter is non-nil.
4643 ;;; - And it returns _strict_ content of the field, fetch-field strips
4644 ;;;   spaces away.
4645 ;;;
4646 (defun ti::mail-get-field (field &optional any mode)
4647   "Return field content.
4648
4649 Input:
4650
4651    FIELD         field name without anchor '^' and char ':'
4652    ANY           return any field. When non-nil, drops anchor ^
4653                  from the  ^field: criteria
4654    MODE          nil    read the field as is, returning all chars
4655                         after the ':'
4656                  t      If field has only spaces, Return nil
4657                  'pure  Include header name as well as content.
4658
4659 Return:
4660
4661    nil or contents of field."
4662   (let ((case-fold-search t)            ;ignore case = t
4663         (re (if any
4664                 (concat field ":")      ; pick first one met
4665               (concat "^" field ":")))  ; require STRICT HEADER
4666
4667         (hmax (if any nil (ti::mail-text-start)))
4668         beg
4669         end
4670         ret)
4671     (save-excursion
4672       (when (and (setq beg (ti::mail-field-start re 'move hmax))
4673                  (setq end (ti::mail-next-field-start nil nil hmax)))
4674         (when (and (eq mode 'pure)
4675                    (looking-at "[\t ]*[^\n\t ]+")) ;not empty
4676           (beginning-of-line)
4677           (setq beg (point)))
4678         (setq ret (buffer-substring beg (1- end)))))
4679     (when (and mode
4680                (stringp ret)
4681                (string-match "^[ \t\n\r]*\\'" ret))
4682       (setq ret nil))
4683     ret))
4684
4685 ;;; ----------------------------------------------------------------------
4686 ;;; - If you want simple filed adding to your mail, then have a look
4687 ;;;   at this instead:
4688 ;;;
4689 ;;;     (defconst my-mail-info-string "Emacs RMAIL in 19.28")
4690 ;;;     (setq mail-default-headers
4691 ;;;           (concat
4692 ;;;            "X-info: " my-mail-info-string "\n"))
4693 ;;;
4694 (defun ti::mail-add-field (field text &optional look-field mode replace)
4695   "Add FIELD and puts TEXT into it.
4696 If field already exist, replaces field text.
4697 By default, field is added to the end of header.
4698
4699 Input:
4700
4701   FIELD         string, like \"To\".
4702   TEXT          \\n at end is optional. _No_ colon and _no_ spaces.
4703   LOOK-FIELD    new field will be added after this. _No_ colon at end.
4704                 if MODE is non-nil, field is added before this field
4705
4706                 If there is no LOOK-FIELD, nothing is done and nil
4707                 is returned.
4708
4709   MODE          see look-field
4710   REPLACE       if non-nil Any previous field is removed. You probably
4711                 want to set this flag to non-nil if you only want unique
4712                 field names.
4713
4714 Return:
4715
4716   t             something done
4717   nil           nothing done, maybe look-field doesn't exist ?"
4718   (let* ((field-re (concat "^" field ":")))
4719     (save-excursion
4720       (cond
4721        (look-field
4722         (if replace
4723             (ti::mail-kill-field field-re)) ;Remove
4724         (when (and look-field
4725                    (ti::mail-field-start (concat "^" look-field) 'move))
4726           (unless mode                  ;use only forward
4727             (ti::mail-next-field-start 'move mode))
4728           (beginning-of-line)
4729           (insert (concat field ": " text))
4730           t))
4731        (t                               ;add to the end
4732         (if (mail-fetch-field field)
4733             (ti::mail-kill-field field-re text)
4734           (mail-position-on-field field)
4735           (insert text))
4736         t)))))
4737
4738 ;;; ----------------------------------------------------------------------
4739 ;;;
4740 (defun ti::mail-add-to-field-string (field string &optional look-field sep )
4741   "Find FIELD and add STRING to the. Field is created if it does not exist.
4742
4743 Input:
4744
4745   FIELD      string WITHOUT colon, anchor or spaces.
4746   STRING     added text
4747   LOOK-FIELD field name. If Field does not exist, add field after this field.
4748              See `ti::mail-add-field'
4749   SEP        defaults to comma and space."
4750   (or sep
4751       (setq sep ", "))
4752
4753   (save-excursion
4754     (ti::pmin)
4755     (let ((content  (mail-fetch-field field)))
4756       (if (ti::nil-p content)
4757           (ti::mail-add-field field string look-field)
4758         (re-search-forward (concat "^" field ":"))
4759         (ti::mail-next-field-start 'move)
4760         (skip-chars-backward " \n\t")
4761         (insert sep string)))))
4762
4763 ;;; ----------------------------------------------------------------------
4764 ;;;
4765 (defun ti::mail-kill-field-elt (re &optional field)
4766   "Kill all elts matching RE from FIELD, which defaults to cc.
4767 Elements are supposed to be separated by commas.
4768
4769 Example:
4770
4771    To: him@example.com
4772    CC: me@example.com, you@example.com
4773
4774    ;;  If called with this
4775
4776    (ti::mail-kill-field-elt \"me\")
4777    --> To: him@example.com
4778    --> CC: you@example.com
4779
4780    ;; If called with this; all elts are matched and thus the
4781    ;; field is removed
4782
4783    (ti::mail-kill-field-elt \".\")
4784    --> To: him@example.com"
4785   (let* (flag
4786          str
4787          fld)
4788     (setq field (or field "CC"))
4789
4790     (when (setq fld    (ti::mail-get-field field))
4791       ;; remove spread lines
4792
4793       (setq fld (replace-regexp-in-string "[\n\f\t ]+" "" fld))
4794       (setq fld (split-string fld "[,]+")) ; divide into items
4795
4796       ;; ... ... ... ... ... ... ... ... ... ... ... ...  remove items . .
4797
4798       (setq fld
4799             (ti::list-find  fld re
4800                             (function
4801                              (lambda (arg elt)
4802                                (not (string-match arg elt))))
4803                             'all-items))
4804
4805       ;; ... ... ... ... ... ... ... ... ... ... ... . build up string . .
4806
4807       (dolist (elt fld)
4808         (if (null flag)
4809             (setq flag  t               ;done 1st line
4810                   str   (concat " " elt))
4811           (setq str (concat
4812                      str ", " elt
4813                      (if (> (+ (length str) (length elt))  70)
4814                          "\n  "  "")))))
4815
4816       ;; ... ... ... ... ... ... ... ... ... ... ... ...  write new fld . .
4817       (if str
4818           (ti::mail-kill-field (concat "^" field) str) ;replace
4819         ;;  Remove whole field, all entries were discarded.
4820         ;;
4821         (ti::mail-kill-field (concat "^" field))))))
4822
4823 ;;; ----------------------------------------------------------------------
4824 ;;; - This is mainly for converting your mail to anon post by
4825 ;;;   removing any headers you might have added.
4826 ;;;
4827 (defun ti::mail-kill-non-rfc-fields (&optional list)
4828   "Kill all non RFC fields unless LIST (HEADER-NAME-SYMBOL .. ) list is given.
4829
4830 References
4831   `ti::mail-required-headers'    ,default rfc headers"
4832   (let ((ptr (or list
4833                  (ti::mail-required-headers)
4834                  (error "(ti::mail-required-headers) returned nil")))
4835         (case-fold-search t)
4836         fld
4837         list)
4838     ;;  First we gather all valid headers to list
4839     (dolist (elt ptr)
4840       (setq fld (symbol-name elt))
4841       (when (setq elt (ti::mail-get-field fld))
4842         (ti::nconc list (format "%s:%s" (capitalize fld) elt))))
4843     ;; Now we kill all headers and yank the valid ones back.
4844     (ti::mail-hmax 'move)
4845     (delete-region (point-min) (point))
4846     (setq ptr list)
4847     (dolist (elt ptr)
4848       (insert elt "\n"))))
4849
4850 ;;; ----------------------------------------------------------------------
4851 ;;;
4852 (defun ti::mail-get-all-email-addresses
4853   (&optional field-list abbrev-alist no-expand)
4854   "Return all email addresses from FIELD-LIST.
4855
4856 Input:
4857
4858  FIELD-LIST     Eg. '(\"To\" \"CC\"). Default is To CC and BCC.
4859  ABBREV-ALIST   see function `ti::mail-abbrev-expand-mail-aliases'
4860  NO-EXPAND      if non-nil, Do not expand addresses on current buffer.
4861
4862 Return:
4863  '(str str ..)  notice that there may be \"\" empty strings"
4864   (let ((buffer  (if no-expand
4865                      (generate-new-buffer "*tmp*")
4866                    (current-buffer)))
4867         str
4868         mems
4869         field
4870         ret)
4871     (unwind-protect
4872         (progn
4873           (or field-list (setq field-list '("To" "CC" "BCC")))
4874
4875           (when no-expand
4876             (dolist (fld field-list)
4877               (setq str
4878                     (concat (or str "")
4879                             (ti::mail-get-field fld nil 'pure)
4880                             "\n"))))
4881
4882           (with-current-buffer buffer
4883             (if str (insert str))
4884
4885             (ti::save-with-marker-macro
4886               (ti::mail-abbrev-expand-mail-aliases
4887                (point-min)
4888                (if str
4889                    (point-max)
4890                  (ti::mail-hmax))
4891                abbrev-alist))
4892
4893 ;;;         (pop-to-buffer (current-buffer)) (ti::d! "MT:ABB" field-list)
4894
4895             (dolist (elt field-list)
4896               (when (setq field (mail-fetch-field elt))
4897                 (setq mems (split-string field "[,\n]+")) ;members ?
4898 ;;;             (ti::d! elt field mems)
4899                 (dolist (mem mems)
4900                   (unless (ti::nil-p mem)
4901                     (push mem ret))))))) ;; with-current + progn
4902       ;;  make sure temp buffer is removed.
4903
4904       (if no-expand
4905           (kill-buffer buffer)))
4906     (nreverse ret)))
4907
4908 ;;; ----------------------------------------------------------------------
4909 ;;;
4910 (defun ti::mail-set-recipients (to-list &optional cc-list cc-flag)
4911   "Compose current mail message to TO-LIST and add info about CC-LIST.
4912
4913 Input:
4914
4915   TO-LIST       List of real recipients.
4916   CC-LIST       List of additional recipients that are put to
4917                 X-Cc-Info. These are not actual CC members.
4918   CC-FLAG       Treat CC-LIST as actual recipients. This is like combining
4919                 TO-LIST and CC-LIST. No X-Cc-Info field is added."
4920   (when cc-flag
4921     (setq to-list (ti::list-merge-elements to-list cc-list)
4922           cc-list nil))
4923
4924   (ti::mail-kill-field "^To")
4925   (ti::mail-kill-field "^CC")
4926   (ti::mail-kill-field "^X-Cc-Info")
4927
4928   (ti::mail-add-field "To" (pop to-list))
4929   (when to-list
4930     (ti::mail-add-field "Cc" (mapconcat 'concat to-list ",")))
4931
4932   (when cc-list
4933     (ti::mail-add-field
4934      "X-Cc-Info"
4935      (concat "Additional recipient(s)\n  "
4936              (mapconcat 'concat cc-list ",")))))
4937
4938 ;;}}}
4939 ;;{{{ News, articles
4940
4941 ;;; ............................................................ &News ...
4942
4943 ;;; ----------------------------------------------------------------------
4944 ;;;
4945 (defun ti::mail-news-buffer-p ()
4946   "Check if current buffer is news post, followup or the like."
4947   (interactive)
4948   (cond
4949    ((and (eq major-mode 'message-mode) (fboundp 'message-news-p))
4950     (ti::funcall 'message-news-p))
4951    ((and (eq major-mode 'message-mode) (boundp 'message-this-is-news))
4952     (symbol-value 'message-this-is-news))
4953    ((string-match "news" (symbol-name major-mode)))
4954    (t
4955     ;;  Gnus keeps it in 'message-mode', so search this header then
4956     (save-excursion
4957       (ti::pmin)
4958       (re-search-forward "Newsgroups\\|References:\\|Gcc:" nil t)))))
4959
4960 ;;; ----------------------------------------------------------------------
4961 ;;;
4962 (defun ti::mail-article-regexp-read-line (re &optional level)
4963   "Switch to article buffer; match RE at LEVEL and return match."
4964   (let (line)
4965     (or level
4966         (setq level (or level 0)))
4967     (ti::mail-with-article-buffer
4968      (ti::pmin)
4969      (if (re-search-forward re nil t)
4970          (setq line (match-string level))))
4971     line))
4972
4973 ;;; ----------------------------------------------------------------------
4974 ;;; - This is useful if you use same hook for both
4975 ;;;   regular mail posting AND for gnuis posting.
4976 ;;; - It makes it possible to decicede inside hook, which post
4977 ;;;   type this is. Eg. setting extra headers for NEWS and not
4978 ;;;   different for regular Mail
4979 ;;;
4980 (defun ti::mail-news-reply-p ()
4981   "Return type of message being composed.
4982 This function is meaningful _only_ when you use it inside
4983 some GNUS or mail hook.  The buffer must be current mail buffer.
4984
4985 Return:
4986   'news         news
4987   nil"
4988   (let* ((mode          (symbol-name major-mode))
4989
4990          ;;             GNUS might not be loaded in this emacs
4991          (gnus-buf      (if (boundp 'gnus-article-buffer)
4992                             ;; normally name is "Article"
4993                             (symbol-value 'gnus-article-buffer)
4994                           ""))
4995
4996          (mail-buf      (ti::mail-mail-buffer-name)) ;YANK buffer name?
4997
4998          ;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ GNUS
4999          ;; - Detect news posting mode. The mail program uses
5000          ;;   YANK from the gnus buffer "*Article*" So we can detect
5001          ;;   if this is gnus post
5002          ;; - gnus 'news-mail-reply-->rnewspost.el
5003
5004          (gnus          (string= gnus-buf mail-buf))
5005
5006          (news-mode     (or gnus
5007                             (string-match "news" mode)
5008                             (save-excursion ;Gnus
5009                               (ti::pmin)
5010                               (re-search-forward "^References:" nil t)))))
5011     (if news-mode
5012         'news)))
5013
5014 ;;}}}
5015 ;;{{{ anon.penet.fi anon-nymserver.com
5016
5017 ;;; ............................................................ &anon ...
5018
5019 ;;; ----------------------------------------------------------------------
5020 ;;;
5021 (defun ti::mail-anon-penet-p (email)
5022   "Check if EMAIL is penet anon address."
5023   (string-match "[an][an][0-9]+@.*penet.fi" email))
5024
5025 ;;; ----------------------------------------------------------------------
5026 ;;;
5027 (defun ti::mail-anon-penet-to-p ()
5028   "Check if the TO: field contain anon.penet.fi address.
5029
5030 Return:
5031   nil
5032   email       if it's anon address."
5033   (let  ((to (ti::mail-get-field "to")))
5034     (if (and to (ti::mail-anon-penet-p to))
5035         to nil)))
5036
5037 ;;; ----------------------------------------------------------------------
5038 ;;;
5039 (defun ti::mail-nymserver-email-convert (email &optional na-mode)
5040   "Convert penet EMAIL address.
5041
5042 If NA-MODE is nil: do 'an' conversion
5043         anXXX@example.com   --> anXXX
5044         naXXX@example.com   --> anXXX
5045        VANITY@example.com   --> VANITY@example.com
5046     VANITY.an@example.com   --> VANITY@example.com
5047     VANITY.na@example.com   --> VANITY@example.com
5048
5049 If NA-MODE is non-nil:
5050     Then do opposite 'na' conversion"
5051   (cond
5052    (na-mode
5053     (if (string-match "\\(an\\)[0-9]+@\\|\\.\\(an\\)@" email)
5054         (setq email (ti::replace-match 1 "na" email))
5055       ;; the email is VANITY@example.com
5056       (if (string-match "\\(.*\\)\\(@.*\\)" email)
5057           (setq email (concat
5058                        (match-string 1 email) ".na"
5059                        (match-string 2 email))))))
5060    (t
5061     (cond
5062      ((string-match "\\(na\\)[0-9]+@" email)
5063       (setq email (ti::replace-match 1 "an" email)))
5064      ((string-match "\\(\\.na\\)@" email)
5065       (setq email (ti::replace-match 1 "" email))))))
5066   email)
5067
5068 ;;}}}
5069 ;;{{{ mime
5070
5071 ;;; ............................................................ &mime ...
5072
5073 ;;; ----------------------------------------------------------------------
5074 ;;;
5075 (defsubst ti::mail-mime-tm-featurep-p  ()
5076   "TM. Check if MIME is loaded."
5077   (and (featurep 'mime-setup)
5078        (not (featurep 'semi-setup))))
5079
5080 ;;; ----------------------------------------------------------------------
5081 ;;;
5082 (defsubst ti::mail-mime-semi-featurep-p  ()
5083   "SEMI. Check if MIME is loaded."
5084   (featurep 'semi-setup))
5085
5086 ;;; ----------------------------------------------------------------------
5087 ;;;
5088 (defsubst ti::mail-mime-feature-p  ()
5089   "MIME. Check if TM/ or SEMI is available."
5090   (or (ti::mail-mime-tm-featurep-p)
5091       (ti::mail-mime-semi-featurep-p)))
5092
5093 ;;; ----------------------------------------------------------------------
5094 ;;;
5095 (defsubst ti::mail-mime-tm-edit-p ()
5096   "TM. Check if mime edit is active."
5097   (and (boundp 'mime/editor-mode-flag)
5098        (symbol-value 'mime/editor-mode-flag)))
5099
5100 ;;; ----------------------------------------------------------------------
5101 ;;;
5102 (defsubst ti::mail-mime-semi-edit-p ()
5103   "SEMI. Check if mime edit is active."
5104   (and (boundp 'mime-edit-mode-flag)
5105        (symbol-value 'mime-edit-mode-flag)))
5106
5107 ;;; ----------------------------------------------------------------------
5108 ;;;
5109 (put 'ti::mail-mime-tm-edit-mode-macro 'lisp-indent-function 0)
5110 (put 'ti::mail-mime-tm-edit-mode-macro 'edebug-form-spec '(body))
5111 (defmacro ti::mail-mime-tm-edit-mode-macro  (&rest body)
5112   "TM. Run body If mime edit mode is active in current buffer."
5113   (`
5114    (when (and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
5115      (,@ body))))
5116
5117 ;;; ----------------------------------------------------------------------
5118 ;;;
5119 (put 'ti::mail-mime-semi-edit-mode-macro 'lisp-indent-function 0)
5120 (put 'ti::mail-mime-semi-edit-mode-macro 'edebug-form-spec '(body))
5121 (defmacro ti::mail-mime-semi-edit-mode-macro  (&rest body)
5122   "SEMI. Run body If mime edit mode is active in current buffer."
5123   (`
5124    (when (and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
5125      (,@ body))))
5126
5127 ;;; ----------------------------------------------------------------------
5128 ;;;
5129 (put 'ti::mail-mime-funcall-0-macro 'lisp-indent-function 1)
5130 (put 'ti::mail-mime-funcall-0-macro 'edebug-form-spec '(body))
5131 (defmacro ti::mail-mime-funcall-0-macro (func-tm func-semi)
5132   "Call function  FUNC-TM or FUNC-SEMI with no arguments."
5133   (`
5134    (cond
5135     ((and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
5136      (ti::funcall (, func-tm))
5137      t)
5138     ((and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
5139      (ti::funcall (, func-semi))))))
5140
5141 ;;; ----------------------------------------------------------------------
5142 ;;;
5143 (put 'ti::mail-mime-funcall-2-macro 'lisp-indent-function 3)
5144 (put 'ti::mail-mime-funcall-2-macro 'edebug-form-spec '(body))
5145 (defmacro ti::mail-mime-funcall-2-macro (func-tm func-semi arg1 arg2)
5146   "Call function  FUNC-TM or FUNC-SEMI with ARG1 ARG2."
5147   (`
5148    (cond
5149     ((and (ti::mail-mime-tm-featurep-p) (ti::mail-mime-tm-edit-p))
5150      (ti::funcall (, func-tm) (, arg1) (, arg2))
5151      t)
5152     ((and (ti::mail-mime-semi-featurep-p) (ti::mail-mime-semi-edit-p))
5153      (ti::funcall (, func-semi) (, arg1) (, arg2))
5154      t))))
5155
5156 ;;; ----------------------------------------------------------------------
5157 ;;;
5158 (defun ti::mail-mime-turn-on-mode ()
5159   "Turn on MIME mode. Do nothing if mime is not available.
5160 Return t if mime was supported."
5161   (interactive)
5162   (cond
5163    ((ti::mail-mime-tm-featurep-p)
5164     (unless (ti::mail-mime-tm-edit-p)
5165       (ti::funcall 'mime/editor-mode))
5166     t)
5167    ((ti::mail-mime-semi-featurep-p)
5168     (unless (ti::mail-mime-semi-edit-p)
5169       (ti::funcall 'mime-edit-mode))
5170     t)))
5171
5172 ;;; ----------------------------------------------------------------------
5173 ;;;
5174 (defun ti::mail-mime-turn-off-mode ()
5175   "Turn off MIME mode. Do nothing if mime is not available.
5176 Return t if mime was supported."
5177   (interactive)
5178   (cond
5179    ((ti::mail-mime-tm-featurep-p)
5180     (when (ti::mail-mime-tm-edit-p)
5181       (ti::funcall 'mime-editor/exit))
5182     t)
5183    ((ti::mail-mime-semi-featurep-p)
5184     (when (ti::mail-mime-semi-edit-p)
5185       (ti::funcall 'mime-edit-exit))
5186     t)))
5187
5188 ;;; ----------------------------------------------------------------------
5189 ;;;
5190 (defun ti::mail-mime-sign-region (&optional beg end)
5191   "MIME. Enclose region BEG END as signed.
5192 Input:
5193
5194 BEG   Defaults to mail beginning or buffer beginning.
5195 END   Defualts to `point-max'
5196
5197 Return:
5198
5199 nil  if mime is not available.
5200 "
5201   (interactive)
5202   (ti::mail-set-region beg end)
5203   (ti::mail-mime-funcall-2-macro
5204    'mime-editor/enclose-signed-region
5205    'mime-edit-enclose-pgp-signed-region
5206    beg
5207    end))
5208
5209 ;;; ----------------------------------------------------------------------
5210 ;;;
5211 (defun ti::mail-mime-encrypt-region (&optional beg end)
5212   "MIME. Enclose region BEG END as encrypted
5213 Input:
5214
5215 BEG   Defaults to mail beginning or buffer beginning.
5216 END   Defualts to `point-max'
5217
5218 Return:
5219
5220 nil  if mime is not available.
5221 "
5222   (interactive)
5223   (ti::mail-set-region beg end)
5224   (ti::mail-mime-funcall-2-macro
5225    'mime-editor/enclose-encrypted-region
5226    'mime-edit-enclose-pgp-encrypted-region
5227    beg
5228    end))
5229
5230 ;;; ----------------------------------------------------------------------
5231 ;;;
5232 (put 'ti::mail-mime-tm-split-macro 'lisp-indent-function 0)
5233 (put 'ti::mail-mime-tm-split-macro 'edebug-form-spec '(body))
5234 (defmacro ti::mail-mime-tm-split-macro (&rest body)
5235   "TM. Define  variables `split'  `max' `parts' and run BODY if TM active.
5236 You have to use variables `max' and `parts' otherwise you don't need this macro."
5237   (`
5238    (when (boundp 'mime-editor/split-message)
5239      (let* ((split (symbol-value 'mime-editor/split-message))
5240             (max   (symbol-value 'mime-editor/message-default-max-lines))
5241             (lines (count-lines (point-min) (point-max)))
5242             (parts (1+ (/ lines max))))
5243        (if (null split)
5244            (setq split nil))            ; No-op Bytecomp silencer
5245        (,@ body)))))
5246
5247 ;;; ----------------------------------------------------------------------
5248 ;;;
5249 (defun ti::mail-mime-maybe-p ()
5250   "Check if buffer possibly contain MIME sections.
5251 if there is boundary string in header or if the TM -mime tags
5252 '-[[' are found from buffer, then it's considered mime."
5253   (or (ti::mail-mime-p)
5254       (save-excursion
5255         (cond
5256          ((featurep 'tm-edit)           ;TM.el
5257           ;;   TM puth these markes to MIME section; Try to find one.
5258           ;;   This can be only found if the mimi-edit mode is not
5259           ;;   yet exited. Upon exit the message will match true
5260           ;;   MIME (ti::mail-mime-p).
5261           (ti::re-search-check (concat "^" (regexp-quote "--[["))))))))
5262
5263 ;;; ----------------------------------------------------------------------
5264 ;;;
5265 (defun ti::mail-mime-p ()
5266   "Check if buffer has mime message. You probably want `ti::mail-mime-maybe-p'.
5267 It must contain boundary field in the headers and the boundary
5268 must be found from the message body itself.
5269 Only the header is not enough to say it's a composed mime mail.
5270
5271 Content-Type: ...
5272   boundary=\"Multipart_Thu_Sep_19_12:46:36_1996-1\"
5273            ^^^^^^^^^
5274
5275 This text must be found after the headers until the MIME criteria is
5276 satisfied."
5277   (interactive)
5278   (let ((field (ti::mail-get-field "Content-Type" 'any))
5279         re)
5280     (when (and field
5281                ;;  Content-Type field may not include "boundary"
5282                ;;  --> it's not multipart mime.
5283                (setq re (ti::string-match ".*boundary=.\\(.*\\)\"" 1 field)))
5284       (setq re (regexp-quote re))
5285       ;;   start finding the boundary text after the headers.
5286       (save-excursion
5287         (ti::pmin) (re-search-forward re) ;This is the header, ignore it
5288         (forward-line 1)
5289         (re-search-forward re nil t)))))
5290
5291 ;;; ----------------------------------------------------------------------
5292 ;;; #todo: not tested
5293 ;;;
5294 (defun ti::mail-mime-qp-decode(from to)
5295   "Mime. Decode quoted-printable from region between FROM and TO."
5296   (save-excursion
5297     (goto-char from)
5298     (while (search-forward "=" to t)
5299       (cond ((char= (following-char) ?\n)
5300              (delete-char -1)
5301              (delete-char 1))
5302             ((looking-at "[0-9A-F][0-9A-F]")
5303              (delete-char -1)
5304              (insert (hexl-hex-string-to-integer
5305                       (buffer-substring (point) (+ 2 (point)))))
5306              (delete-char 2))
5307             ((message "Malformed MIME quoted-printable message"))))))
5308
5309 ;;; ----------------------------------------------------------------------
5310 ;;; (add-hook 'vm-select-message-hook 'ti::mail-mime-prepare-qp)
5311 ;;;
5312 (defun ti::mail-qp-mime-prepare ()
5313   "Mime. Unquote quoted-printable from mail buffers.
5314 Searches for tag:
5315
5316 content-transfer-encoding: quoted-printable"
5317   (interactive)
5318   (save-excursion
5319     (let ((case-fold-search t)
5320           (type (mail-fetch-field "content-transfer-encoding"))
5321           buffer-read-only)
5322       (cond
5323        ((and (stringp type)
5324              (string-match "quoted-printable" type))
5325         (ti::pmin)
5326
5327         (search-forward "\n\n" nil 'move)
5328         (message  "MIME Unquoting printable...")
5329         (ti::mail-mime-qp-decode (point) (point-max))
5330         (message  "MIME Unquoting printable...done"))))))
5331
5332 ;;}}}
5333
5334 ;;{{{ Mail sending
5335
5336 ;;; .................................................... &mail-sending ...
5337
5338 ;;; ----------------------------------------------------------------------
5339 ;;;
5340 (defun ti::mail-plugged-p ()
5341   "Check if computer is on-line. This function relies on Gnus."
5342   (when (boundp 'gnus-plugged)
5343     (symbol-value 'gnus-plugged)))
5344
5345 ;;; ----------------------------------------------------------------------
5346 ;;;
5347 (defun ti::mail-sendmail-reset-send-hooks ()
5348   "Make `mail-send-hook' et al. buffer local and set to nil."
5349   (dolist (sym '(mail-send-hook
5350                  message-send-hook
5351                  mh-before-send-letter-hook))
5352     (when (boundp sym)
5353       (make-local-hook sym)
5354       (set sym nil))))
5355
5356 ;;; ----------------------------------------------------------------------
5357 ;;;
5358 (put 'ti::mail-sendmail-pure-env-macro 'lisp-indent-function 0)
5359 (put 'ti::mail-sendmail-pure-env-macro 'edebug-form-spec '(body))
5360 (defmacro ti::mail-sendmail-pure-env-macro (&rest body)
5361   "Reset all mail/message hooks/vars locally to nil and run BODY."
5362   (`
5363    (let* (message-setup-hook
5364           message-mode-hook
5365           mail-mode-hook
5366           mail-setup-hook
5367           mail-archive-file-name
5368           mail-default-headers
5369           mail-default-reply-to)
5370      ;; byteComp silencer: "Not used variables."
5371      (if mail-mode-hook         (setq mail-mode-hook            nil))
5372      (if mail-setup-hook        (setq mail-setup-hook           nil))
5373      (if mail-archive-file-name (setq mail-archive-file-name    nil))
5374      (if mail-default-headers   (setq mail-default-headers      nil))
5375      (if mail-default-reply-to  (setq mail-default-reply-to     nil))
5376      (,@ body))))
5377
5378 ;;; ----------------------------------------------------------------------
5379 ;;;
5380 (put 'ti::mail-sendmail-macro-1 'lisp-indent-function 3)
5381 (put 'ti::mail-sendmail-macro-1 'edebug-form-spec '(body))
5382 (defmacro ti::mail-sendmail-macro-1 (to subject send &rest body)
5383   "See `ti::mail-sendmail-macro' instead. This is low level function."
5384   (`
5385    (progn
5386      (ti::mail-sendmail-pure-env-macro
5387       ;;   to subject in-reply-to cc replybuffer actions
5388       ;;
5389       (mail-setup (, to) (, subject) nil nil nil nil)
5390       (mail-mode)
5391       (ti::mail-kill-field "^fcc")
5392       (ti::mail-text-start 'move)
5393       (,@ body)
5394       (ti::pmin)
5395       (ti::kill-buffer-safe " sendmail temp") ;See sendmail-send-it
5396       (when (, send)
5397         (mail-send-and-exit nil))))))
5398
5399 ;;; ----------------------------------------------------------------------
5400 ;;;
5401 (put 'ti::mail-sendmail-macro 'lisp-indent-function 3)
5402 (put 'ti::mail-sendmail-macro 'edebug-form-spec '(body))
5403 (defmacro ti::mail-sendmail-macro (to subject send &rest body)
5404   "Send / construct mail according to parameters.
5405 Use TO, SUBJECT and If SEND if non-nil, send mail after BODY finishes.
5406
5407 Point is at the beginning of body.
5408
5409 Note:
5410
5411     `mail-mode-hook' `mail-setup-hook' `mail-archive-file-name'
5412     `mail-default-headers'
5413
5414     are set to nil. If you need these, please copy them before calling this
5415     macro and restore their values in BODY, possibly calling
5416     and using them as sendmail normally would.
5417
5418     The hooks are set to nil so that mail buffer is created fast and
5419     that nothing causes trouble when mail buffer is ready."
5420   (`
5421    (let* ((BuffeR (ti::temp-buffer ti:mail-mail-buffer 'clear)))
5422      (save-window-excursion
5423        (with-current-buffer BuffeR
5424          (ti::mail-sendmail-macro-1
5425           (, to)
5426           (, subject)
5427           (, send)
5428           (,@ body)))))))
5429
5430 ;;}}}
5431
5432 ;;{{{ Abbrevs: XEmacs and Emacs
5433
5434 ;;; ......................................................... &abbrevs ...
5435
5436 ;;; ----------------------------------------------------------------------
5437 ;;;
5438 (defun ti::mail-abbrev-table  ()
5439   "XEmacs and Emacs Compatibility, Return mail abbrev hash table."
5440   (ti::package-require-mail-abbrevs)
5441   (cond
5442    ((ti::emacs-p)
5443
5444     (if mail-abbrevs
5445         (ti::funcall 'mail-abbrevs-setup))
5446
5447     (or mail-abbrevs
5448         (progn
5449           (build-mail-aliases)
5450           mail-abbrevs)
5451         mail-aliases))
5452    (t
5453     ;;  in Emacs this is a list, in XEmacs this is a HASH
5454     (or mail-aliases
5455         (progn
5456           (condition-case err
5457               (build-mail-aliases)
5458             (error
5459              ;;  See mail-abbrev.el
5460              (when (get-buffer "mailrc")
5461                (pop-to-buffer (get-buffer "mailrc")))
5462              (error err)))
5463           mail-aliases)))))
5464
5465 ;;; ----------------------------------------------------------------------
5466 ;;;
5467 (defun ti::mail-abbrev-expand-mail-aliases  (beg end &optional alias-alist)
5468   "Expand aliases in region BEG END.
5469 Please Cache results from `ti::mail-abbrev-get-alist' and
5470 use the result as argument ALIAS-ALIST. Otherwise aliases are always
5471 reuild from scratch."
5472   (interactive "*r")
5473   (let* (mb
5474          me
5475          word
5476          exp)
5477     (cond
5478      ((and (require 'mailalias nil 'noerr) ;Emacs Feature only
5479            (fboundp 'expand-mail-aliases))
5480       (ti::funcall 'expand-mail-aliases beg end))
5481
5482      (t                                 ;Too bad, this is much slower
5483       (unless alias-alist
5484         (setq alias-alist (ti::mail-abbrev-get-alist)))
5485
5486       (save-restriction
5487         (narrow-to-region beg end) (ti::pmin)
5488         (while (re-search-forward
5489                 "^[ \t]+\\|^[ \t]*[\n,][ \t]*\\|:[ \t]*" nil t)
5490           (when (setq word (ti::buffer-match"[^ \t,\n]+" 0))
5491
5492             (setq mb (match-beginning 0)
5493                   me (match-end 0))
5494
5495             ;;  Do not count field names, like  "CC:" words
5496             (when (and (not (string-match ":$" word))
5497                        ;;  Is this abbrev ?
5498                        (setq exp (assoc word alias-alist)))
5499               (setq exp (cdr exp))      ; Change alias to expansion
5500               (delete-region mb me)
5501               (insert exp)
5502
5503               ;;  This isn't very smart formatting, the layout
5504               ;;  is so that each expansion is on it's own line,
5505               ;;  no fancy lining up things -- Mail me back
5506               ;;  with diff to this code if you code nicer one.
5507
5508               (when (looking-at "[ \t]*,") ;put on separate lines
5509                 (goto-char (match-end 0))
5510                 (when (not (looking-at "[ \t]*$"))
5511                   (insert "\n\t")
5512                   (beginning-of-line)))))))))))
5513
5514 ;;; ----------------------------------------------------------------------
5515 ;;; See mailabbrev.el how to build your abbrevs.
5516 ;;;
5517 (defun ti::mail-abbrev-get-alist  (&optional expand-until)
5518   "Return alist of all `mail-abbrevs'.
5519 Build the abbrev table from your ~/.mailrc with command
5520 \\[build-mail-abbrevs]. The following parameter is _not_ yet functional.
5521
5522 Input:
5523   EXPAND-UNTIL        expand until the RH elt is pure email.
5524
5525 Return:
5526   '((ABBREV-STRING . EXPANDED-STRING) (A . E) ..)"
5527   (let* (
5528          (pre-abbrev-expand-hook        nil) ;; prevent recursion
5529          (mail-abbrev-aliases-need-to-be-resolved t)
5530          table
5531          exp-list
5532          elt)
5533
5534     ;; XEmacs 19.14 no-op for ByteCompiler
5535
5536     (unless mail-abbrev-aliases-need-to-be-resolved
5537       (setq mail-abbrev-aliases-need-to-be-resolved nil))
5538
5539     (setq table (ti::mail-abbrev-table))
5540
5541     (cond
5542      ((listp table) ;; mail-aliases is already in (A . S) form
5543       (setq exp-list table))
5544      (t                                 ;Vector
5545       ;;  We have to expand abbrevs by hand because XEmacs doesn't
5546       ;;  parse them like emacs mail-alias
5547
5548       (when table
5549         (let ((tmp (generate-new-buffer "*ti::mail-abbrev*")))
5550           (with-current-buffer tmp
5551             (setq local-abbrev-table table)
5552
5553             (mapatoms
5554              (function
5555               (lambda (x)
5556                 (setq elt (prin1-to-string (identity x)))
5557                 (when (not (string= "0" elt)) ;abbrev in this slot?
5558                   (insert elt)
5559                   (end-of-line)
5560
5561                   ;;  2000-09-03
5562                   ;;  BBDB does some voodoo with the abbrevs by
5563                   ;;  setting the function cell, and sometimes  calling
5564                   ;;  expand-abbrev by BBDB blessed abbrev gives error.
5565                   ;;  --> Don't bother with the error, since the
5566                   ;;  abbrevs is correctly expanded, but BBDB cries about
5567                   ;;  "wrong marker" or something.
5568
5569                   (condition-case err
5570                       (expand-abbrev)
5571                     (error
5572                      (message
5573                       (concat
5574                        "tinylibmail: `expand-abbrev' signalled ERROR `%s'"
5575                        " while expanding `%s'")
5576                       (prin1-to-string err)
5577                       elt)))
5578                   (push (cons (symbol-name x) (ti::read-current-line)) exp-list)
5579                   (end-of-line)
5580                   (insert "\n"))))
5581              table))
5582           (kill-buffer tmp))))) ;; cond
5583     exp-list))
5584
5585 ;;; ----------------------------------------------------------------------
5586 ;;;
5587 (defun ti::mail-mail-abbrevs-email-list  (&optional abbrev-alist)
5588   "Build email list of abbrevs; optionally use ABBREV-ALIST.
5589 Only entries in this format in ~/.mailrc are returned. There must be
5590 no \",\" chained lists in the line.
5591
5592   alias[spaces]some[spaces]user@address.xx
5593
5594 Input:
5595
5596   '((\"abbrev\" . \"expansion\") (A . E) ..)
5597
5598 Return:
5599
5600   '(email email ...)"
5601   (let* (str
5602          email
5603          list)
5604     (dolist (elt
5605              (or abbrev-alist (ti::mail-abbrev-get-alist)))
5606       (setq str (cdr elt))
5607       (when (null (string-match "," str)) ;filter out multiple mail lists
5608         (setq email (ti::string-match "\\([^< \t]+@[^> \t\n]+\\)" 0 str))
5609         (if email
5610             (push str list))))
5611     ;; retain order
5612     (nreverse list)))
5613
5614 ;;}}}
5615
5616 ;;{{{ provide
5617
5618 (provide   'tinylibmail)
5619 (run-hooks 'ti:mail-load-hook)
5620
5621 ;;}}}
5622
5623 ;;; tinylibmail.el ends here