cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-header.el

   1 ;;; mew-header.el --- Mail header stuff for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Oct  2, 1996
   5 ;; Revised: Aug 31, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-header-version "mew-header.el version 0.15")
  10
  11 (require 'mew)
  12
  13 (defvar mew-anonymous-recipients ":;")
  14
  15 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16 ;;;
  17 ;;; Header functions
  18 ;;;
  19
  20 (defmacro mew-header-goto-next ()
  21   '(while (looking-at mew-lwsp)
  22      (forward-line)))
  23
  24 ;; see also mew-header-end
  25 (defmacro mew-header-goto-end ()
  26   '(progn
  27      (goto-char (point-min))
  28      (if (re-search-forward mew-eoh nil t)
  29          (beginning-of-line)
  30        (goto-char (point-max))
  31        (if (eolp) (insert "\n")))))
  32
  33 (defmacro mew-header-goto-body ()
  34   '(progn
  35      (mew-header-goto-end)
  36      (forward-line)))
  37
  38 (defun mew-header-get-value (field)
  39   "currently, when no match, it returns nil."
  40   ;; maybe called in narrowed region.
  41   ;; we can't widen for citation.
  42   (let ((case-fold-search t)
  43         (regex (format "^%s[ \t]*" field))
  44         start match ret)
  45     (save-excursion
  46       (mew-header-goto-end)
  47       (save-restriction
  48         (narrow-to-region (point-min) (point))
  49         (goto-char (point-min))
  50         (catch 'only-one
  51           (while (re-search-forward regex nil t)
  52             (setq start (match-end 0))
  53             (forward-line)
  54             (mew-header-goto-next)
  55             (setq match (mew-buffer-substring start (1- (point))))
  56             (if (string= "" match)
  57                 ()
  58               (if ret
  59                   (setq ret (concat ret "," match))
  60                 (setq ret match)
  61                 (if (equal field mew-from:) (throw 'only-one nil))))))))
  62     ret))
  63
  64 (fset 'mew-header-existp (symbol-function 'mew-header-get-value))
  65
  66 (defun mew-make-field-regex (fields)
  67   (concat "^\\(" (mapconcat (function identity) fields "\\|") "\\)"))
  68
  69 (defun mew-header-delete-lines (fields)
  70   (if (null fields)
  71       ()
  72     (let ((case-fold-search t)
  73           (regex (mew-make-field-regex fields))
  74           start)
  75       (mew-header-goto-end)
  76       (save-restriction
  77         (narrow-to-region (point-min) (point))
  78         (goto-char (point-min))
  79         (while (re-search-forward regex nil t)
  80           (setq start (match-beginning 0))
  81           (forward-line)
  82           (mew-header-goto-next)
  83           (delete-region start (point)))))))
  84
  85 (defun mew-header-replace-lines (fields prefix)
  86   (if (null fields)
  87       ()
  88     (let ((case-fold-search t)
  89           (regex (mew-make-field-regex fields)))
  90       (mew-header-goto-end)
  91       (save-restriction
  92         (narrow-to-region (point-min) (point))
  93         (goto-char (point-min))
  94         (while (re-search-forward regex nil t)
  95           (beginning-of-line)
  96           (insert prefix)
  97           (forward-line))))))
  98
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100 ;;;
 101 ;;; Header insertion
 102 ;;;
 103
 104 (defun mew-draft-header-insert (field value)
 105   "No encoding. Just insert."
 106   (if (and value (stringp field))
 107       (insert field " " value "\n")))
 108
 109 (defmacro mew-draft-header-fill (field value)
 110   (` (if (not (mew-header-existp (, field)))
 111          (mew-draft-header-insert (, field) (, value)))))
 112
 113 (defun mew-header-insert (key value)
 114   (if (and value (stringp key))
 115       (let ((beg (point)) params med par parname parval)
 116         (if (listp value)
 117             (progn
 118               (setq params (cdr value))
 119               (setq value (car value))))
 120         (insert key)
 121         (insert " ")
 122         (setq med (point))
 123         (if (string-match "^[\t -~]*$" value)
 124             (insert value)
 125           (mew-header-encode-text value nil (length key)))
 126         (while params
 127           (setq par (car params))
 128           (setq parname (nth 0 par))
 129           (setq parval (nth 1 par))
 130           (setq params (cdr params))
 131           (insert ";")
 132           (cond
 133            ((string-match "^[-a-zA-Z0-9]+$" parval)
 134             ) ;; do nothing
 135            ((and (equal (mew-charset-guess-string parval) mew-us-ascii)
 136                  (not (string-match "\"" parval)))
 137             (setq parval (concat "\"" parval "\"")))
 138            (t
 139             (setq parval (mew-param-encode parval))
 140             (setq parname (concat parname "*"))))
 141           (insert " " parname "=" parval))
 142         (insert "\n")
 143         (mew-header-fold-region beg (point) med))))
 144
 145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146 ;;;
 147 ;;; Low-level functions to parse fields
 148 ;;;
 149
 150 ;;
 151 ;; The purpose of this function is to purse and extract value
 152 ;; of address or content header. text is not target!
 153 ;;
 154 ;; ADDRP is t if STR are addresses.
 155 ;; ADDRP is nil if STR is a value of content-*.
 156 ;;
 157 ;; 'Winnie (The) Pooh <"W. Pooh" (loves "honey") @ (somewhere in) England>'
 158 ;; ->
 159 ;; '"W. Pooh"@England'
 160 ;;
 161 ;; For 'destination', SEP is ",".
 162 ;; For Content-*, SEP is ";".
 163 ;;
 164 ;; The special (i.e. SEP) is one of delimiters.
 165 ;; 'linear-white-space' is another delimiter.
 166 ;; 'quoted-string', 'comment', and 'domain-literal' is self-delimiting.
 167 ;; But 'domain-literal' (e.g. [1.2.3.4]) is meaningless.
 168 ;; So, the delimiters consists of SEP, SP, TAB, CRLF, "(", ")", and <">.
 169 ;;
 170 ;; 'qtext' remains. (It will be removed by mew-param-decode.)
 171 ;; ## how about 'quoted-pair'?
 172 ;;
 173 ;; 'comment' must be symmetric. That is, it must have the exact number of
 174 ;; ")" against that of ")". The entire 'comment', even if nested, is
 175 ;; ignored.
 176 ;;
 177 ;; 'encoded-word' is meaningless.
 178 ;; (1) Remove 'comment' so 'encoded-word' in 'comment' is meaningless.
 179 ;; (2) 'phrase' of 'mailbox' will be ignored because 'addr-spec' in
 180 ;; 'route-addr' will be extracted. So, 'encoded-word' in 'phrase' is
 181 ;; meaningless.
 182
 183 (defmacro mew-addrstr-parse-syntax-list-check-depth ()
 184   '(progn
 185      (setq sep-cnt (1+ sep-cnt))
 186      (if (and (integerp mew-header-max-depth)
 187               (>= sep-cnt mew-header-max-depth))
 188          (progn
 189            (message "Too many values. Truncate values over mew-header-max-depth.")
 190            (ding)
 191            (sit-for 2)
 192            (throw 'max nil)))))
 193
 194 (defun mew-addrstr-parse-syntax-list (str sep addrp)
 195   (let* ((i 0) (len (length str))
 196          (par-cnt 0) (tmp-cnt 0) (sep-cnt 0)
 197          (tmp (make-string len ?x))
 198          c ret)
 199     (catch 'max
 200       (while (< i len)
 201         (setq c (aref str i))
 202         (cond
 203          ((char-equal c ?\")
 204           (aset tmp tmp-cnt c)
 205           (setq tmp-cnt (1+ tmp-cnt))
 206           (setq i (1+ i))
 207           (catch 'quote
 208             (while (< i len)
 209               (setq c (aref str i))
 210               (cond
 211                ((char-equal c ?\")
 212                 (aset tmp tmp-cnt c)
 213                 (setq tmp-cnt (1+ tmp-cnt))
 214                 (throw 'quote nil))
 215                ((char-equal c ?\n)
 216                 (setq i (1+ i))
 217                 (catch 'fold-quote
 218                   (while (< i len)
 219                     (setq c (aref str i))
 220                     (cond
 221                      ((or (char-equal c ?\t) (char-equal c 32))
 222                       (setq i (1+ i)))
 223                      ((char-equal c ?\")
 224                       (aset tmp tmp-cnt c)
 225                       (setq tmp-cnt (1+ tmp-cnt))
 226                       (throw 'quote nil))
 227                      (t
 228                       (aset tmp tmp-cnt c)
 229                       (setq tmp-cnt (1+ tmp-cnt))
 230                       (throw 'fold-quote nil))))))
 231                (t
 232                 (aset tmp tmp-cnt c)
 233                 (setq tmp-cnt (1+ tmp-cnt))))
 234               (setq i (1+ i)))))
 235          ((char-equal c ?\()
 236           (setq par-cnt 1)
 237           (setq i (1+ i))
 238           (catch 'comment
 239             (while (< i len)
 240               (setq c (aref str i))
 241               (cond
 242                ((char-equal c ?\()
 243                 (setq par-cnt (1+ par-cnt)))
 244                ((char-equal c ?\))
 245                 (setq par-cnt (1- par-cnt))
 246                 (if (equal par-cnt 0) (throw 'comment nil))))
 247               (setq i (1+ i)))))
 248          ((char-equal c ?<)
 249           (cond
 250            (addrp
 251             (let (rbeg rend)
 252               (setq i (1+ i))
 253               (setq rbeg i)
 254               (while (and (< i len) (not (char-equal (aref str i) ?>)))
 255                 (setq i (1+ i)))
 256               (setq rend i);; note: to be used for substring, so not 1-.
 257               ;; should not be nested but easy to implement...
 258               (setq ret (cons (car (mew-addrstr-parse-syntax-list
 259                                     (substring str rbeg rend) sep t))
 260                               ret)))
 261             (while (and (< i len) (not (char-equal (aref str i) sep)))
 262               (setq i (1+ i)))
 263             (setq tmp-cnt 0)
 264             (mew-addrstr-parse-syntax-list-check-depth))
 265            (t
 266             ;; just ignore
 267             (while (and (< i len) (not (char-equal (aref str i) ?>)))
 268               (setq i (1+ i))))))
 269          ((char-equal c ?\n))
 270          ((char-equal c ?\t))
 271          ((char-equal c 32))
 272          ((char-equal c sep)
 273           (if (> tmp-cnt 0)
 274               (setq ret (cons (substring tmp 0 tmp-cnt) ret)))
 275           (setq tmp-cnt 0)
 276           (mew-addrstr-parse-syntax-list-check-depth))
 277          (t
 278           (aset tmp tmp-cnt c)
 279           (setq tmp-cnt (1+ tmp-cnt)))
 280          )
 281         (setq i (1+ i))))
 282     (if (> tmp-cnt 0)
 283         (setq ret (cons (substring tmp 0 tmp-cnt) ret)))
 284     (nreverse ret)))
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;;;
 288 ;;; High-level functions to parse fields
 289 ;;;
 290
 291 (defmacro mew-addrstr-parse-value (value)
 292   (` (car (mew-addrstr-parse-value-list (, value)))))
 293
 294 (defmacro mew-addrstr-parse-value-list (value)
 295   (` (mew-addrstr-parse-syntax-list (, value) ?\; nil)))
 296
 297 (defmacro mew-addrstr-parse-value2 (value)
 298   (` (car (mew-addrstr-parse-value-list2 (, value)))))
 299
 300 (defmacro mew-addrstr-parse-value-list2 (value)
 301   (` (mew-addrstr-parse-syntax-list (, value) ?, nil)))
 302
 303 ;;
 304
 305 (defmacro mew-addrstr-parse-address (address)
 306   (` (car (mew-addrstr-parse-address-list (, address)))))
 307
 308 (defmacro mew-addrstr-parse-address-list (address)
 309   (` (mew-addrstr-parse-syntax-list (, address) ?, t)))
 310
 311 (defmacro mew-header-parse-address (field)
 312   (` (car (mew-header-parse-address-list (list (, field))))))
 313
 314 (defmacro mew-header-parse-address-list (field-list)
 315   (` (mew-addrstr-parse-syntax-list
 316       (mapconcat (function mew-header-get-value) (, field-list) ",")
 317       ?, t)))
 318
 319 (defun mew-header-parse-address-list2 (field-list)
 320   "Collect addresses from FIELD-LIST.
 321 Remove anonymous addresses."
 322   (let ((vals (mew-addrstr-parse-syntax-list
 323                (mapconcat (function mew-header-get-value) field-list ",")
 324                ?, t))
 325         ret)
 326     (while vals
 327       (if (not (string-match mew-anonymous-recipients (car vals)))
 328           (setq ret (cons (car vals) ret)))
 329       (setq vals (cdr vals)))
 330     (nreverse ret)))
 331
 332 ;;
 333
 334 (defmacro mew-addrstr-extract-user-list (addr-list)
 335   (` (mapcar (function mew-addrstr-extract-user) (, addr-list))))
 336
 337 (defun mew-addrstr-extract-user (addr)
 338   "Extracts username from ADDR"
 339   (if (string-match "@.*:" addr) ;; xxx what's this?
 340       (setq addr (substring addr (match-end 0) nil))
 341     (setq addr (mew-replace-character addr 32 ?_))
 342     (setq addr (substring addr 0 (string-match "%" addr)))
 343     (setq addr (substring addr 0 (string-match "@" addr)))
 344     ;; just for refile:  "To: recipients:;" -> recipients
 345     (setq addr (substring addr 0 (string-match mew-anonymous-recipients addr)))
 346     ;; removing Notes domain
 347     (setq addr (substring addr 0 (string-match "/" addr)))))
 348
 349 ;;
 350
 351 (defun mew-addrstr-append-domain (addr)
 352   (if mew-addrbook-append-domain-p
 353       (if (string-match "@" addr)
 354           addr
 355         (concat addr "@" mew-mail-domain))
 356     addr))
 357
 358 (defun mew-addrstr-expand-alias (alias)
 359   (if (and mew-addrbook-unexpand-regex
 360            (string-match mew-addrbook-unexpand-regex alias))
 361       (list alias) ;; not expand
 362     (let ((addrs (mew-alias-get alias)))
 363       (setq addrs (mapcar (function mew-chop) (mew-split addrs ?,)))
 364       (setq addrs (delete "" addrs))
 365       (mapcar (function mew-addrstr-append-domain) addrs))))
 366
 367 (defun mew-addrstr-canonicalize-address (addr-str)
 368   "Expand aliases for each addresses in ADDR-STR.
 369 Then prepend mew-mail-domain if a domain part doesn't exist."
 370   (let ((addrs (mapcar (function mew-chop) (mew-split addr-str ?,)))
 371         addr ret)
 372     (while addrs
 373       (setq addr (car addrs))
 374       (setq addrs (cdr addrs))
 375       (setq ret (nconc ret (mew-addrstr-expand-alias addr))))
 376     ret))
 377
 378 (provide 'mew-header)
 379
 380 ;;; Copyright Notice:
 381
 382 ;; Copyright (C) 1996, 1997, 1998, 1999 Mew developing team.
 383 ;; All rights reserved.
 384
 385 ;; Redistribution and use in source and binary forms, with or without
 386 ;; modification, are permitted provided that the following conditions
 387 ;; are met:
 388 ;;
 389 ;; 1. Redistributions of source code must retain the above copyright
 390 ;;    notice, this list of conditions and the following disclaimer.
 391 ;; 2. Redistributions in binary form must reproduce the above copyright
 392 ;;    notice, this list of conditions and the following disclaimer in the
 393 ;;    documentation and/or other materials provided with the distribution.
 394 ;; 3. Neither the name of the team nor the names of its contributors
 395 ;;    may be used to endorse or promote products derived from this software
 396 ;;    without specific prior written permission.
 397 ;;
 398 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 399 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 400 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 401 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 402 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 403 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 404 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 405 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 406 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 407 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 408 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 409
 410 ;;; mew-header.el ends here