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

   1 ;;; mew-syntax.el --- Internal syntax for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Oct  2, 1996
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-syntax-version "mew-syntax.el version 0.18")
  10
  11 (require 'mew)
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14 ;;
  15 ;; mew-encode-syntax
  16 ;;
  17 ;; <esgl> = [ 'single file (dcr) (<epri>) (CT:)   CTE: CD: nil (CDP:) ]
  18 ;; <emul> = [ 'multi  dir/ (dcr) (<epri>) ("mul") CTE: CD: nil (CDP:) 1*<eprt> ]
  19 ;; <eprt> = <esgl> | <emul>
  20 ;; <epri> = list of (mew-ct-mls mew-ct-pgs)
  21 ;;
  22 ;; mew-decode-syntax
  23 ;;
  24 ;; <dmsg> = [ 'message hbeg hend (<dpri>) ("msg") CTE: CD: CID: (CDP:) <dbdy> ]
  25 ;; <dsgl> = [ 'single   beg  end (<dpri>) (CT:)   CTE: CD: CID: (CDP:) ]
  26 ;; <dmul> = [ 'multi    beg  end (<dpri>) ("mul") CTE: CD: CID: (CDP:) 1*<dprt> ]
  27 ;; <dbdy> = <dmul> | Text/Plain <dsgl>
  28 ;; <dprt> = <dmsg> | <dsgl> | <dmul>
  29 ;; <dpri> = list of (mew-ct-mls mew-ct-pgs RESULT) in reverse order ;; for cons
  30
  31 ;;
  32 ;;
  33 ;;
  34
  35 (defmacro mew-syntax-singlepart-p (syntax)
  36   (` (eq (aref (, syntax) 0) 'single)))
  37
  38 (defmacro mew-syntax-multipart-p (syntax)
  39   (` (eq (aref (, syntax) 0) 'multi)))
  40
  41 (defmacro mew-syntax-message-p (syntax)
  42   (` (eq (aref (, syntax) 0) 'message)))
  43
  44 ;;
  45 ;;
  46 ;;
  47
  48 (defmacro mew-syntax-get-key (syntax)
  49   (` (aref (, syntax) 0)))
  50
  51 (defmacro mew-syntax-set-key (syntax key)
  52   (` (aset (, syntax) 0 (, key))))
  53
  54 (defmacro mew-syntax-get-begin (syntax)
  55   (` (aref (, syntax) 1)))
  56
  57 (defmacro mew-syntax-set-begin (syntax begin)
  58   (` (aset (, syntax) 1 (, begin))))
  59
  60 (defmacro mew-syntax-get-end (syntax)
  61   (` (aref (, syntax) 2)))
  62
  63 (defmacro mew-syntax-set-end (syntax end)
  64   (` (aset (, syntax) 2 (, end))))
  65
  66 (defmacro mew-syntax-get-privacy (syntax)
  67   (` (aref (, syntax) 3)))
  68
  69 (defmacro mew-syntax-set-privacy (syntax privacy)
  70   (` (aset (, syntax) 3 (, privacy))))
  71
  72 (defmacro mew-syntax-get-ct (syntax)
  73   (` (aref (, syntax) 4)))
  74
  75 (defmacro mew-syntax-set-ct (syntax ct)
  76   (` (aset (, syntax) 4 (, ct))))
  77
  78 (defmacro mew-syntax-get-cte (syntax)
  79   (` (aref (, syntax) 5)))
  80
  81 (defmacro mew-syntax-set-cte (syntax cte)
  82   (` (aset (, syntax) 5 (, cte))))
  83
  84 (defmacro mew-syntax-get-cd (syntax)
  85   (` (aref (, syntax) 6)))
  86
  87 (defmacro mew-syntax-set-cd (syntax cd)
  88   (` (aset (, syntax) 6 (, cd))))
  89
  90 (defmacro mew-syntax-get-cid (syntax)
  91   (` (aref (, syntax) 7)))
  92
  93 (defmacro mew-syntax-set-cid (syntax cid)
  94   (` (aset (, syntax) 7 (, cid))))
  95
  96 (defmacro mew-syntax-get-cdp (syntax)
  97   (` (aref (, syntax) 8)))
  98
  99 (defmacro mew-syntax-set-cdp (syntax cdp)
 100   (` (aset (, syntax) 8 (, cdp))))
 101
 102 (defmacro mew-syntax-get-part (syntax)
 103   (` (aref (, syntax) 9)))
 104
 105 (defmacro mew-syntax-set-part (syntax part)
 106   (` (aset (, syntax) 9 (, part))))
 107
 108 ;; alias for draft syntax
 109
 110 (defmacro mew-syntax-get-file (syntax)
 111   (` (aref (, syntax) 1)))
 112
 113 (defmacro mew-syntax-set-file (syntax file)
 114   (` (aset (, syntax) 1 (, file))))
 115
 116 (defmacro mew-syntax-get-decrypters (syntax)
 117   (` (aref (, syntax) 2)))
 118
 119 (defmacro mew-syntax-set-decrypters (syntax decrypters)
 120   (` (aset (, syntax) 2 (, decrypters))))
 121
 122 ;; for content parameters
 123
 124 (defun mew-syntax-get-value (ctl &optional capitalize)
 125   (if capitalize
 126       (capitalize (car ctl))
 127     (car ctl)))
 128
 129 (defmacro mew-syntax-get-params (ctl)
 130   (` (cdr (, ctl))))
 131
 132 ;; ctl = (value (pname pvalue) (pname pvalue) ...)
 133 ;; ctl = ((pname pvalue) (pname pvalue) ...)
 134 (defmacro mew-syntax-get-param (ctl member)
 135   (` (mew-header-sanity-check-string (nth 1 (assoc (, member) (, ctl))))))
 136
 137 ;; need to setq
 138 (defmacro mew-syntax-cat (syntax part)
 139   (` (vconcat (, syntax) (vector (, part)))))
 140
 141 (defun mew-syntax-cdp-format (file)
 142   (if file (list "attachment" (list "filename" file))))
 143
 144 ;; Encryption
 145
 146 (defun mew-syntax-encrypted-p (syntax)
 147   (let ((plist (mew-syntax-get-privacy (mew-syntax-get-part syntax))))
 148     (catch 'loop
 149       (while plist
 150         (if (mew-case-equal (nth 0 (car plist)) mew-ct-mle)
 151             (throw 'loop t))
 152         (setq plist (cdr plist))))))
 153
 154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 155 ;;
 156 ;; Entry functions
 157 ;;
 158
 159 (defun mew-syntax-get-entry (syntax nums)
 160   (cond
 161    ((null nums) syntax) ;; single & message match
 162    ((mew-syntax-message-p syntax)
 163     (let ((body (mew-syntax-get-part syntax)))
 164       (if (mew-syntax-multipart-p body)
 165           (mew-syntax-get-entry (mew-syntax-get-part syntax) nums)
 166         ;; nums sould be "1"
 167         body)))
 168    ((mew-syntax-multipart-p syntax)
 169     (if (null nums) syntax
 170       (mew-syntax-get-entry
 171        (aref syntax (+ mew-syntax-magic (1- (car nums)))) (cdr nums))))))
 172
 173 (defun mew-syntax-insert-entry (syntax nums entry)
 174   (let* ((root syntax)
 175          (child entry)
 176          grand parent
 177          (nl (length nums))
 178          (rev (reverse nums))
 179          (n0 (nth 0 rev))
 180          (n1 (nth 1 rev))
 181          (ns (reverse (nthcdr 2 rev))))
 182     (cond
 183      ((= nl 1)
 184       (setq parent root)
 185       (mew-syntax-add-entry parent n0 child))
 186      (t
 187       (if (= nl 2)
 188           (setq grand root)
 189         (setq grand (mew-syntax-get-entry root ns)))
 190       (setq parent (mew-syntax-get-entry grand (list n1)))
 191       (setq parent (mew-syntax-add-entry parent n0 child))
 192       (aset grand (+ mew-syntax-magic (1- n1)) parent)
 193       root))))
 194
 195 (defun mew-syntax-add-entry (syntax n entry)
 196   "Must not use in functions other than mew-syntax-insert-entry"
 197   (let* ((len (1+ (length syntax)))
 198          (vec (make-vector len nil))
 199          (cnt 0) (thr (+ mew-syntax-magic (1- n))))
 200     (while (< cnt thr)
 201       (aset vec cnt (aref syntax cnt))
 202       (setq cnt (1+ cnt)))
 203     (aset vec cnt entry)
 204     (setq cnt (1+ cnt))
 205     (while (< cnt len)
 206       (aset vec cnt (aref syntax (1- cnt)))
 207       (setq cnt (1+ cnt)))
 208     vec ;; return value
 209     ))
 210
 211 (defun mew-syntax-remove-entry (syntax nums)
 212   (let* ((root syntax)
 213          grand parent
 214          (nl (length nums))
 215          (rev (reverse nums))
 216          (n0 (nth 0 rev))
 217          (n1 (nth 1 rev))
 218          (ns (reverse (nthcdr 2 rev))))
 219     (cond
 220      ((= nl 1)
 221       (setq parent root)
 222       (mew-syntax-cut-entry parent n0))
 223      (t
 224       (if (= nl 2)
 225           (setq grand root)
 226         (setq grand (mew-syntax-get-entry root ns)))
 227       (setq parent (mew-syntax-get-entry grand (list n1)))
 228       (setq parent (mew-syntax-cut-entry parent n0))
 229       (aset grand (+ mew-syntax-magic (1- n1)) parent)
 230       root))))
 231
 232 (defun mew-syntax-cut-entry (syntax n)
 233   "Must not use in functions other than mew-syntax-remove-entry"
 234   (let* ((len (1- (length syntax)))
 235          (vec (make-vector len nil))
 236          (cnt 0) (thr (+ mew-syntax-magic (1- n))))
 237     (while (< cnt thr)
 238       (aset vec cnt (aref syntax cnt))
 239       (setq cnt (1+ cnt)))
 240     (while (< cnt len)
 241       (aset vec cnt (aref syntax (1+ cnt)))
 242       (setq cnt (1+ cnt)))
 243     vec ;; return value
 244     ))
 245
 246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 247 ;;
 248 ;;
 249 ;;
 250
 251 (defvar mew-syntax-number-text-regex "^.....\\([.0-9]+\\) +")
 252 (defvar mew-syntax-number-icon-regex "<\\([0-9.]+\\)>")
 253
 254 (defun mew-summary-goto-part (msg part)
 255   (goto-char (point-min))
 256   (cond
 257    ((equal major-mode 'mew-virtual-mode)
 258     (if (re-search-forward (format "\r.*%s" msg) nil t)
 259         (re-search-forward (format "^.....%s" part) nil t)))
 260    ((equal major-mode 'mew-summary-mode)
 261     (if (re-search-forward (format "^ *%s" msg) nil t)
 262         (re-search-forward (format "^.....%s" part) nil t))))
 263   (beginning-of-line))
 264
 265 (defun mew-summary-goto-message ()
 266   (if (mew-in-decode-syntax-p)
 267       (progn
 268         (goto-char (mew-decode-syntax-begin))
 269         (forward-line -1))))
 270
 271 (defun mew-syntax-number ()
 272   (let ((event last-command-event)
 273         ret str)
 274     (if (and mew-icon-p
 275              (mouse-event-p event)
 276              (event-over-toolbar-p event)
 277              (or (button-press-event-p event)
 278                  (button-release-event-p event)))
 279         (progn
 280           (setq str (toolbar-button-help-string (event-toolbar-button event)))
 281           ;; last-pressed-toolbar-button can't be used.
 282           (if (string-match mew-syntax-number-icon-regex str)
 283               (setq ret (mew-match 1 str)))))
 284     (or ret
 285         (if (or (mew-in-attach-p)
 286                 (mew-in-decode-syntax-p))
 287             (save-excursion
 288               (beginning-of-line)
 289               (if (looking-at mew-syntax-number-text-regex)
 290                   (mew-match 1)))))))
 291
 292 (defmacro mew-syntax-number-to-nums (strnum)
 293   (` (if (, strnum)
 294          (mapcar (function string-to-int) (mew-split (, strnum) ?.))
 295        nil)))
 296
 297 (defmacro mew-syntax-nums ()
 298   '(mew-syntax-number-to-nums (mew-syntax-number)))
 299
 300 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 301 ;;;
 302 ;;; get number
 303 ;;;
 304
 305 (defun mew-summary-message-number ()
 306   (let ((event last-command-event)
 307         ret str)
 308     (if (and mew-icon-p
 309              ;; exclude press button 2 in summary buffer.
 310              ;; exclude pulldown menu in Summary mode.
 311              ;; exclude popup menu of multipart icon because
 312              ;; the cursor has already moved.
 313              (mouse-event-p event)
 314              (event-over-toolbar-p event)
 315              (or (button-press-event-p event)     ;; right button
 316                  (button-release-event-p event))) ;; left button
 317         (if last-pressed-toolbar-button
 318             (progn
 319               (setq str (toolbar-button-help-string
 320                          last-pressed-toolbar-button))
 321               (if (string-match "^\\([0-9]+\\) " str)
 322                   (setq ret (mew-match 1 str))))))
 323     (if ret
 324         ret
 325       (if (not (mew-in-decode-syntax-p))
 326           (save-excursion
 327             (beginning-of-line)
 328             (cond
 329              ((equal major-mode 'mew-summary-mode)
 330               (if (looking-at mew-summary-message-regex)
 331                   (mew-match 1)
 332                 nil))
 333              ((equal major-mode 'mew-virtual-mode)
 334               (if (looking-at ".*\r \\([-+%=].*\\) \\(.*\\)$")
 335                   (mew-match 2)
 336                 nil))
 337              (t nil)))))))
 338
 339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 340 ;;
 341 ;; mew-encode-syntax
 342 ;;
 343
 344 (defun mew-encode-syntax-single (file &optional ctl cte cd cid cdp
 345                                       privacy decrypters)
 346   ;; cid is just for beauty
 347   ;; if cdp is *non-nil*, set cdp from file.
 348   (let* ((attr (mew-attr-by-file file))
 349          (ct (mew-attr-get-ct attr)))
 350     (or cte (setq cte (mew-attr-get-cte attr)))
 351     (if (null ctl) (setq ctl (list ct)))
 352     (if (and cdp
 353              (not (mew-member-match ct mew-mime-content-type-ignore-cdp t)))
 354         (setq cdp file)
 355       (setq cdp nil))
 356     (setq cdp (mew-syntax-cdp-format cdp))
 357     (vconcat [single] (list file decrypters privacy ctl cte cd cid cdp))))
 358
 359 (defun mew-encode-syntax-multi (dir ct)
 360   (if (not (string-match (concat mew-path-separator "$") dir))
 361       (setq dir (file-name-as-directory dir)))
 362   (vconcat [multi] (list dir) [nil nil] (list ct) [nil nil nil nil]))
 363
 364 (defun mew-encode-syntax-initial (dir)
 365   (vconcat
 366    (mew-encode-syntax-multi dir mew-type-mlm)
 367    ;; ensure to guess charset ....
 368    (list (mew-encode-syntax-single mew-draft-coverpage (list mew-ct-txt)))))
 369
 370 (defun mew-encode-syntax-initial-multi (dir n)
 371   (let ((i 1) (ret))
 372     (while (<= i n)
 373       (setq ret (vconcat ret (list (mew-encode-syntax-single
 374                                     (int-to-string i)))))
 375       (setq i (1+ i)))
 376     (vconcat (mew-encode-syntax-multi dir mew-type-mlm)
 377              (list (mew-encode-syntax-single mew-draft-coverpage
 378                                              (list mew-ct-txt)))
 379              ret)))
 380
 381 (defconst mew-encode-syntax-dot
 382   [nil "." nil nil ("") nil nil nil nil])
 383
 384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 385 ;;
 386 ;; mew-decode-syntax
 387 ;;
 388
 389 (defun mew-decode-syntax-rfc822 (&optional msg-head)
 390   ;; msg-head may include CD:
 391   (if (null msg-head) (setq msg-head (mew-decode-syntax-rfc822-head t)))
 392   (vconcat msg-head (vector (mew-decode-syntax-text))))
 393
 394 (defun mew-decode-syntax-rfc822-head (&optional reg-hend)
 395   (vector 'message (point-min)
 396           (and reg-hend
 397                (save-excursion (forward-line -1) (beginning-of-line) (point)))
 398           nil mew-type-msg nil nil nil nil))
 399
 400 (defun mew-decode-syntax-text ()
 401   (vector 'single (point) (point-max) nil mew-type-txt nil nil nil nil))
 402
 403 (defconst mew-encode-syntax-multi-head
 404   (vector 'multi nil nil nil mew-type-mlm nil nil nil nil))
 405
 406 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 407 ;;
 408 ;; syntax printer
 409 ;;
 410
 411 (defun mew-encode-syntax-print (syntax)
 412   (interactive)
 413   (mew-elet
 414    (let ((end nil)
 415          (nums (mew-syntax-nums)))
 416      (cond
 417       ((mew-attach-p)
 418        (goto-char (point-max))
 419        (re-search-backward (concat "^" mew-draft-attach-boundary-end "$") nil t)
 420        (setq end (point))
 421        (re-search-backward (concat "^" mew-draft-attach-boundary-begin "$") nil t)
 422        (forward-line)
 423        (delete-region (point) end)
 424        (setq mew-syntax-multi-form nil)
 425        (setq mew-syntax-icon-spec nil)
 426        (mew-syntax-multipart syntax nil nil 'mew-draft-button)
 427        (mapcar (function insert-and-inherit)
 428                (nreverse mew-syntax-multi-form))
 429        (if mew-xemacs-p
 430            (progn
 431              (goto-char (mew-attach-begin))
 432              (insert "X")))
 433        (put-text-property (mew-attach-begin) (point-max) 'read-only t)
 434        (mew-front-nonsticky (mew-attach-begin) (1+ (mew-attach-begin)))
 435        (mew-rear-sticky (1- (point-max)) (point-max))
 436        (if mew-xemacs-p
 437            (progn
 438              (goto-char (1- (mew-attach-begin)))
 439              (delete-char 1)))
 440        (if mew-icon-p
 441            (mew-syntax-print-icon-spec (nreverse mew-syntax-icon-spec)
 442                                        mew-draft-toolbar))
 443        (mew-attach-goto-number 'here nums))))))
 444
 445 ;;
 446 ;;
 447 ;;
 448
 449 (defun mew-decode-syntax-print (sumbuf syntax form spec)
 450   ;; message buffer
 451   (let ((part (mew-syntax-get-part syntax))
 452         (cbuf (current-buffer)))
 453     (if (not (mew-syntax-multipart-p part))
 454         ()
 455       (set-buffer sumbuf)
 456       (forward-line)
 457       (mew-elet
 458        (let ((pos (point)))
 459          (mew-decode-syntax-begin-set)
 460          (mapcar (function insert-and-inherit) form)
 461          (if (equal pos (point))
 462              ;; Nothing was printed.
 463              (mew-decode-syntax-remove)
 464            (mew-decode-syntax-end-set)
 465            (put-text-property (mew-decode-syntax-begin) (mew-decode-syntax-end)
 466                               'face 'default)))
 467        (if mew-icon-p
 468            (mew-syntax-print-icon-spec spec mew-summary-toolbar))
 469        (mew-summary-goto-message)
 470        (set-buffer-modified-p nil))
 471       (set-buffer cbuf))))
 472
 473 ;;
 474 ;;
 475 ;;
 476
 477 (defun mew-decode-syntax-clear ()
 478   (setq mew-syntax-multi-form nil)
 479   (mew-syntax-clear-icon-spec)
 480   (mew-decode-syntax-clear-privacy))
 481
 482 (defun mew-decode-syntax-set ()
 483   ;; cache buffer
 484   (let ((mc-flag t)
 485         (part (mew-syntax-get-part mew-decode-syntax)))
 486     (if (mew-syntax-multipart-p part)
 487         (progn
 488           (mew-syntax-multipart part 'decoding nil 'mew-summary-button 'body)
 489           (setq mew-syntax-multi-form (nreverse mew-syntax-multi-form))
 490           (setq mew-syntax-icon-spec (nreverse mew-syntax-icon-spec)))
 491       (mew-decode-syntax-set-privacy part "body"))))
 492
 493 (defun mew-syntax-multipart (syntax dec part func &optional body)
 494   (let* ((ct (mew-syntax-get-value (mew-syntax-get-ct syntax) 'cap))
 495          (cd (or (mew-syntax-get-cd syntax) ""))
 496          (cnt mew-syntax-magic)
 497          (num 1)
 498          (len (length syntax))
 499          strpart subsyntax)
 500     ;; multipart itself is displayed only when encoding.
 501     (if dec
 502         (mew-decode-syntax-set-privacy
 503          syntax
 504          (concat (if part (concat part " "))
 505                  (if body "body ")
 506                  "multi"))
 507       (mew-syntax-format syntax part dec)
 508       (mew-syntax-set-icon-spec part
 509                                 ct cd
 510                                 (mew-attr-get-icon (mew-attr-by-ct ct)) func))
 511     (while (< cnt len)
 512       (if part
 513           (setq strpart (concat part "." (int-to-string num)))
 514         (setq strpart (int-to-string num)))
 515       (setq subsyntax (aref syntax cnt))
 516       (cond
 517        ((mew-syntax-multipart-p subsyntax)
 518         (mew-syntax-multipart subsyntax dec strpart func nil))
 519        ((mew-syntax-message-p subsyntax)
 520         (mew-syntax-message subsyntax dec strpart func))
 521        ((mew-syntax-singlepart-p subsyntax)
 522         (mew-syntax-singlepart subsyntax dec strpart func
 523                                (and body (equal cnt mew-syntax-magic)))))
 524       (setq cnt (1+ cnt))
 525       (setq num (1+ num)))
 526     (if dec
 527         ()
 528       (if part
 529           (setq part (concat part "." (int-to-string num)))
 530         (setq part (int-to-string num)))
 531       (mew-syntax-format mew-encode-syntax-dot part dec)
 532       (mew-syntax-set-icon-spec part "Attach Here" cd mew-icon-blank func))))
 533
 534 (defun mew-syntax-singlepart (syntax dec part func first)
 535   ;; part is valid only when called by mew-syntax-multipart.
 536   (let ((ct (mew-syntax-get-value (mew-syntax-get-ct syntax) 'cap))
 537         (cd (or (mew-syntax-get-cd syntax) "")))
 538     ;; see also mew-mime-message/rfc822.
 539     (if (and dec
 540              ;; the first singlepart in multipart under message if t
 541              ;; the first singlepart under message if 'body
 542              first
 543              ;; CT: is text/plain but not attached file.
 544              (mew-case-equal ct mew-ct-txt))
 545         () ;; skip displaying.
 546       ;; reach here only when called by mew-syntax-multipart.
 547       (mew-syntax-format syntax part dec)
 548       (mew-syntax-set-icon-spec part ct cd
 549                                 (mew-attr-get-icon (mew-attr-by-ct ct)) func))
 550     (if dec (mew-decode-syntax-set-privacy
 551              syntax
 552              (if (equal first 'body)
 553                  (if part (concat part " body") "body")
 554                part)))))
 555
 556 (defun mew-syntax-message (syntax dec part func)
 557   (let ((ct (mew-syntax-get-value (mew-syntax-get-ct syntax) 'cap))
 558         (cd (or (mew-syntax-get-cd syntax) ""))
 559         (subsyntax (mew-syntax-get-part syntax)))
 560     (mew-syntax-format syntax part dec)
 561     (if dec (mew-decode-syntax-set-privacy
 562              syntax
 563              (format "%s message" part)))
 564     (mew-syntax-set-icon-spec part ct cd
 565                               (mew-attr-get-icon (mew-attr-by-ct ct)) func)
 566     (cond
 567      ((mew-syntax-multipart-p subsyntax)
 568       (mew-syntax-multipart subsyntax dec part func 'body))
 569      ((mew-syntax-message-p subsyntax)
 570       ) ;; never happens
 571      ((mew-syntax-singlepart-p subsyntax)
 572       ;; text/plain only
 573       (mew-syntax-singlepart subsyntax dec part func 'body)))))
 574
 575 ;012345678901234567890123456789012345678901234567890123456789012345678901234567
 576 ;<4>snss<27-2                   >ss<24+2                    >ss<16            >
 577
 578 (defun mew-syntax-format (syntax number dec)
 579   (let* ((file (if (not dec) (mew-syntax-get-file syntax)))
 580          (ctl (mew-syntax-get-ct syntax))
 581          (ct (mew-syntax-get-value ctl 'cap))
 582          (char (mew-syntax-get-param ctl "charset"))
 583          (cte (mew-syntax-get-cte syntax)) ;; cte may be nil
 584          (cd (mew-syntax-get-cd syntax))
 585          (cdpl (mew-syntax-get-cdp syntax))
 586          (filename (mew-syntax-get-param cdpl "filename"))
 587          (decrypters-list (mew-syntax-get-decrypters syntax))
 588          (decrypters (and (not dec) decrypters-list
 589                           (mew-join "," decrypters-list)))
 590          (cd-or-dec cd)
 591          (privacy (mew-syntax-get-privacy syntax))
 592          (space " ") (SP 32)
 593          (cnt "..") (lcnt (length cnt))
 594          (LT (- (window-width) 2))
 595          (ln (length number))
 596          (lm 4)
 597          (lt 27) (ltc (- lt lcnt))
 598          (ld (* (/ (- LT lm lt) 5) 3)) (ldc (- ld lcnt))
 599          (lf (- LT lm ln lt ld 8)) (lfc (- lf lcnt))
 600          (AR "*") (lfc* (1- lfc)) (asterisk nil)
 601          (case-fold-search t)
 602          (marks (make-string lm SP))
 603          (i 0) (N (length privacy))
 604          ctm ctp)
 605
 606     (run-hooks 'mew-syntax-format-hook)
 607     (if (string-match "Text/" ct)
 608         (if char
 609             (setq ct (concat ct "(" char ")"))
 610           (if dec
 611               (setq ct (concat ct "(" mew-us-ascii ")"))
 612             (setq ct (concat ct "(guess)")))))
 613     (if (null privacy)
 614         (if (null cte)
 615             ()
 616           (setq cte (downcase cte))
 617           (cond
 618            ((or (equal cte mew-7bit)
 619                 (equal cte mew-8bit)
 620                 (equal cte mew-bin))
 621             ;; no mark
 622             )
 623            ((equal cte mew-b64) (aset marks 0 ?B))
 624            ((equal cte mew-qp)  (aset marks 0 ?Q))
 625            ((equal cte mew-xg)  (aset marks 0 ?G))
 626            (t                   (aset marks 0 ?X))))
 627
 628       (if dec (setq privacy (reverse privacy)))
 629       (while (< i N)
 630         (setq ctm (nth 0 (nth i privacy)))
 631         (setq ctp (nth 1 (nth i privacy)))
 632         (cond
 633          ((string-match "pgp"  ctp) (aset marks (* i 2) ?P))
 634          ((string-match "moss" ctp) (aset marks (* i 2) ?M)))
 635         (cond
 636          ((string-match mew-ct-mle ctm) (aset marks (1+ (* i 2)) ?E))
 637          ((string-match mew-ct-mls ctm) (aset marks (1+ (* i 2)) ?S)))
 638         (setq i (1+ i))))
 639
 640     (if (< lm (length marks))
 641         (setq marks (substring marks 0 lm))
 642       (setq marks (concat marks (make-string (- lm (length marks)) SP))))
 643
 644     (if (< lt (length ct))
 645         (setq ct (concat (substring ct 0 ltc) cnt))
 646       (setq ct (concat ct (make-string (- lt (length ct)) SP))))
 647
 648     (if (and (not dec) decrypters) (setq cd-or-dec decrypters))
 649     (if (null cd-or-dec)
 650         (setq cd-or-dec (make-string ld SP))
 651       (if (< ld (mew-string-width cd-or-dec))
 652           (setq cd-or-dec (concat (mew-substring cd-or-dec ldc) cnt))
 653         (setq cd-or-dec
 654               (concat cd-or-dec
 655                       (make-string (- ld (mew-string-width cd-or-dec)) SP)))))
 656     (cond
 657      (filename
 658       (setq file filename))
 659      ((and file (not (equal file ".")) (not (string-match "/$" file)))
 660       (setq asterisk t)
 661       (setq file (concat file AR))))
 662     (if file
 663         (if (< lf (mew-string-width file))
 664             (if asterisk
 665                 (setq file (concat (mew-substring file lfc*) AR cnt))
 666               (setq file (concat (mew-substring file lfc) cnt)))))
 667     (setq mew-syntax-multi-form
 668           (cons (concat
 669                  marks
 670                  (if number (concat space number))
 671                  space space
 672                  ct
 673                  space space
 674                  cd-or-dec
 675                  space space
 676                  file
 677                  "\n")
 678                 mew-syntax-multi-form))))
 679
 680 (defun mew-decode-syntax-delete ()
 681   (if (mew-decode-syntax-p)
 682       (let ((cbuf (current-buffer))
 683             (pos (make-marker)))
 684         (set-buffer (mew-decode-syntax-buffer))
 685         (mew-syntax-clear-icon-spec)
 686         (mew-summary-toolbar-update)
 687         (set-marker pos (point))
 688         (mew-elet
 689          (delete-region (mew-decode-syntax-begin) (mew-decode-syntax-end)))
 690         (mew-decode-syntax-remove)
 691         (goto-char (marker-position pos))
 692         (mew-highlight-cursor-line)
 693         (set-buffer-modified-p nil)
 694         (set-buffer cbuf))))
 695
 696 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 697 ;;
 698 ;; icon spec
 699 ;;
 700
 701 (defvar mew-syntax-icon-spec nil)
 702
 703 (defun mew-syntax-set-icon-spec (part ct cd icon func)
 704   (if mew-icon-p
 705       (setq mew-syntax-icon-spec
 706             (cons
 707              (vector icon func t
 708                      ;; cache buffer
 709                      (format "%s <%s> (%s) %s"
 710                              mew-cache-message-number
 711                              (or part "top") ct cd))
 712              mew-syntax-icon-spec))))
 713
 714 (defun mew-syntax-clear-icon-spec ()
 715   (setq mew-syntax-icon-spec nil))
 716
 717 (defun mew-syntax-print-icon-spec (spec bar)
 718   (let ((toolbar))
 719     (cond
 720      ((eq mew-multipart-icon-position 'left)
 721       (setq toolbar (append spec mew-icon-separate-spec bar)))
 722      ((eq mew-multipart-icon-position 'right)
 723       (setq toolbar (append bar mew-icon-separate-spec spec)))
 724      (t (setq toolbar bar)))
 725     (set-specifier default-toolbar (cons (current-buffer) toolbar))))
 726
 727 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 728 ;;
 729 ;; decode privacy
 730 ;;
 731
 732 (defun mew-decode-syntax-set-privacy (syntax label)
 733   (let ((privacy (mew-syntax-get-privacy syntax))
 734         results)
 735     (while privacy
 736       (setq results (concat results (nth 2 (car privacy))))
 737       (setq privacy (cdr privacy)))
 738     (if results
 739         (setq mew-syntax-privacy-result
 740               (concat mew-syntax-privacy-result
 741                       mew-x-mew:
 742                       (format " <%s> " label)
 743                       results
 744                       "\n")))))
 745
 746 (defun mew-decode-syntax-clear-privacy ()
 747   (setq mew-syntax-privacy-result nil))
 748
 749 (defun mew-decode-syntax-insert-privacy ()
 750   (if mew-syntax-privacy-result
 751       (let ((beg (point)))
 752         (insert mew-syntax-privacy-result)
 753         (mew-decode-header-property-region beg (point))
 754         (save-restriction
 755           (narrow-to-region beg (point))
 756           (goto-char (point-min))
 757           (while (re-search-forward "BAD.*sign" nil t)
 758             (put-text-property
 759              (match-beginning 0)
 760              (match-end 0)
 761              'face
 762              (intern-soft "mew-highlight-header-face-xmew-bad")))))))
 763
 764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 765 ;;
 766 ;; markers
 767 ;;
 768
 769 (defvar mew-marker-decode-syntax-begin (make-marker))
 770 (defvar mew-marker-decode-syntax-end (make-marker))
 771
 772 (defvar mew-overlay-header-keymap nil)
 773 (defvar mew-overlay-attach-keymap nil)
 774
 775 (mapcar (function make-variable-buffer-local)
 776         '(mew-overlay-header-keymap
 777           mew-overlay-attach-keymap))
 778
 779 ;; location
 780
 781 (defmacro mew-in-decode-syntax-p ()
 782   '(and (marker-position mew-marker-decode-syntax-begin)
 783         (marker-position mew-marker-decode-syntax-end)
 784         (>= (point) (marker-position mew-marker-decode-syntax-begin))
 785         (<  (point) (marker-position mew-marker-decode-syntax-end))))
 786
 787 (defmacro mew-in-header-p ()
 788   '(let ((end (mew-header-end)))
 789      (and end (<= (point) end))))
 790
 791 (defmacro mew-in-attach-p ()
 792   '(let ((beg (mew-attach-begin)))
 793      (and beg (> (point) beg)))) ;; excluding the preceding \n
 794
 795 ;; existence
 796
 797 (defmacro mew-decode-syntax-p ()
 798   '(and (marker-position mew-marker-decode-syntax-begin)
 799         (marker-position mew-marker-decode-syntax-end)))
 800
 801 (defmacro mew-header-p ()
 802   '(next-single-property-change (point-min) 'read-only))
 803
 804 (defmacro mew-attach-p ()
 805   '(if (/= (point-max) 1)
 806        (get-text-property (1- (point-max)) 'mew-attach-end)))
 807
 808 (defmacro mew-attach-valid-p ()
 809   '(> (length mew-encode-syntax) (1+ mew-syntax-magic)))
 810
 811 ;; point
 812
 813 (defmacro mew-decode-syntax-begin ()
 814   '(marker-position mew-marker-decode-syntax-begin))
 815
 816 (defmacro mew-decode-syntax-end ()
 817   '(marker-position mew-marker-decode-syntax-end))
 818
 819 (defmacro mew-header-end ()
 820   '(mew-header-p))
 821
 822 (defmacro mew-attach-begin ()
 823   '(if (mew-attach-p)
 824        (let ((beg (previous-single-property-change
 825                    (point-max) 'mew-attach-begin)))
 826          (if beg (1- beg) nil))))
 827
 828 ;;
 829
 830 (defmacro mew-decode-syntax-begin-set ()
 831   '(set-marker mew-marker-decode-syntax-begin (point)))
 832
 833 (defmacro mew-decode-syntax-end-set ()
 834   '(set-marker mew-marker-decode-syntax-end (point)))
 835
 836 (defmacro mew-decode-syntax-remove ()
 837   '(progn
 838      (set-marker mew-marker-decode-syntax-begin nil)
 839      (set-marker mew-marker-decode-syntax-end nil)))
 840
 841 (defmacro mew-decode-syntax-buffer ()
 842   '(set-buffer (marker-buffer mew-marker-decode-syntax-begin)))
 843
 844 (defun mew-summary-end-of-message-p ()
 845   (let (pos beg end)
 846     (save-excursion
 847       (set-buffer (mew-decode-syntax-buffer))
 848       (setq pos (point))
 849       (setq end (mew-decode-syntax-end))
 850       (goto-char end)
 851       (forward-line -1)
 852       (beginning-of-line)
 853       (setq beg (point))
 854       (and (<= beg pos) (< pos end)))))
 855
 856 ;;
 857
 858 (defmacro mew-header-set (sep)
 859   (` (mew-elet
 860       (let ((end (point)))
 861         (if (, sep)
 862             (insert (, sep))
 863           (forward-line))
 864         (put-text-property end (point) 'read-only t)
 865         (mew-front-nonsticky end (1+ end))
 866         (mew-rear-nonsticky (1- (point)) (point))
 867         end))))
 868
 869 (defmacro mew-header-clear ()
 870   ;; the cursor moves to the end of the header (with some exceptions)
 871   '(mew-elet
 872     (mew-header-goto-end) ;; do not use mew-header-end
 873     (let ((pos (point)))
 874       (forward-line)
 875 ;;      (put-text-property pos (point) 'read-only nil)
 876       ;; If the body contains the read-only property, mew-header-p
 877       ;; makes a mistake. So, remove the read-only property from
 878       ;; the entire buffer.
 879       (put-text-property (point) (point-max) 'read-only nil)
 880       (delete-region pos (point)))))
 881
 882 ;;
 883
 884 (defmacro mew-attach-set ()
 885   '(mew-elet
 886     (let (beg)
 887       (goto-char (point-max))
 888       (if (null (bolp)) (insert "\n"))
 889       (setq beg (point))
 890       (insert "\n")
 891       (insert mew-draft-attach-boundary-begin)
 892       (insert "\n")
 893       (insert mew-draft-attach-boundary-end)
 894       (insert "\n")
 895       (put-text-property beg (1+ beg) 'mew-attach-begin t)
 896       (put-text-property (1- (point)) (point) 'mew-attach-end t)
 897       (beginning-of-line)
 898       (mew-draft-attach-keymap))))
 899
 900 (defmacro mew-attach-clear ()
 901   '(if (mew-attach-p)
 902        (save-excursion
 903          (mew-elet
 904           (delete-region (mew-attach-begin) (point-max)))
 905          (if mew-use-overlay-keymap
 906              (mew-overlay-delete mew-overlay-attach-keymap)))))
 907
 908 (defmacro mew-header-prepared ()
 909   '(progn
 910      (mew-header-set (concat mew-header-separator "\n"))
 911      (if mew-config-insert-when-prepared
 912          (mew-draft-insert-config 'nohighlight))
 913      (mew-highlight-header)
 914      (mew-draft-header-keymap)))
 915
 916 (defmacro mew-draft-header-keymap ()
 917   '(save-excursion
 918      (if mew-use-overlay-keymap
 919          (if (mew-overlay-p mew-overlay-header-keymap)
 920              (mew-overlay-move mew-overlay-header-keymap
 921                                (point-min) (1+ (mew-header-end)))
 922            (setq mew-overlay-header-keymap
 923                  (mew-overlay-make (point-min) (1+ (mew-header-end))))
 924            (mew-overlay-put mew-overlay-header-keymap
 925                             (if mew-xemacs-p 'keymap 'local-map)
 926                             mew-draft-header-map)
 927            (mew-rear-sticky mew-overlay-header-keymap)))))
 928
 929 (defmacro mew-draft-attach-keymap ()
 930   '(progn
 931      (if mew-use-overlay-keymap
 932          (if (mew-overlay-p mew-overlay-attach-keymap)
 933              (mew-overlay-move mew-overlay-attach-keymap
 934                                (1+ (mew-attach-begin)) (point-max))
 935            (setq mew-overlay-attach-keymap
 936                  (mew-overlay-make (1+ (mew-attach-begin)) (point-max)))
 937            (mew-overlay-put mew-overlay-attach-keymap
 938                             (if mew-xemacs-p 'keymap 'local-map)
 939                             mew-draft-attach-map)))))
 940
 941 (provide 'mew-syntax)
 942
 943 ;;; Copyright Notice:
 944
 945 ;; Copyright (C) 1996, 1997, 1998, 1999 Mew developing team.
 946 ;; All rights reserved.
 947
 948 ;; Redistribution and use in source and binary forms, with or without
 949 ;; modification, are permitted provided that the following conditions
 950 ;; are met:
 951 ;;
 952 ;; 1. Redistributions of source code must retain the above copyright
 953 ;;    notice, this list of conditions and the following disclaimer.
 954 ;; 2. Redistributions in binary form must reproduce the above copyright
 955 ;;    notice, this list of conditions and the following disclaimer in the
 956 ;;    documentation and/or other materials provided with the distribution.
 957 ;; 3. Neither the name of the team nor the names of its contributors
 958 ;;    may be used to endorse or promote products derived from this software
 959 ;;    without specific prior written permission.
 960 ;;
 961 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 962 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 963 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 964 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 965 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 966 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 967 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 968 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 969 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 970 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 971 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 972
 973 ;;; mew-syntax.el ends here