1;;; mime-parse.el --- MIME message parser -*- lexical-binding: t -*- 2 3;; Copyright (C) 1994,95,96,97,98,99,2001 Free Software Foundation, Inc. 4 5;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp> 6;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> 7;; Keywords: parse, MIME, multimedia, mail, news 8 9;; This file is part of FLIM (Faithful Library about Internet Message). 10 11;; This program is free software; you can redistribute it and/or 12;; modify it under the terms of the GNU General Public License as 13;; published by the Free Software Foundation; either version 2, or (at 14;; your option) any later version. 15 16;; This program is distributed in the hope that it will be useful, but 17;; WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19;; General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Code: 27 28(require 'pccl) 29(require 'broken) 30 31(require 'luna) 32(require 'mime-def) 33(require 'std11) 34(require 'mime) 35 36(autoload 'mime-entity-body-buffer "mime") 37(autoload 'mime-entity-body-start-point "mime") 38(autoload 'mime-entity-body-end-point "mime") 39 40 41;;; @ lexical analyzer 42;;; 43 44(unless-broken ccl-usable 45(define-ccl-program mime-default-ccl-lexical-analyzer 46 ;; r0 input 47 ;; r1 flag means any character exists. 48 ;; r2 in parse flag 49 ;; 1 atom, 2 spaces 3 comment (no output) 4 encloser 5 error 50 ;; r3 comment depth 51 (eval-when-compile 52 (let* ((wrt `(if (r0 == ?\") (write "\\\"") 53 (if (r0 == ?\\) (write "\\\\") 54 (write r0)))) 55 (atm `((branch r2 56 ((r2 = 1) 57 (write "(mime-token . \"") 58 (write-read-repeat r0)) 59 (write-read-repeat r0) 60 ((r2 = 1) 61 (write "(mime-token . \"") 62 (write-read-repeat r0))))) 63 (ts `((if (r2 == 1) ((write "\")") (r2 = 0))) 64 (write "(tspecials . \"") 65 ,wrt 66 (write "\")") 67 (read r0) 68 (repeat))) 69 (sp `((branch r2 70 ((r2 = 2) 71 (read r0) 72 (repeat)) 73 ((write "\")") 74 (r2 = 2) 75 (read r0) 76 (repeat)) 77 ((read r0) (repeat))))) 78 (err `((branch r2 79 ((write "(error . \"")) 80 ((write "\")") 81 (write "(error . \"")) 82 ((write "(error . \""))) 83 (r2 = 5) 84 (loop 85 (write-read-repeat r0)))) 86 (enc (lambda (name tag) 87 `((if (r2 == 1) ((write "\")"))) 88 (write ,(concat "(" name " . \"")) 89 (r2 = 4) 90 (loop 91 (read-branch 92 r0 93 ,@(let* ((count (1+ (max tag ?\\))) 94 (result (make-vector count '(write-repeat r0)))) 95 (aset result tag '(break)) 96 (aset result ?\\ `((write "\\\\") 97 (read r0) 98 ,wrt 99 (repeat))) 100 (aset result ?\" '((write "\\\"") (repeat))) 101 (mapcar 'identity result))) 102 (write-repeat r0)) 103 (write "\")") 104 (r2 = 0) 105 (read r0) 106 (repeat)))) 107 (qs (funcall enc "quoted-string" ?\")) 108 (dl (funcall enc "domain-literal" ?\])) 109 (cm `((if (r2 == 1) ((write "\")"))) 110 (r2 = 3) 111 (r3 = 1) 112 (loop 113 (read-branch 114 r0 115 ,@(let* ((count (1+ (max ?\( ?\) ?\\))) 116 (result (make-vector count '(repeat)))) 117 (aset result ?\( '((r3 += 1) (repeat))) 118 (aset result ?\) '((r3 -= 1) 119 (if (r3 < 1) (break) 120 (repeat)))) 121 (aset result ?\\ `((read r0) (repeat))) 122 (mapcar 'identity result))) 123 (repeat)) 124 (r2 = 0) 125 (read r0) 126 (repeat)))) 127 `(8 128 ((r2 = 0) 129 (read r0) 130 (r1 = 1) 131 (write "((") 132 (loop 133 (branch r0 134 ,@(mapcar (lambda (elt) (eval elt)) 135 '(err err err err err err err err 136 err sp sp err err err err err 137 err err err err err err err err 138 err err err err err err err err 139 sp atm qs atm atm atm atm atm 140 cm ts atm atm ts atm atm ts 141 atm atm atm atm atm atm atm atm 142 atm atm ts ts ts ts ts ts 143 ts atm atm atm atm atm atm atm 144 atm atm atm atm atm atm atm atm 145 atm atm atm atm atm atm atm atm 146 atm atm atm dl ts ts))) 147 ,@atm)) 148 ((branch r1 149 (write "(nil . t)") 150 (branch r2 151 (write ") . t)") 152 (write "\")) . t)") 153 (write ") . t)") 154 (write "))") 155 (write "\")))") 156 (write "\")) . t)"))))))))) 157 158(defcustom mime-ccl-lexical-analyzer 159 (static-unless (or (broken-p 'ccl-usable) 160 (broken-p 'ccl-execute-eof-block)) 161 'mime-default-ccl-lexical-analyzer) 162 "Specify CCL-program symbol for `mime-lexical-analyze'. 163When nil, do not use CCL. 164See docstring of `std11-ccl-lexical-analyzer' for details of CCL-program. 165If you modify `mime-lexical-analyzer', set this variable to nil 166or prepare corresponding CCL-program." 167 :group 'mime 168 :type '(choice symbol (const :tag "Do not use CCL." nil))) 169 170(defcustom mime-lexical-analyzer 171 '(std11-analyze-quoted-string 172 std11-analyze-domain-literal 173 std11-analyze-comment 174 std11-analyze-spaces 175 mime-analyze-tspecial 176 mime-analyze-token) 177 "*List of functions to return result of lexical analyze. 178Each function must have two arguments: STRING and START. 179STRING is the target string to be analyzed. 180START is start position of STRING to analyze. 181 182Previous function is preferred to next function. If a function 183returns nil, next function is used. Otherwise the return value will 184be the result." 185 :group 'mime 186 :type '(repeat function)) 187 188(defun mime-analyze-tspecial (string start) 189 (if (and (> (length string) start) 190 (memq (aref string start) mime-tspecial-char-list)) 191 (cons (cons 'tspecials (substring string start (1+ start))) 192 (1+ start)))) 193 194(defun mime-analyze-token (string start) 195 (if (and (string-match mime-token-regexp string start) 196 (= (match-beginning 0) start)) 197 (let ((end (match-end 0))) 198 (cons (cons 'mime-token (substring string start end)) 199 end)))) 200 201(defun mime-lexical-analyze (string) 202 "Analyze STRING as lexical tokens of MIME." 203 (let (ret prev tail) 204 (if (and mime-ccl-lexical-analyzer 205 (cdr (setq ret (read (ccl-execute-on-string 206 mime-ccl-lexical-analyzer 207 (make-vector 9 0) (or string "")))))) 208 (car ret) 209 (setq ret (std11-lexical-analyze string mime-lexical-analyzer)) 210 ;; skip leading linear-white-space. 211 (while (memq (car (car ret)) '(spaces comment)) 212 (setq ret (cdr ret))) 213 (setq prev ret 214 tail (cdr ret)) 215 ;; remove linear-white-space. 216 (while tail 217 (if (memq (car (car tail)) '(spaces comment)) 218 (progn 219 (setcdr prev (cdr tail)) 220 (setq tail (cdr tail))) 221 (setq prev (cdr prev) 222 tail (cdr tail)))) 223 ret))) 224 225 226;;; @ field parser 227;;; 228 229(defun mime-decode-parameter-value (text charset language) 230 (with-temp-buffer 231 (set-buffer-multibyte nil) 232 (insert text) 233 (goto-char (point-min)) 234 (while (re-search-forward "%[0-9A-Fa-f][0-9A-Fa-f]" nil t) 235 (insert (prog1 (string-to-number 236 (buffer-substring (point)(- (point) 2)) 237 16) 238 (delete-region (point)(- (point) 3))))) 239 (setq text (buffer-string)) 240 (when charset 241 (setq text (mime-charset-decode-string text charset))) 242 (when language 243 (put-text-property 0 (length text) 'mime-language language text)) 244 text)) 245 246(defun mime-decode-parameter-encode-segment (segment) 247 (with-temp-buffer 248 (set-buffer-multibyte nil) 249 (insert segment) 250 (goto-char (point-min)) 251 (while (progn 252 (when (looking-at (eval-when-compile 253 (concat mime-attribute-char-regexp "+"))) 254 (goto-char (match-end 0))) 255 (not (eobp))) 256 (insert (prog1 (format "%%%02X" (following-char)) 257 (delete-region (point)(1+ (point)))))) 258 (buffer-string))) 259 260(defun mime-decode-parameters (params) 261 "Decode PARAMS as a property list of MIME parameter values. 262Return value is an association list of MIME parameter values. 263If parameter continuation is used, segments of values are concatenated. 264If parameters contain charset information, values are decoded. 265If parameters contain language information, it is set to `mime-language' 266property of the decoded-value." 267 ;; (unless (zerop (% (length params) 2)) ...) 268 (let ((len (/ (length params) 2)) 269 dest eparams) 270 (while params 271 (if (and (string-match (eval-when-compile 272 (concat "^\\(" mime-attribute-char-regexp "+\\)" 273 "\\(\\*[0-9]+\\)?" ; continuation 274 "\\(\\*\\)?$")) ; charset/language 275 (car params)) 276 (> (match-end 0) (match-end 1))) 277 ;; parameter value extensions are used. 278 (let* ((attribute (downcase 279 (substring (car params) 0 (match-end 1)))) 280 (section (if (match-beginning 2) 281 (string-to-number 282 (substring (car params) 283 (1+ (match-beginning 2)) 284 (match-end 2))) 285 0)) 286 ;; EPARAM := (ATTRIBUTE VALUES CHARSET LANGUAGE) 287 ;; VALUES := [1*VALUE] ; vector of LEN elements. 288 (eparam (assoc attribute eparams)) 289 (value (progn 290 (setq params (cdr params)) 291 (car params)))) 292 (if eparam 293 (setq eparam (cdr eparam)) 294 (setq eparam (list (make-vector len nil) nil nil) 295 eparams (cons (cons attribute eparam) eparams))) 296 ;; if parameter-name ends with "*", it is an extended-parameter. 297 (if (match-beginning 3) 298 (if (zerop section) 299 ;; extended-initial-parameter. 300 (if (string-match (eval-when-compile 301 (concat 302 "^\\(" mime-charset-regexp "\\)?" 303 "'\\(" mime-language-regexp "\\)?" 304 "'\\(\\(" mime-attribute-char-regexp 305 "\\|%[0-9A-Fa-f][0-9A-Fa-f]\\)+\\)$")) 306 value) 307 (progn 308 ;; text 309 (aset (car eparam) 0 310 (substring value (match-beginning 3))) 311 (setq eparam (cdr eparam)) 312 ;; charset 313 (when (match-beginning 1) 314 (setcar eparam 315 (downcase 316 (substring value 0 (match-end 1))))) 317 (setq eparam (cdr eparam)) 318 ;; language 319 (when (match-beginning 2) 320 (setcar eparam 321 (intern 322 (downcase 323 (substring value 324 (match-beginning 2) 325 (match-end 2))))))) 326 ;; invalid parameter-value. 327 (aset (car eparam) 0 328 (mime-decode-parameter-encode-segment value))) 329 ;; extended-other-parameter. 330 (if (string-match (eval-when-compile 331 (concat 332 "^\\(\\(" mime-attribute-char-regexp 333 "\\|%[0-9A-Fa-f][0-9A-Fa-f]\\)+\\)$")) 334 value) 335 (aset (car eparam) section value) 336 ;; invalid parameter-value. 337 (aset (car eparam) section 338 (mime-decode-parameter-encode-segment value)))) 339 ;; regular-parameter. parameter continuation only. 340 (aset (car eparam) section 341 (mime-decode-parameter-encode-segment value)))) 342 ;; parameter value extensions are not used, 343 ;; or invalid attribute-name (in RFC2231, although valid in RFC2045). 344 (setq dest (cons (cons (downcase (car params)) 345;;; ;; decode (invalid!) encoded-words. 346;;; (eword-decode-string 347;;; (decode-mime-charset-string 348;;; (car (cdr params)) 349;;; default-mime-charset) 350;;; 'must-unfold) 351 (car (cdr params))) 352 dest) 353 params (cdr params))) 354 (setq params (cdr params))) 355 ;; concat and decode parameters. 356 (while eparams 357 (setq dest (cons (cons (car (car eparams)) ; attribute 358 (mime-decode-parameter-value 359 (mapconcat (function identity) 360 (nth 1 (car eparams)) ; values 361 "") 362 (nth 2 (car eparams)) ; charset 363 (nth 3 (car eparams)) ; language 364 )) 365 dest) 366 eparams (cdr eparams))) 367 dest)) 368 369;;; for compatibility with flim-1_13-rfc2231 API. 370(defalias 'mime-parse-parameters-from-list 'mime-decode-parameters) 371(make-obsolete 'mime-parse-parameters-from-list 372 'mime-decode-parameters "28 Feb 2001") 373 374 375;;; @ parameter value encoder 376;;; 377 378(defun mime-divide-extended-parameter (name value) 379 "Divide MIME parameter value \"NAME=VALUE\" into segments. 380Each of \" NAME*n*=SEGMENT_n\;\" will be no more than 78 characters. 381Return value is a list of string when division is performed, otherwise 382return value is just a string." 383 ;; `limit' must be more than (length "CHARSET'LANGUAGE'%XX"). 384 ;; 385 ;; Since MIME spec does not limit either length of CHARSET or length 386 ;; of LANGUAGE, we choose 30 for minimum `limit' based on the longest 387 ;; name of charset that Emacs supports ("ISO-2022-CN-EXT"; 15 chars). 388 ;; 389 ;; Anyway, if `name' is too long, we will ignore 78 chars limit. 390 (let ((limit (max (- 78 4 (length name)) 30))); (length " *=;") => 4 391 (if (> limit (length value)) 392 value 393 (let ((count 0) 394 result) 395 (setq limit (max (- limit 2) 30)) ; (length "*n") => 2 396 (with-temp-buffer 397 (set-buffer-multibyte nil) 398 (insert value) 399 (while (> (point-max) limit) 400 (goto-char (- limit 3)) ; (length "%XX") => 3 401 (cond 402 ((eq (following-char) ?%) 403 (forward-char 3)) 404 ((progn 405 (forward-char) 406 (eq (following-char) ?%))) 407 ((progn 408 (forward-char) 409 (eq (following-char) ?%))) 410 (t 411 (forward-char))) 412 (setq result (cons (prog1 (buffer-substring (point-min)(point)) 413 (delete-region (point-min)(point))) 414 result) 415 count (1+ count)) 416 (when (zerop (% count 10)) 417 (setq limit (max (1- limit) 30)))) 418 (nreverse 419 (cons (buffer-substring (point-min)(point-max)) 420 result))))))) 421 422(defun mime-encode-extended-parameter (name value) 423 "Encode MIME parameter value \"NAME=VALUE\" as an extended-parameter. 424If encoding is unnecessary, return nil. 425If division is performed, return value is a list of string, otherwise 426return value is just a string." 427 (let ((language (get-text-property 0 'mime-language value))) 428 (when (or language 429 (string-match "[^ -~]" value)) ; Nonmatching printable US-ASCII. 430 (with-temp-buffer 431 (let ((charset (find-mime-charset-by-charsets 432 (find-charset-string value)))) 433 (setq value (mime-charset-encode-string value charset)) 434 (set-buffer-multibyte nil) 435 (insert value) 436 (goto-char (point-min)) 437 (insert (symbol-name charset) 438 ?' 439 (if language (symbol-name language) "") 440 ?') 441 (while (re-search-forward mime-non-attribute-char-regexp nil t) 442 (insert (prog1 (format "%%%02X" (preceding-char)) 443 (delete-region (1- (point))(point))))) 444 (mime-divide-extended-parameter name (buffer-string))))))) 445 446(defun mime-divide-regular-parameter (name value) 447 "Divide MIME parameter value \"NAME=VALUE\" into segments. 448Each of \" NAME*n=SEGMENT_n\;\" will be no more than 78 characters. 449Return value is a list of string when division is performed, otherwise 450just a string is returned." 451 (let ((limit (max (- (eval-when-compile (- 78 (length " =\"\";"))) 452 (length name)) 453 30))) 454 (if (> limit (length value)) 455 (concat "\"" value "\"") 456 (let ((count 0) 457 result) 458 (setq limit (max (- limit 2) 30)) ; (length "*n") => 2 459 (setq limit (1- limit)) ; XXX 460 (with-temp-buffer 461 (set-buffer-multibyte nil) 462 (insert value) 463 (while (> (point-max) limit) 464 (goto-char (point-min)) 465 (while (< (point) limit) 466 (when (eq (following-char) ?\\) 467 (forward-char)) 468 (forward-char)) 469 (setq result (cons (concat "\"" 470 (prog1 (buffer-substring 471 (point-min)(point)) 472 (delete-region 473 (point-min)(point))) 474 "\"") 475 result) 476 count (1+ count)) 477 (when (zerop (% count 10)) 478 (setq limit (max (1- limit) 30)))) 479 (nreverse 480 (cons (concat "\"" 481 (buffer-substring (point-min)(point-max)) 482 "\"") 483 result))))))) 484 485(defun mime-encode-regular-parameter (name value) 486 "Encode MIME parameter value \"NAME=VALUE\" as a regular-parameter. 487If division is performed, return value is a list of string, otherwise 488return value is just a string." 489 (with-temp-buffer 490 (set-buffer-multibyte nil) 491 (insert value) 492 (goto-char (point-min)) 493 (while (not (eobp)) 494 (when (memq (following-char) '(?\\ ?\")) 495 (insert ?\\)) 496 (forward-char 1)) 497 (mime-divide-regular-parameter name (buffer-string)))) 498 499(defun mime-encode-parameters (params) 500 "Encode PARAMS plist with MIME Parameter-Value Extensions. 501Return value is an alist of MIME parameter values." 502 (let (name value encoded result) 503 (while params 504 (setq name (car params) 505 value (car (cdr params)) 506 params (cdr (cdr params))) 507 (cond 508 ;; first two clauses are for backward compatibility, 509 ;; especially for "ftp.in" in the distribution. 510 ((not (string-match (eval-when-compile 511 (concat "^\\(" mime-attribute-char-regexp "+\\)" 512 "\\(\\*[0-9]+\\)?" ; continuation 513 "\\(\\*\\)?$")) ; charset/language 514 name)) 515 ;; invalid parameter name. 516 ;; XXX: Should we signal an error? 517 ) 518 ((> (match-end 0) (match-end 1)) 519 ;; this parameter value is already encoded. 520 (setq result (cons (cons name 521 (if (match-beginning 3) 522 ;; extended-parameter 523 value 524 ;; regular-parameter 525 (std11-wrap-as-quoted-string value))) 526 result))) 527 ((setq encoded (mime-encode-extended-parameter name value)) 528 ;; extended-parameter 529 (if (stringp encoded) 530 (setq result (cons (cons (concat name "*") encoded) result)) 531 ;; with continuation 532 (let ((section 0)) 533 (while encoded 534 (setq result (cons (cons (concat name 535 "*" (int-to-string section) 536 "*") 537 (car encoded)) 538 result) 539 section (1+ section) 540 encoded(cdr encoded)))))) 541 (t 542 ;; regular-parameter 543 (setq encoded (mime-encode-regular-parameter name value)) 544 (if (stringp encoded) 545 (setq result (cons (cons name encoded) result)) 546 ;; with continuation 547 (let ((section 0)) 548 (while encoded 549 (setq result (cons (cons (concat name 550 "*" (int-to-string section)) 551 (car encoded)) 552 result) 553 section (1+ section) 554 encoded (cdr encoded)))))))) 555 (nreverse result))) 556 557(provide 'mime-parse) 558(require 'eword-encode) 559 560(defun mime-encode-parameters-broken-mime (params) 561 "Encode PARAMS plist compatibly with Outlook. 562Return value is an alist of MIME parameter values." 563 (let (result) 564 (while (cadr params) 565 (setq result 566 `((,(car params) 567 . ,(eword-encode-string (cadr params) 568 (+ (length (car params)) 3))) 569 . ,result) 570 params (cddr params))) 571 (nreverse result))) 572 573 574;;; @ field parser 575;;; 576 577(defun mime-parse-parameters (tokens) 578 "Parse TOKENS as MIME parameter values. 579Return a property list, which is a list of the form 580\(PARAMETER-NAME1 VALUE1 PARAMETER-NAME2 VALUE2...)." 581 (let (params attribute) 582 (while (and tokens 583 (eq (car (car tokens)) 'tspecials) 584 (string= (cdr (car tokens)) ";") 585 (setq tokens (cdr tokens)) 586 (eq (car (car tokens)) 'mime-token) 587 (progn 588 (setq attribute (cdr (car tokens))) 589 (setq tokens (cdr tokens))) 590 (eq (car (car tokens)) 'tspecials) 591 (string= (cdr (car tokens)) "=") 592 (setq tokens (cdr tokens)) 593 (memq (car (car tokens)) '(mime-token quoted-string))) 594 (setq params (cons (if (eq (car (car tokens)) 'quoted-string) 595 (std11-strip-quoted-pair (cdr (car tokens))) 596 (cdr (car tokens))) 597 (cons attribute params)) 598 tokens (cdr tokens))) 599 (nreverse params))) 600 601 602;;; @@ Content-Type 603;;; 604 605;;;###autoload 606(defun mime-parse-Content-Type (field-body) 607 "Parse FIELD-BODY as a Content-Type field. 608FIELD-BODY is a string. 609Return value is a mime-content-type object. 610If FIELD-BODY is not a valid Content-Type field, return nil." 611 (let ((tokens (mime-lexical-analyze field-body))) 612 (when (eq (car (car tokens)) 'mime-token) 613 (let ((primary-type (cdr (car tokens)))) 614 (setq tokens (cdr tokens)) 615 (when (and (eq (car (car tokens)) 'tspecials) 616 (string= (cdr (car tokens)) "/") 617 (setq tokens (cdr tokens)) 618 (eq (car (car tokens)) 'mime-token)) 619 (make-mime-content-type 620 (intern (downcase primary-type)) 621 (intern (downcase (cdr (car tokens)))) 622 (mime-decode-parameters 623 (mime-parse-parameters (cdr tokens))))))))) 624 625;;;###autoload 626(defun mime-read-Content-Type () 627 "Parse field-body of Content-Type field of current-buffer. 628Return value is a mime-content-type object. 629If Content-Type field is not found, return nil." 630 (let ((field-body (std11-field-body "Content-Type"))) 631 (if field-body 632 (mime-parse-Content-Type field-body)))) 633 634 635;;; @@ Content-Disposition 636;;; 637 638;;;###autoload 639(defun mime-parse-Content-Disposition (field-body) 640 "Parse FIELD-BODY as a Content-Disposition field. 641FIELD-BODY is a string. 642Return value is a mime-content-disposition object. 643If FIELD-BODY is not a valid Content-Disposition field, return nil." 644 (let ((tokens (mime-lexical-analyze field-body))) 645 (when (eq (car (car tokens)) 'mime-token) 646 (make-mime-content-disposition 647 (intern (downcase (cdr (car tokens)))) 648 (mime-decode-parameters 649 (mime-parse-parameters (cdr tokens))))))) 650 651;;;###autoload 652(defun mime-read-Content-Disposition () 653 "Parse field-body of Content-Disposition field of current-buffer. 654Return value is a mime-content-disposition object. 655If Content-Disposition field is not found, return nil." 656 (let ((field-body (std11-field-body "Content-Disposition"))) 657 (if field-body 658 (mime-parse-Content-Disposition field-body)))) 659 660 661;;; @@ Content-Transfer-Encoding 662;;; 663 664;;;###autoload 665(defun mime-parse-Content-Transfer-Encoding (field-body) 666 "Parse FIELD-BODY as a Content-Transfer-Encoding field. 667FIELD-BODY is a string. 668Return value is a string. 669If FIELD-BODY is not a valid Content-Transfer-Encoding field, return nil." 670 (let ((tokens (mime-lexical-analyze field-body))) 671 (when (eq (car (car tokens)) 'mime-token) 672 (downcase (cdr (car tokens)))))) 673 674;;;###autoload 675(defun mime-read-Content-Transfer-Encoding () 676 "Parse field-body of Content-Transfer-Encoding field of current-buffer. 677Return value is a string. 678If Content-Transfer-Encoding field is not found, return nil." 679 (let ((field-body (std11-field-body "Content-Transfer-Encoding"))) 680 (if field-body 681 (mime-parse-Content-Transfer-Encoding field-body)))) 682 683 684;;; @@ Content-ID / Message-ID 685;;; 686 687;;;###autoload 688(defun mime-parse-msg-id (tokens) 689 "Parse TOKENS as msg-id of Content-ID or Message-ID field." 690 (car (std11-parse-msg-id tokens))) 691 692;;;###autoload 693(defun mime-uri-parse-cid (string) 694 "Parse STRING as cid URI." 695 (when (string-match "^cid:" string) 696 (setq string (concat "<" (substring string 4) ">")) 697 (let ((parser (cdr (assq 'Content-Id mime-field-parser-alist)))) 698 (if parser 699 (funcall parser (eword-lexical-analyze string)) 700 (mime-decode-field-body string 'Content-Id 'plain))))) 701 702 703 704;;; @ message parser 705;;; 706 707;; (defun mime-parse-multipart (entity) 708;; (with-current-buffer (mime-entity-body-buffer entity) 709;; (let* ((representation-type 710;; (mime-entity-representation-type-internal entity)) 711;; (content-type (mime-entity-content-type-internal entity)) 712;; (dash-boundary 713;; (concat "--" 714;; (mime-content-type-parameter content-type "boundary"))) 715;; (delimiter (concat "\n" (regexp-quote dash-boundary))) 716;; (close-delimiter (concat delimiter "--[ \t]*$")) 717;; (rsep (concat delimiter "[ \t]*\n")) 718;; (dc-ctl 719;; (if (eq (mime-content-type-subtype content-type) 'digest) 720;; (make-mime-content-type 'message 'rfc822) 721;; (make-mime-content-type 'text 'plain) 722;; )) 723;; (body-start (mime-entity-body-start-point entity)) 724;; (body-end (mime-entity-body-end-point entity))) 725;; (save-restriction 726;; (goto-char body-end) 727;; (narrow-to-region body-start 728;; (if (re-search-backward close-delimiter nil t) 729;; (match-beginning 0) 730;; body-end)) 731;; (goto-char body-start) 732;; (if (re-search-forward 733;; (concat "^" (regexp-quote dash-boundary) "[ \t]*\n") 734;; nil t) 735;; (let ((cb (match-end 0)) 736;; ce ncb ret children 737;; (node-id (mime-entity-node-id-internal entity)) 738;; (i 0)) 739;; (while (re-search-forward rsep nil t) 740;; (setq ce (match-beginning 0)) 741;; (setq ncb (match-end 0)) 742;; (save-restriction 743;; (narrow-to-region cb ce) 744;; (setq ret (mime-parse-message representation-type dc-ctl 745;; entity (cons i node-id))) 746;; ) 747;; (setq children (cons ret children)) 748;; (goto-char (setq cb ncb)) 749;; (setq i (1+ i)) 750;; ) 751;; (setq ce (point-max)) 752;; (save-restriction 753;; (narrow-to-region cb ce) 754;; (setq ret (mime-parse-message representation-type dc-ctl 755;; entity (cons i node-id))) 756;; ) 757;; (setq children (cons ret children)) 758;; (mime-entity-set-children-internal entity (nreverse children)) 759;; ) 760;; (mime-entity-set-content-type-internal 761;; entity (make-mime-content-type 'message 'x-broken)) 762;; nil) 763;; )))) 764 765;; (defun mime-parse-encapsulated (entity) 766;; (mime-entity-set-children-internal 767;; entity 768;; (with-current-buffer (mime-entity-body-buffer entity) 769;; (save-restriction 770;; (narrow-to-region (mime-entity-body-start-point entity) 771;; (mime-entity-body-end-point entity)) 772;; (list (mime-parse-message 773;; (mime-entity-representation-type-internal entity) nil 774;; entity (cons 0 (mime-entity-node-id-internal entity)))) 775;; )))) 776 777;; (defun mime-parse-external (entity) 778;; (require 'mmexternal) 779;; (mime-entity-set-children-internal 780;; entity 781;; (with-current-buffer (mime-entity-body-buffer entity) 782;; (save-restriction 783;; (narrow-to-region (mime-entity-body-start-point entity) 784;; (mime-entity-body-end-point entity)) 785;; (list (mime-parse-message 786;; 'mime-external-entity nil 787;; entity (cons 0 (mime-entity-node-id-internal entity)))) 788;; ;; [tomo] Should we unify with `mime-parse-encapsulated'? 789;; )))) 790 791(defun mime-parse-message (representation-type &optional default-ctl 792 parent node-id) 793 (let ((header-start (point-min)) 794 header-end 795 body-start 796 (body-end (point-max)) 797 content-type) 798 (goto-char header-start) 799 (if (re-search-forward "^$" nil t) 800 (setq header-end (match-end 0) 801 body-start (if (= header-end body-end) 802 body-end 803 (1+ header-end))) 804 (setq header-end (point-min) 805 body-start (point-min))) 806 (save-restriction 807 (narrow-to-region header-start header-end) 808 (setq content-type (or (mime-read-Content-Type) 809 default-ctl))) 810 (luna-make-entity representation-type 811 :location (current-buffer) 812 :content-type content-type 813 :parent parent 814 :node-id node-id 815 :buffer (current-buffer) 816 :header-start header-start 817 :header-end header-end 818 :body-start body-start 819 :body-end body-end))) 820 821 822;;; @ for buffer 823;;; 824 825;;;###autoload 826(defun mime-parse-buffer (&optional buffer representation-type) 827 "Parse BUFFER as a MIME message. 828If buffer is omitted, it parses current-buffer." 829 (require 'mmbuffer) 830 (save-excursion 831 (if buffer (set-buffer buffer)) 832 (mime-parse-message (or representation-type 833 'mime-buffer-entity) nil))) 834 835 836;;; @ end 837;;; 838 839(provide 'mime-parse) 840 841;;; mime-parse.el ends here 842