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

   1 ;;; mew-decode.el --- MIME syntax decoder 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-decode-version "mew-decode.el version 0.26")
  10
  11 (require 'mew)
  12
  13 (defvar mew-prog-mime-decode-switch
  14   (list (cons mew-b64 '("-b"))
  15         (cons mew-qp  '("-q"))
  16         (cons mew-xg  '("-g"))))
  17
  18 (defvar mew-prog-mime-decode-text-switch
  19   (list (cons mew-b64 '("-b" "-t"))
  20         (cons mew-qp  '("-q"))
  21         (cons mew-xg  '("-g" "-t"))))
  22
  23 (defvar mew-decode-multipart-encrypted-switch
  24   '(("application/pgp-encrypted" mew-pgp-decrypt mew-pgp-ver mew-prog-pgp)))
  25
  26 (defvar mew-decode-multipart-signed-switch
  27   '(("application/pgp-signature" mew-pgp-verify mew-pgp-ver mew-prog-pgp)))
  28
  29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30 ;;
  31 ;; MIME decoder
  32 ;;
  33
  34 (defmacro mew-decode-error (error-msg)
  35   (` (progn (setq mew-decode-error (, error-msg)) (error ""))))
  36
  37 (defmacro mew-decode-narrow-to-header (&rest body)
  38   (` (progn
  39        (if (re-search-forward mew-eoh nil t)
  40            (beginning-of-line)
  41          (goto-char (point-max))
  42          (insert "\n"))
  43        (if (and (integerp mew-header-max-length)
  44                 (> (count-lines (point-min) (point)) mew-header-max-length))
  45            (mew-decode-error
  46             (substitute-command-keys
  47              "Too long header. To see the message, type '\\<mew-summary-mode-map>\\[mew-summary-display-command]'")))
  48        (save-restriction
  49          (narrow-to-region (point-min) (point))
  50          (goto-char (point-min))
  51          (,@ body)))))
  52
  53 (defun mew-header-arrange (beg end)
  54   (save-restriction
  55     (narrow-to-region beg end)
  56     (mew-elet
  57      (let (ch-beg ch-end vs-beg vs-end contents cbeg)
  58        (setq ch-beg (next-single-property-change (point-min) 'mew-noncontents))
  59        (if (null ch-beg)
  60            ()
  61          (setq vs-beg (next-single-property-change (point-min) 'mew-visible))
  62          (if vs-beg
  63              (setq vs-end (next-single-property-change vs-beg 'mew-visible))
  64            (if mew-field-other-visible
  65                (progn
  66                  (setq vs-beg (next-single-property-change (point-min)
  67                                                            'mew-others))
  68                  (if vs-beg
  69                      (setq vs-end (next-single-property-change vs-beg
  70                                                                'mew-others))
  71                    (setq vs-beg ch-beg)
  72                    (setq vs-end ch-beg)))
  73              (setq vs-beg ch-beg)
  74              (setq vs-end ch-beg)))
  75          (setq ch-end (point-max))
  76          (if (null vs-end) (setq vs-end (point-max)))
  77          (mew-decode-header-property-region ch-beg ch-end)
  78          (setq contents (buffer-substring ch-beg ch-end))
  79          (delete-region ch-beg ch-end)
  80          (if (nth 1 (mew-assoc-match2 "Content-" mew-field-spec 0))
  81              (progn
  82                ;; visible
  83                (goto-char vs-end)
  84                (setq cbeg (point))
  85                (insert contents)
  86                (put-text-property cbeg (point) 'mew-visible t)) ;; used later
  87            ;; invisible
  88            (goto-char vs-beg)
  89            (setq cbeg (point))
  90            (insert contents)
  91            (put-text-property cbeg (point) 'mew-visible nil)) ;; for XEmacs
  92          (goto-char (point-max)))
  93        (mew-decode-syntax-insert-privacy)
  94        (goto-char (if (get-text-property (point-min) 'mew-visible)
  95                       (point-min)
  96                     (or (next-single-property-change (point-min) 'mew-visible)
  97                         (point-max))))
  98        (recenter 0)
  99        (save-excursion (mew-highlight-x-face (point-min) (point-max))))))
 100   (mew-header-goto-end)
 101   (if (eobp)
 102       (mew-header-set "\n") ;; analyzed
 103     (mew-header-set nil))) ;; asis
 104
 105 (defun mew-decode-header-property-region (BEG END)
 106   ;; see also mew-highlight-header
 107   (if (and (or window-system mew-xemacs-p) mew-use-highlight-header)
 108       (mew-elet
 109        (let ((defkey (intern-soft "mew-highlight-header-face-key"))
 110              (defval (intern-soft "mew-highlight-header-face-marginal"))
 111              key beg med N-spec key-face val-face)
 112          (save-restriction
 113            (narrow-to-region BEG END)
 114            (goto-char (point-min))
 115            (while (not (eobp))
 116              (if (not (looking-at mew-keyval))
 117                  (forward-line)
 118                (setq key (mew-match 1))
 119                (setq beg (match-beginning 0))
 120                (setq med (match-end 0))
 121                (forward-line)
 122                (mew-header-goto-next)
 123                (setq N-spec (mew-assoc-match3 key mew-field-spec 0))
 124                (setq key-face (or (nth 3 N-spec) defkey))
 125                (setq val-face (or (nth 4 N-spec) defval))
 126                (put-text-property beg med 'face key-face)
 127                (put-text-property med (point) 'face val-face))))))))
 128
 129 (defun mew-decode-rfc822-header (&optional no-property)
 130   "A function to handle RFC822 header.
 131 Called on the beginning of the header in the narrowed region.
 132  - Decode and highlight RFC822 fields excluding MIME fields.
 133  - Delete X-Mew: fields.
 134  - Arrange decoded-RFC822-fields, mew-mv:, MIME fields in order.
 135 The cursor moves between mew-mv: and MIME fields.
 136 Return the existence MIME-Version: and the value of Subject:."
 137   (setq no-property (or no-property
 138                         (not (and (or window-system mew-xemacs-p)
 139                                   mew-use-highlight-header))))
 140   (let* ((case-fold-search t)
 141          (visibles (make-list (length mew-field-spec) nil))
 142          (defkey (intern-soft "mew-highlight-header-face-key"))
 143          (defval (intern-soft "mew-highlight-header-face-marginal"))
 144          key beg med subj from contents others
 145          key-face val-face N N-spec visiblep mimep)
 146     (mew-decode-narrow-to-header
 147      (while (not (eobp))
 148        (if (not (looking-at mew-keyval))
 149            (forward-line)
 150          (setq key (capitalize (mew-match 1)))
 151          (setq beg (match-beginning 0))
 152          (setq med (match-end 0))
 153          (forward-line)
 154          (mew-header-goto-next)
 155          (setq N-spec (mew-assoc-match3 key mew-field-spec 0))
 156          (setq N (nth 0 N-spec))
 157          (setq visiblep (nth 2 N-spec))
 158          (cond
 159           ((mew-case-equal key mew-x-mew:)
 160            ;; deleting X-Mew: on the RFC822 header
 161            (delete-region beg (point)))
 162           ((string-match "^Content-" key)
 163            ;; Due to PGP/MIME, properties are not put here.
 164            (setq contents (cons (buffer-substring beg (point)) contents))
 165            (delete-region beg (point)))
 166           (t
 167            (mew-header-decode-region
 168             (mew-field-type-for-decoding key) med (point))
 169            (cond
 170             ((mew-case-equal key mew-from:)
 171              (setq from (mew-addrstr-parse-address
 172                          (buffer-substring med (1- (point))))))
 173             ((mew-case-equal key mew-subj:)
 174              (setq subj (buffer-substring med (1- (point)))))
 175             ((mew-case-equal key mew-mv:)
 176              ;; MIME-Version:
 177              (setq mimep (string-match
 178                           mew-mv:-num
 179                           (mew-addrstr-parse-value
 180                            (buffer-substring med (point)))))))
 181            (if no-property
 182                ()
 183              (setq key-face (or (nth 3 N-spec) defkey))
 184              (setq val-face (or (nth 4 N-spec) defval))
 185              (put-text-property beg med 'face key-face)
 186              (put-text-property med (point) 'face val-face))
 187            (cond
 188             ((null N-spec) ;; others
 189              (setq others (cons (buffer-substring beg (point)) others))
 190              (delete-region beg (point)))
 191             (visiblep
 192              (setcar (nthcdr N visibles)
 193                      (concat (nth N visibles)
 194                              (buffer-substring beg (point))))
 195              (delete-region beg (point)))
 196             (t ;; invisible
 197              ())))))))
 198     (put-text-property (point-min) (point) 'mew-invisible t)
 199     (put-text-property (point-min) (point) 'mew-noncontents t)
 200     (if mew-field-other-visible
 201         ()
 202       (setq beg (point))
 203       (mapcar (function insert) (nreverse others))
 204       (put-text-property beg (point) 'mew-others t)
 205       (put-text-property beg (point) 'mew-noncontents t))
 206     (setq beg (point))
 207     (mapcar (function (lambda (x) (and (stringp x) (insert x)))) visibles)
 208     ;; for recenter in Message mode
 209     (put-text-property beg (point) 'mew-visible t)
 210     (put-text-property beg (point) 'mew-noncontents t)
 211     (if mew-field-other-visible
 212         (progn
 213           (setq beg (point))
 214           (mapcar (function insert) (nreverse others))
 215           (put-text-property beg (point) 'mew-others t)
 216           (put-text-property beg (point) 'mew-noncontents t)))
 217     ;; the beginning of the content header
 218     (save-excursion (mapcar (function insert) (nreverse contents)))
 219     ;; 'mew-contents doesn't work due to PGP/MIME
 220     (list mimep subj from)))
 221
 222 (defun mew-decode-mime-header (&optional dct)
 223   "A function to handle content header.
 224 Called on the beginning of the content header in the narrowed region
 225 Return a part syntax after moving the beginning of the content body."
 226   (let ((case-fold-search t)
 227         (vec (make-vector (length mew-mime-fields) nil))
 228         key med attr n act value syntax)
 229     (mew-decode-narrow-to-header
 230      (while (not (eobp))
 231        (if (not (looking-at mew-keyval))
 232            (forward-line)
 233          (setq key (capitalize (mew-match 1)))
 234          (setq med (match-end 0))
 235          (forward-line)
 236          (mew-header-goto-next)
 237          (setq attr (assoc key mew-mime-fields))
 238          (if (not attr)
 239              ()
 240            (setq n (nth 1 attr))
 241            (setq act (nth 2 attr))
 242            (cond
 243             ((eq act 'analyze)
 244              (setq value (mew-param-decode
 245                           (buffer-substring med (1- (point))))))
 246             ((eq act 'extract)
 247              (setq value (mew-addrstr-parse-value
 248                           (buffer-substring med (1- (point))))))
 249             ((eq act 'decode)
 250              (if mew-decode-DECODE
 251                  (mew-header-decode-region 'text med (point) t))
 252              ;; mew-header-decode-region goes to the max point in
 253              ;; the narrowed region. So, this must be (point).
 254              (setq value (buffer-substring med (1- (point))))))
 255            (aset vec n value)))))
 256     (if (eobp)
 257         (insert "\n")
 258       (forward-line))
 259     ;; the beginning of the content body
 260     (setq syntax (vconcat (list 'single (point) nil nil) vec))
 261     (or (mew-syntax-get-ct syntax)
 262         (mew-syntax-set-ct syntax (or dct mew-type-txt)))
 263     syntax))
 264
 265 (defun mew-decode-mime-body (ctl cte &optional tocs)
 266   ;; ((point), (point-max)) (not point-min)
 267   ;; If tocs is t, don't decode fromcs, don't encode tocs, no post-conv
 268   (let* ((ct (mew-syntax-get-value ctl 'cap))
 269          (textp (string-match "^Text/" ct))
 270          (linebasep (or textp (mew-ct-linebasep ct)))
 271          (switch (if linebasep
 272                      mew-prog-mime-decode-text-switch
 273                    mew-prog-mime-decode-switch))
 274          (beg (point))
 275          opt file charset post-conv fromcs)
 276     (if (or (null cte) (mew-member-case-equal cte mew-decode-composite-value))
 277         ()
 278       (cond
 279        ((and (mew-case-equal cte mew-b64)
 280              (fboundp 'base64-decode-region))
 281         (base64-decode-region beg (point-max))
 282         (if linebasep
 283             (progn
 284               (goto-char beg)
 285               (while (search-forward "\r\n" nil t) (replace-match "\n")))))
 286        ((mew-which mew-prog-mime-decode exec-path)
 287         (setq opt (cdr (mew-assoc-case-equal cte switch 0)))
 288         (if (null opt)
 289             ;; Treated as Application/Octet-Stream.
 290             ;; Never reach here when decoding.
 291             (mew-decode-error (concat "Unknown CTE: " cte))
 292           (setq file (mew-make-temp-name))
 293           (mew-frwlet
 294            mew-cs-dummy mew-cs-text-for-write
 295            ;; NEVER use call-process-region for privacy reasons
 296            (write-region beg (point-max) file nil 'no-msg))
 297           (delete-region beg (point-max))
 298           (mew-piolet
 299            mew-cs-binary mew-cs-dummy
 300            ;; mew-prog-mime-decode converts CRLF to LF, so
 301            ;; read input as binary.
 302            (apply (function call-process) mew-prog-mime-decode
 303                   file t nil opt))
 304           (if (file-exists-p file) (delete-file file))))
 305        (t
 306         (mew-decode-error (concat mew-prog-mime-decode " doesn't exist")))))
 307     ;; charset conversion
 308     (if (and textp
 309              (not (eq tocs t))
 310              (setq charset (mew-syntax-get-param ctl "charset")))
 311         (progn
 312           (setq fromcs (mew-charset-to-cs charset))
 313           (mew-cs-decode-region beg (point-max) fromcs)
 314           (cond
 315            (tocs
 316             (mew-cs-encode-region beg (point-max) tocs))
 317            ((setq post-conv (mew-cs-post-conv fromcs))
 318             (let ((mc-flag t))
 319               (funcall post-conv beg (point-max)))))))
 320     linebasep))
 321
 322 ;;
 323 ;; Kick start function
 324 ;;
 325
 326 (defvar mew-decode-LIMIT  nil)
 327 (defvar mew-decode-DECODE t)
 328
 329 (defun mew-decode (fld msg)
 330   ;; in cache buffer
 331   (mew-erase-buffer)
 332   (goto-char (point-min))
 333   (setq mew-decode-error nil)
 334   (setq mew-decode-not-decrypted nil)
 335   (mew-decode-syntax-clear)
 336   (mew-insert-message fld msg mew-cs-text-for-read nil)
 337   ;; afer reading the file
 338   (if mew-mule-p
 339       (cond
 340        ((boundp 'mc-flag)
 341         (setq mc-flag nil)) ;; for re-search-forward
 342        ((fboundp 'set-buffer-multibyte)
 343         (set-buffer-multibyte t))))
 344   ;; Illegal messages may not have end-of-header.
 345   ;; Truncated messages may not have end-of-header.
 346   (if (re-search-forward mew-eoh nil t)
 347       ()
 348     (setq mew-decode-error "No end-of-header(null line) in the top level")
 349     (goto-char (point-max))
 350     (if (not (bolp)) (insert "\n"))
 351     (insert "\n"))
 352   (goto-char (point-min))
 353   (setq mew-decode-LIMIT nil)
 354   (setq mew-decode-DECODE t)
 355   (if mew-debug
 356       (let ((debug-on-error t))
 357         (setq mew-decode-syntax
 358               (mew-decode-message (mew-decode-syntax-rfc822-head) 0))
 359         (mew-decode-syntax-set))
 360     (condition-case nil
 361         (progn
 362           (setq mew-decode-syntax
 363                 (mew-decode-message
 364                  ;; Call internalform with VIRTUAL content header
 365                  ;;     CT: message/rfc822 (virtual)
 366                  ;;
 367                  ;;     Header(RFC822 header + content header)
 368                  ;;
 369                  ;;     Body(content body)
 370                  (mew-decode-syntax-rfc822-head) 0))
 371           (mew-decode-syntax-set))
 372       (error
 373        (widen)
 374        (mew-header-goto-body)
 375        ;; min, point - 1, point, point-max
 376        (setq mew-decode-syntax (mew-decode-syntax-rfc822))))))
 377
 378
 379 ;;
 380 ;; the function "m":: for message
 381 ;;
 382
 383 (defun mew-decode-message (syntax cnt)
 384   ;; Called on the beginning of the RFC822 header in the narrowed region
 385   ;; hbeg is certainly the beginning of the VIRTUAL content body(i.e. min).
 386   ;; hend will have to set to the end of PHYSICAL content header(i.e. end)
 387   ;; after analyzing the physical content header and body since CD:'s
 388   ;; length in the physical content header will change(no need to say
 389   ;; about the end of the physical content header).
 390   ;;
 391   ;;     Content-Type: Message/Rfc822    == virtual content header
 392   ;;
 393   ;;(min)Decoded RFC822 fields           == virtual content body
 394   ;;     MIME-Version: 1.0
 395   ;;(cur)MIME fields                     == physical content header
 396   ;;(end)
 397   ;;     Content-Body                    == physical content body
 398   ;;(max)
 399   (let* (msf mimep subj mew-inherit-from part)
 400     (if (and mew-decode-LIMIT (>= cnt mew-decode-LIMIT))
 401         ;; don't recurse anyway. don't decode the header
 402         (setq mimep nil)
 403       ;; even if mew-decode-DECODE is nil, we can and must
 404       ;; decode the header here.
 405       (setq msf (mew-decode-rfc822-header)) ;; on the physical
 406       (setq mimep (nth 0 msf))
 407       (setq subj (nth 1 msf))
 408       (setq mew-inherit-from (nth 2 msf)))
 409     (setq cnt (1+ cnt))
 410     ;; the beginning of the physical content header (cur)
 411     (cond
 412      (mimep ;; MIME
 413       (save-restriction
 414         (narrow-to-region (point) (point-max))
 415         (setq part (mew-decode-singlepart cnt nil 'message))
 416         ;; hend is always 1 char smaller than the beginning of
 417         ;; the physical content body
 418         (mew-syntax-set-key syntax 'message)
 419         (mew-syntax-set-end syntax (1- (mew-syntax-get-begin part)))
 420         (or (mew-syntax-get-cd syntax) (mew-syntax-set-cd syntax subj))
 421         (mew-syntax-cat syntax part))) ;; return value
 422      (t ;; RFC822
 423       ;; the beginning of the meaningless physical content header
 424       (if (re-search-forward mew-eoh nil t)
 425           (forward-line)
 426         (mew-decode-error "No end-of-header(null line) in RFC822 message"))
 427       ;; the beginning of the BODY(i.e. the physical content body)
 428       (if mew-decode-DECODE
 429           (mew-cs-decode-region (point) (point-max) mew-cs-rfc822-trans))
 430       (mew-syntax-set-key syntax 'message)
 431       (mew-syntax-set-end syntax (1- (point)))
 432       (or (mew-syntax-get-cd syntax) (mew-syntax-set-cd syntax subj))
 433       (mew-decode-syntax-rfc822 syntax)
 434       ;; (point-min), (point) - 1, (point), (point-max)
 435       ))))
 436
 437 ;;
 438 ;; the function "S":: for singlepart
 439 ;;
 440
 441 (defun mew-decode-singlepart (cnt &optional dct parent)
 442   ;; Called on the beginning of the content header in the narrowed region
 443   (let* ((case-fold-search t) (begin (point))
 444          (syntax (mew-decode-mime-header dct))
 445          (ctl (mew-syntax-get-ct syntax))
 446          (ct (mew-syntax-get-value ctl 'cap))
 447          (cte (or (mew-syntax-get-cte syntax) mew-7bit))
 448          (encap nil))
 449     ;; the beginning of the content body
 450     (cond
 451      ((not (mew-member-case-equal cte mew-decode-value))
 452       (mew-syntax-set-ct syntax mew-type-apo))
 453      ((string-match "^Message/" ct)
 454       (if (not (mew-member-case-equal cte mew-decode-composite-value))
 455           (mew-syntax-set-ct syntax mew-type-apo)
 456         (cond
 457          ((mew-case-equal mew-ct-msg ct)
 458           (if (equal parent 'message) (setq encap t))
 459           (save-restriction
 460             (narrow-to-region (point) (point-max))
 461             (setq syntax (mew-decode-message syntax cnt))))
 462          ((mew-case-equal mew-ct-ext ct)
 463           (let* ((at (mew-syntax-get-param ctl "access-type"))
 464                  (func (cdr (mew-assoc-case-equal at mew-ext-include-switch 0))))
 465             (if (not (and func (fboundp func)))
 466                 ()
 467               (save-excursion
 468                 (goto-char (point-max)) ;; phantom body
 469                 (funcall func ctl))
 470               (delete-region begin (point))
 471               (setq syntax (mew-decode-singlepart cnt)))))
 472          ((mew-case-equal mew-ct-sts ct)
 473           ;; do nothing
 474           )
 475          (t
 476           ;; xxx how about message/partinal?
 477           (mew-syntax-set-ct syntax mew-type-apo)
 478           ))))
 479      ;; Multipart, decoding is not required
 480      ((string-match "^Multipart/" ct)
 481       (if (not (mew-member-case-equal cte mew-decode-composite-value))
 482           (mew-syntax-set-ct syntax mew-type-apo)
 483         (cond
 484          ((mew-case-equal mew-ct-mld ct)
 485           ;; semantics into digest
 486           (setq syntax (mew-decode-multipart syntax cnt mew-type-msg)))
 487          ((mew-case-equal mew-ct-mls ct)
 488           (setq syntax (mew-decode-multipart-signed syntax cnt)))
 489          ((mew-case-equal mew-ct-mle ct)
 490           (if (boundp 'mew-inherit-prefetching) ;; xxx
 491               (signal 'quit "")
 492             (setq syntax (mew-decode-multipart-encrypted syntax cnt))))
 493          (t
 494           (setq syntax (mew-decode-multipart syntax cnt nil))))))
 495      ;; Others
 496      (t
 497       (if (and (equal parent 'message) (not (mew-case-equal mew-ct-txt ct)))
 498           (setq encap t))
 499       ;; even if cte is nil, call mew-decode-mime-body for charset conversion
 500       (if mew-decode-DECODE (mew-decode-mime-body ctl cte))))
 501     ;; ct may be changed to apo
 502     (if (not (mew-case-equal mew-ct-msg (car (mew-syntax-get-ct syntax))))
 503         (mew-syntax-set-end syntax (point-max)))
 504     (if encap
 505         ;; Mew allows text/plain and multipart/* for body.
 506         ;; If other CT: is embedded under message, it should be
 507         ;; encapsulated in multipart/mixed.
 508         (let ((head mew-encode-syntax-multi-head))
 509           ;; begin for multipart syntax is important because
 510           ;; the begin will be used by the parent to set hend
 511           (mew-syntax-set-begin head (mew-syntax-get-begin syntax))
 512           (mew-syntax-set-end head (point-max))
 513           (mew-syntax-cat head syntax)) ;; return value
 514       syntax))) ;; return value
 515
 516 ;;
 517 ;; the function "M":: for multipart
 518 ;;
 519
 520 (defun mew-decode-multipart (syntax cnt &optional dct)
 521   (let* ((case-fold-search nil) ;; boundary is case sensitive
 522          (ctl (mew-syntax-get-ct syntax))
 523          (ct (mew-syntax-get-value ctl 'cap))
 524          (boundary (regexp-quote (mew-syntax-get-param ctl "boundary")))
 525          (parts []) part
 526          obound ebound bregex start break)
 527     (if (null boundary)
 528         (mew-decode-error "No boundary parameter for multipart"))
 529     (mew-syntax-set-key syntax 'multi)
 530     (setq obound (concat "--" boundary))
 531     (setq ebound (concat "--" boundary "--"))
 532     (setq bregex (concat "^--" boundary "\\(\\|--\\)$"))
 533     (if (not (re-search-forward (concat "^" obound "$") nil t))
 534         (mew-decode-error (format "No first boundary for %s" ct)))
 535     (forward-line)
 536     (setq start (point)) ;; the beginning of the part
 537     (catch 'multipart
 538       (while t
 539         (if (not (re-search-forward bregex nil t))
 540             (mew-decode-error (format "No last boundary for %s" ct)))
 541         (setq break (string= (regexp-quote (mew-match 0)) ebound))
 542         (forward-line) ;; the beginning of the next part
 543         (save-excursion
 544           (forward-line -1)
 545           (beginning-of-line) ;; just in case
 546           (forward-char -1) ;; skip the preceding CRLF
 547           ;; the end of the part
 548           (save-restriction
 549             (narrow-to-region start (point))
 550             (goto-char (point-min))
 551             ;; the beginning of the part
 552             (setq part (mew-decode-singlepart cnt dct nil))
 553             (setq parts (vconcat parts (vector part)))))
 554         (setq start (point)) ;; the beginning of the part
 555         (if break
 556             (throw 'multipart (vconcat syntax parts)))))))
 557
 558 ;;
 559 ;; the function "D":: for decryption
 560 ;;
 561
 562 (defun mew-decode-multipart-encrypted (syntax cnt)
 563   ;; called in narrowed region
 564   ;;
 565   ;;     CT: M/E; proto; bound;
 566   ;;
 567   ;;(cur)--bound
 568   ;;             (the key part)
 569   ;;     --bound
 570   ;;             (the encrypted part)
 571   ;;     --bound--
 572   (let* ((case-fold-search nil) ;; boundary is case sensitive
 573          (ctl (mew-syntax-get-ct syntax))
 574          (boundary (regexp-quote (mew-syntax-get-param ctl "boundary")))
 575          (switch mew-decode-multipart-encrypted-switch)
 576          file1 file2 file3 syntax1 syntax3 func unknown existp proto
 577          start result file3result privacy
 578          oregex eregex)
 579     (if (null boundary)
 580         (mew-decode-error "No boundary parameter for multipart"))
 581     (setq oregex (concat "^--" boundary "$"))
 582     (setq eregex (concat "^--" boundary "--$"))
 583     ;;
 584     (if (not (re-search-forward oregex nil t))
 585         (mew-decode-error "No first boundary for Multipart/Encrypted"))
 586     (forward-line) ;; the beginning of the key part
 587     (setq start (point))
 588     ;;
 589     (if (not (re-search-forward oregex nil t))
 590         (mew-decode-error "No second boundary for Multipart/Encrypted"))
 591     (beginning-of-line)
 592     (setq syntax1 (mew-decode-security-singlepart start (1- (point))))
 593     (setq proto (car (mew-syntax-get-ct syntax1)))
 594     (setq func (mew-decode-get-security-func proto switch))
 595     (setq existp (mew-decode-get-security-existence proto switch))
 596     (if func
 597         (if existp
 598             (setq file1 (mew-save-decode-form syntax1)))
 599       (setq unknown t))
 600     (forward-line) ;; the beginning of the encrypted part
 601     (setq start (point))
 602     ;;
 603     (if (not (re-search-forward eregex nil t))
 604         (mew-decode-error "No third boundary for Multipart/Encrypted"))
 605     (beginning-of-line)
 606     (if (and func existp)
 607         (setq file2 (mew-save-decode-form
 608                      (mew-decode-security-singlepart start (1- (point))))))
 609     ;;
 610     (delete-region (point-min) (point-max))
 611     ;;
 612     ;; Call protocol function
 613     (cond
 614      (unknown
 615       (setq result (concat "unknown protocol " proto)))
 616      ((not existp)
 617       (setq result (concat (mew-decode-get-security-prog proto switch)
 618                            " doesn't exist")))
 619      (t
 620       (setq file3result (funcall func file1 file2))
 621       (setq file3 (nth 0 file3result) result (nth 1 file3result))))
 622     ;;
 623     (if (and func existp (file-exists-p file3))
 624         (mew-flet
 625          (insert-file-contents file3)
 626          (put-text-property (point-min) (point-max) 'mew-noncontents nil)
 627          ;; because of RICH functionality of RFC1847... Gee dirty!
 628          (mew-decode-crlf-magic))
 629       (insert "\n") ;; CT: text/plain; charset=us-ascii
 630       (insert "Multipart/Encrypted could not be decrypted.\n")
 631       (setq mew-decode-not-decrypted t))
 632     ;; Throw away garbage
 633     (and file1 (file-exists-p file1) (delete-file file1))
 634     (and file2 (file-exists-p file2) (delete-file file2))
 635     (and file3 (file-exists-p file3) (delete-file file3))
 636     ;; Analyze the decrypted part
 637     (goto-char (point-min))
 638     (setq syntax3 (mew-decode-singlepart cnt nil nil))
 639     (setq privacy (mew-syntax-get-privacy syntax3))
 640     (if privacy (setq result (concat result "\n\t")))
 641     (mew-syntax-set-privacy
 642      syntax3 (cons (list mew-ct-mle proto result) privacy))
 643     syntax3))
 644
 645 ;;
 646 ;; the function "V":: for verification
 647 ;;
 648
 649 (defun mew-decode-multipart-signed (syntax cnt)
 650   ;; called in narrowed region
 651   ;;
 652   ;;     CT: M/S; proto; bound; micalg;
 653   ;;
 654   ;;(cur)--bound
 655   ;;             (the signed part)
 656   ;;     --bound
 657   ;;             (the key part)
 658   ;;     --bound--
 659   (let* ((case-fold-search nil) ;; boundary is case sensitive
 660          (ctl (mew-syntax-get-ct syntax))
 661          (boundary (regexp-quote (mew-syntax-get-param ctl "boundary")))
 662          (switch mew-decode-multipart-signed-switch)
 663          file1 file2 syntax2 syntax3 func unknown existp proto
 664          end1 start2 result privacy
 665          oregex eregex)
 666     (if (null boundary)
 667         (mew-decode-error "No boundary parameter for multipart"))
 668     (setq oregex (concat "^--" boundary "$"))
 669     (setq eregex (concat "^--" boundary "--$"))
 670     ;;
 671     (if (not (re-search-forward oregex nil t))
 672         (mew-decode-error "No first boundary for Multipart/Signed"))
 673     (forward-line)
 674     ;; the beginning of the signed part
 675     (delete-region (point-min) (point)) ;; deleting content-header
 676     (goto-char (point-min)) ;; just in case
 677     ;;
 678     (if (not (re-search-forward oregex nil t))
 679         (mew-decode-error "No second boundary for Multipart/Signed"))
 680     (beginning-of-line)
 681     (setq end1 (1- (point))) ;; the end of the signed part
 682     (forward-line) ;; the beginning of the key part
 683     (setq start2 (point))
 684     ;;
 685     (if (not (re-search-forward eregex nil t))
 686         (mew-decode-error "No third boundary for Multipart/Signed"))
 687     (beginning-of-line) ;; the end of the encrypted part + 1
 688     (setq syntax2 (mew-decode-security-singlepart start2 (1- (point))))
 689     (setq proto (car (mew-syntax-get-ct syntax2)))
 690     (setq func (mew-decode-get-security-func proto switch))
 691     (setq existp (mew-decode-get-security-existence proto switch))
 692     (if func
 693         (if existp
 694             (progn
 695               (setq file1 (mew-save-transfer-form (point-min) end1 'retain))
 696               (setq file2 (mew-save-decode-form syntax2))))
 697       (setq unknown t))
 698     ;;
 699     (delete-region end1 (point-max))
 700     ;; Now the signed part only
 701     ;; Call protocl function
 702     (cond
 703      (unknown
 704       (setq result (concat "unknown protocol " proto)))
 705      ((not existp)
 706       (setq result (concat (mew-decode-get-security-prog proto switch)
 707                            " doesn't exist")))
 708      (t
 709       (setq result (funcall func file1 file2))))
 710     ;; Throw away garbage
 711     (and file1 (file-exists-p file1) (delete-file file1))
 712     (and file2 (file-exists-p file2) (delete-file file2))
 713     ;; Analyze the signed part
 714     (goto-char (point-min))
 715     (setq syntax3 (mew-decode-singlepart cnt nil nil))
 716     (setq privacy (mew-syntax-get-privacy syntax3))
 717     (if privacy (setq result (concat result "\n\t")))
 718     (mew-syntax-set-privacy
 719      syntax3 (cons (list mew-ct-mls proto result) privacy))
 720     syntax3))
 721
 722 (defmacro mew-decode-get-security-func (proto switch)
 723   (` (nth 1 (mew-assoc-case-equal (, proto) (, switch) 0))))
 724
 725 (defmacro mew-decode-get-security-existence (proto switch)
 726   (` (symbol-value (nth 2 (mew-assoc-case-equal (, proto) (, switch) 0)))))
 727
 728 (defmacro mew-decode-get-security-prog (proto switch)
 729   (` (symbol-value (nth 3 (mew-assoc-case-equal (, proto) (, switch) 0)))))
 730
 731 (defun mew-decode-security-singlepart (beg end)
 732   (save-excursion
 733     (save-restriction
 734       (narrow-to-region beg end)
 735       (goto-char (point-min))
 736       (mew-decode-singlepart 0)))) ;; 0 is dummy
 737
 738 (defun mew-save-decode-form (syntax)
 739   (mew-flet
 740    (let ((file (mew-make-temp-name)))
 741      (write-region (mew-syntax-get-begin syntax)
 742                    (mew-syntax-get-end syntax)
 743                    file nil 'no-msg)
 744      file)))
 745
 746 (defun mew-decode-crlf-magic ()
 747   (let ((case-fold-search t)
 748         (cte mew-7bit)
 749         key start match)
 750     (save-excursion
 751       (goto-char (point-min))
 752       (catch 'header
 753         (while (re-search-forward
 754                 "^\r?$\\|^Content-Transfer-Encoding:[ \t]*" nil t)
 755           (setq key (mew-match 0))
 756           (setq start (match-end 0))
 757           (if (string-match "^\r?$" key)
 758               (progn
 759                 (save-restriction
 760                   (if (string-match mew-bin cte)
 761                       (narrow-to-region (point-min) (1+ start))
 762                     (narrow-to-region (point-min) (point-max)))
 763                   (goto-char (point-min))
 764                   (while (search-forward "\r\n" nil t)
 765                     (replace-match "\n" nil t)))
 766                 (throw 'header nil)))
 767           (forward-line)
 768           (mew-header-goto-next)
 769           (setq match (mew-buffer-substring start (1- (point))))
 770           (setq cte (mew-addrstr-parse-value match)))))))
 771
 772 (provide 'mew-decode)
 773
 774 ;;; Copyright Notice:
 775
 776 ;; Copyright (C) 1996, 1997, 1998, 1999 Mew developing team.
 777 ;; All rights reserved.
 778
 779 ;; Redistribution and use in source and binary forms, with or without
 780 ;; modification, are permitted provided that the following conditions
 781 ;; are met:
 782 ;;
 783 ;; 1. Redistributions of source code must retain the above copyright
 784 ;;    notice, this list of conditions and the following disclaimer.
 785 ;; 2. Redistributions in binary form must reproduce the above copyright
 786 ;;    notice, this list of conditions and the following disclaimer in the
 787 ;;    documentation and/or other materials provided with the distribution.
 788 ;; 3. Neither the name of the team nor the names of its contributors
 789 ;;    may be used to endorse or promote products derived from this software
 790 ;;    without specific prior written permission.
 791 ;;
 792 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 793 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 794 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 795 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 796 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 797 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 798 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 799 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 800 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 801 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 802 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 803
 804 ;;; mew-decode.el ends here