$NetBSD: patch-eword-decode.el,v 1.1 2023/09/03 14:58:38 mef Exp $ flim-1_14-wl branch at 2023-08-08 --- /tmp/W/devel/flim/work/flim-1.14.9/eword-decode.el 2005-12-25 19:45:52.000000000 +0900 +++ ./eword-decode.el 2023-08-31 08:29:38.587163972 +0900 @@ -1,4 +1,4 @@ -;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs +;;; eword-decode.el --- RFC 2047 based encoded-word decoder for GNU Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, ;; 2005 Free Software Foundation, Inc. @@ -36,8 +36,7 @@ (require 'mime-def) (require 'mel) (require 'std11) - -(eval-when-compile (require 'cl)) ; list*, pop +(require 'cl-lib) ;;; @ Variables @@ -70,8 +69,7 @@ "\\(" eword-encoded-text-regexp ; 4 "\\)" - (regexp-quote "?=")))) - ) + (regexp-quote "?="))))) ;;; @ for string @@ -87,7 +85,10 @@ If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape)." +such as a version of Net$cape). + +The language informations specified in the encoded words, if any, are +put to the decoded text as the `mime-language' text property." (setq string (std11-unfold-string string)) (let ((regexp (concat "[\n\t ]*\\(" eword-encoded-word-regexp "\\)")) (next 0) @@ -98,7 +99,11 @@ (while match (setq next (match-end 0)) (push (list (match-string 2 string) ;; charset - (match-string 3 string) ;; language + (when (match-beginning 3) ;; language + (intern + (downcase + (substring string + (1+ (match-beginning 3)) (match-end 3))))) (match-string 4 string) ;; encoding (match-string 5 string) ;; encoded-text (match-string 1 string)) ;; encoded-word @@ -112,23 +117,19 @@ next (+ start (length words))))) string) -(defun eword-decode-structured-field-body (string - &optional start-column max-column - start) +(defun eword-decode-structured-field-body + (string &optional _start-column _max-column start) (let ((tokens (eword-lexical-analyze string start 'must-unfold)) - (result "") + result token) (while tokens (setq token (car tokens)) - (setq result (concat result (eword-decode-token token))) + (setq result (cons (eword-decode-token token) result)) (setq tokens (cdr tokens))) - result)) + (apply 'concat (nreverse result)))) -(defun eword-decode-and-unfold-structured-field-body (string - &optional - start-column - max-column - start) +(defun eword-decode-and-unfold-structured-field-body + (string &optional _start-column _max-column start) "Decode and unfold STRING as structured field body. It decodes non us-ascii characters in FULL-NAME encoded as encoded-words or invalid \"raw\" string. \"Raw\" non us-ascii @@ -137,17 +138,17 @@ If an encoded-word is broken or your emacs implementation can not decode the charset included in it, it is not decoded." (let ((tokens (eword-lexical-analyze string start 'must-unfold)) - (result "")) + result) (while tokens (let* ((token (car tokens)) (type (car token))) (setq tokens (cdr tokens)) (setq result - (if (eq type 'spaces) - (concat result " ") - (concat result (eword-decode-token token)) - )))) - result)) + (cons (if (eq type 'spaces) + " " + (eword-decode-token token)) + result)))) + (apply 'concat (nreverse result)))) (defun eword-decode-and-fold-structured-field-body (string start-column @@ -160,7 +161,7 @@ (setq max-column fill-column)) (let ((c start-column) (tokens (eword-lexical-analyze string start 'must-unfold)) - (result "") + result token) (while (and (setq token (car tokens)) (setq tokens (cdr tokens))) @@ -171,38 +172,34 @@ (next-len (string-width next-str)) (next-c (+ c next-len 1))) (if (< next-c max-column) - (setq result (concat result " " next-str) + (setq result (cons next-str (cons " " result)) c next-c) - (setq result (concat result "\n " next-str) + (setq result (cons next-str (cons "\n " result)) c (1+ next-len))) - (setq tokens (cdr tokens)) - ) + (setq tokens (cdr tokens))) (let* ((str (eword-decode-token token))) - (setq result (concat result str) - c (+ c (string-width str))) - )))) - (if token - (concat result (eword-decode-token token)) - result)))) + (setq result (cons str result) + c (+ c (string-width str))))))) + (apply 'concat (nreverse + (cons (when token (eword-decode-token token)) + result)))))) -(defun eword-decode-unstructured-field-body (string &optional start-column - max-column) +(defun eword-decode-unstructured-field-body + (string &optional _start-column _max-column) (eword-decode-string - (decode-mime-charset-string string default-mime-charset))) + (mime-charset-decode-string string default-mime-charset))) -(defun eword-decode-and-unfold-unstructured-field-body (string - &optional start-column - max-column) +(defun eword-decode-and-unfold-unstructured-field-body + (string &optional _start-column _max-column) (eword-decode-string - (decode-mime-charset-string (std11-unfold-string string) + (mime-charset-decode-string (std11-unfold-string string) default-mime-charset) 'must-unfold)) -(defun eword-decode-unfolded-unstructured-field-body (string - &optional start-column - max-column) +(defun eword-decode-unfolded-unstructured-field-body + (string &optional _start-column _max-column) (eword-decode-string - (decode-mime-charset-string string default-mime-charset) + (mime-charset-decode-string string default-mime-charset) 'must-unfold)) @@ -216,7 +213,10 @@ If MUST-UNFOLD is non-nil, it unfolds and eliminates line-breaks even if there are in decoded encoded-words (generated by bad manner MUA -such as a version of Net$cape)." +such as a version of Net$cape). + +The language informations specified in the encoded words, if any, are +put to the decoded text as the `mime-language' text property." (interactive "*r") (save-excursion (save-restriction @@ -232,7 +232,11 @@ (while match (goto-char (setq end (match-end 0))) (push (list (match-string 2) ;; charset - (match-string 3) ;; language + (when (match-beginning 3) ;; language + (intern + (downcase + (buffer-substring (1+ (match-beginning 3)) + (match-end 3))))) (match-string 4) ;; encoding (match-string 5) ;; encoded-text (match-string 1)) ;; encoded-word @@ -253,11 +257,8 @@ (save-restriction (narrow-to-region (goto-char beg) end) (while (re-search-forward "\n\\([ \t]\\)" nil t) - (replace-match (match-string 1)) - ) - (goto-char (point-max)) - )) - ))) + (replace-match (match-string 1))) + (goto-char (point-max))))))) ;;; @ for message header @@ -286,16 +287,13 @@ (setcdr cell (put-alist field function (cdr cell))) (setq mime-field-decoder-alist (cons (cons mode (list (cons field function))) - mime-field-decoder-alist)) - )) - (apply (function mime-set-field-decoder) field specs) - ) + mime-field-decoder-alist)))) + (apply (function mime-set-field-decoder) field specs)) (mime-set-field-decoder field 'plain function 'wide function 'summary function - 'nov function) - )))) + 'nov function))))) ;;;###autoload (defmacro mime-find-field-presentation-method (name) @@ -303,20 +301,17 @@ NAME must be `plain', `wide', `summary' or `nov'." (cond ((eq name nil) `(or (assq 'summary mime-field-decoder-cache) - '(summary)) - ) + '(summary))) ((and (consp name) (car name) (consp (cdr name)) (symbolp (car (cdr name))) (null (cdr (cdr name)))) `(or (assq ,name mime-field-decoder-cache) - (cons ,name nil)) - ) + (cons ,name nil))) (t `(or (assq (or ,name 'summary) mime-field-decoder-cache) - (cons (or ,name 'summary) nil)) - ))) + (cons (or ,name 'summary) nil))))) (defun mime-find-field-decoder-internal (field &optional mode) "Return function to decode field-body of FIELD in MODE. @@ -326,8 +321,7 @@ (funcall mime-update-field-decoder-cache field (car mode)) (setcdr mode - (cdr (assq (car mode) mime-field-decoder-cache))) - )))) + (cdr (assq (car mode) mime-field-decoder-cache))))))) ;;;###autoload (defun mime-find-field-decoder (field &optional mode) @@ -342,21 +336,18 @@ (cdr p) (cdr (funcall mime-update-field-decoder-cache field (or mode 'summary))))) - (inline (mime-find-field-decoder-internal field mode)) - )) + (inline (mime-find-field-decoder-internal field mode)))) ;;;###autoload (defun mime-update-field-decoder-cache (field mode &optional function) "Update field decoder cache `mime-field-decoder-cache'." (cond ((eq function 'identity) - (setq function nil) - ) + (setq function nil)) ((null function) (let ((decoder-alist (cdr (assq (or mode 'summary) mime-field-decoder-alist)))) (setq function (cdr (or (assq field decoder-alist) - (assq t decoder-alist))))) - )) + (assq t decoder-alist))))))) (let ((cell (assq mode mime-field-decoder-cache)) ret) (if cell @@ -407,8 +398,7 @@ 'plain #'eword-decode-structured-field-body 'wide #'eword-decode-and-fold-structured-field-body 'summary #'eword-decode-and-unfold-structured-field-body - 'nov #'eword-decode-and-unfold-structured-field-body) - )) + 'nov #'eword-decode-and-unfold-structured-field-body))) ;; unstructured fields (default) (mime-set-field-decoder @@ -442,8 +432,7 @@ ;; Don't decode (if (eq mode 'summary) (std11-unfold-string field-body) - field-body) - ))) + field-body)))) ;;;###autoload (defun mime-decode-header-in-region (start end @@ -480,11 +469,8 @@ (let ((body (buffer-substring p end)) (default-mime-charset default-charset)) (delete-region p end) - (insert (funcall field-decoder body (1+ len))) - )) - )) - (eword-decode-region (point-min) (point-max) t) - ))))) + (insert (funcall field-decoder body (1+ len))))))) + (eword-decode-region (point-min) (point-max) t)))))) ;;;###autoload (defun mime-decode-header-in-buffer (&optional code-conversion separator) @@ -503,12 +489,12 @@ (concat "^\\(" (regexp-quote (or separator "")) "\\)?$") nil t) (match-beginning 0) - (point-max) - )) + (point-max))) code-conversion)) (defalias 'eword-decode-header 'mime-decode-header-in-buffer) -(make-obsolete 'eword-decode-header 'mime-decode-header-in-buffer) +(make-obsolete 'eword-decode-header + 'mime-decode-header-in-buffer "28 Oct 1998") ;;; @ encoded-words decoder @@ -554,39 +540,38 @@ nil))) (if (and eword-decode-allow-incomplete-encoded-text rest - (caaar rest) - (string-equal (downcase charset) (downcase (caaar rest))) - (equal language (cdaar rest))) + (cl-caaar rest) + (string-equal (downcase charset) (downcase (cl-caaar rest))) + (equal language (cl-cdaar rest))) ;; Concatenate text of which the charset is the same. (setcdr (car rest) (concat (cdar rest) text)) (push (cons (cons charset language) text) rest)) ;; Don't decode encoded-word. (push (cons (cons nil language) (nth 4 word)) rest))) (while rest - (setq word (or (and (setq charset (caaar rest)) + (setq word (or (and (setq charset (cl-caaar rest)) (condition-case err - (decode-mime-charset-string (cdar rest) charset) + (mime-charset-decode-string (cdar rest) charset) (error (message "%s" (error-message-string err)) nil))) - (concat (when (cdr rest) " ") - (cdar rest) - (when (and words - (not (eq (string-to-char words) ? ))) - " ")))) + (concat + (when (cdr rest) " ") + (cdar rest) + (when (and words + (not (eq (string-to-char (car words)) ?\s))) + " ")))) (when must-unfold (setq word (mapconcat (lambda (chr) - (cond ((eq chr ?\n) "") - ((eq chr ?\r) "") + (cond ((memq chr '(?\n ?\r)) nil) ((eq chr ?\t) " ") - (t (char-to-string chr)))) - (std11-unfold-string word) - ""))) - (when (setq language (cdaar rest)) + (t (list chr)))) + (std11-unfold-string word) nil))) + (when (setq language (cl-cdaar rest)) (put-text-property 0 (length word) 'mime-language language word)) - (setq words (concat word words) - rest (cdr rest))) - words)) + (when (> (length word) 0) (setq words (cons word words))) + (setq rest (cdr rest))) + (apply 'concat words))) ;;; @ lexical analyze ;;; @@ -618,11 +603,11 @@ returns nil, next function is used. Otherwise the return value will be the result.") -(defun eword-analyze-quoted-string (string start &optional must-unfold) +(defun eword-analyze-quoted-string (string start &optional _must-unfold) (let ((p (std11-check-enclosure string ?\" ?\" nil start)) ret) (when p - (setq ret (decode-mime-charset-string + (setq ret (mime-charset-decode-string (std11-strip-quoted-pair (substring string (1+ start) (1- p))) default-mime-charset)) @@ -631,7 +616,7 @@ (cons (cons 'quoted-string ret) p)))) -(defun eword-analyze-domain-literal (string start &optional must-unfold) +(defun eword-analyze-domain-literal (string start &optional _must-unfold) (std11-analyze-domain-literal string start)) (defun eword-analyze-comment (string from &optional must-unfold) @@ -649,17 +634,16 @@ (cond ((eq chr ?\\) (setq i (1+ i)) (if (>= i len) - (throw 'tag nil) - ) - (setq last-str (concat last-str - (substring string from (1- i)) - (char-to-string (aref string i))) + (throw 'tag nil)) + (setq last-str (cons (list (aref string i)) + (cons (substring string from (1- i)) + last-str)) i (1+ i) - from i) - ) + from i)) ((eq chr ?\)) - (setq ret (concat last-str - (substring string from i))) + (setq ret + (apply 'concat + (substring string from i) (nreverse last-str))) (throw 'tag (cons (cons 'comment (nreverse @@ -667,42 +651,36 @@ dest (cons (eword-decode-string - (decode-mime-charset-string + (mime-charset-decode-string ret default-mime-charset) must-unfold) - dest) - ))) - (1+ i))) - ) + dest)))) + (1+ i)))) ((eq chr ?\() (if (setq ret (eword-analyze-comment string i must-unfold)) (setq last-str - (concat last-str - (substring string from i)) + (apply 'concat (substring string from i) + (nreverse last-str)) dest (if (string= last-str "") (cons (car ret) dest) - (list* (car ret) + (cl-list* (car ret) (eword-decode-string - (decode-mime-charset-string + (mime-charset-decode-string last-str default-mime-charset) must-unfold) - dest) - ) + dest)) i (cdr ret) from i - last-str "") - (throw 'tag nil) - )) + last-str nil) + (throw 'tag nil))) (t - (setq i (1+ i)) - )) - ))))) + (setq i (1+ i))))))))) -(defun eword-analyze-spaces (string start &optional must-unfold) +(defun eword-analyze-spaces (string start &optional _must-unfold) (std11-analyze-spaces string start)) -(defun eword-analyze-special (string start &optional must-unfold) +(defun eword-analyze-special (string start &optional _must-unfold) (std11-analyze-special string start)) (defun eword-analyze-encoded-word (string start &optional must-unfold) @@ -713,7 +691,11 @@ (while match (setq next (match-end 0)) (push (list (match-string 2 string) ;; charset - (match-string 3 string) ;; language + (when (match-beginning 3) ;; language + (intern + (downcase + (substring string + (1+ (match-beginning 3)) (match-end 3))))) (match-string 4 string) ;; encoding (match-string 5 string) ;; encoded-text (match-string 1 string)) ;; encoded-word @@ -721,20 +703,29 @@ (setq match (and (string-match regexp string next) (= next (match-beginning 0))))) (when words - (cons (cons 'atom (eword-decode-encoded-words (nreverse words) - must-unfold)) - next)))) + (setq words (eword-decode-encoded-words (nreverse words) must-unfold)) + (cons + (cons 'atom + (if (and (string-match (eval-when-compile + (concat "[" std11-special-char-list "]")) + words) + (null (eq (cdr (std11-analyze-quoted-string words 0)) + (length words)))) + ;; Docoded words contains non-atom special chars and are + ;; not quoted. + (std11-wrap-as-quoted-string words) + words)) + next)))) -(defun eword-analyze-atom (string start &optional must-unfold) +(defun eword-analyze-atom (string start &optional _must-unfold) (if (and (string-match std11-atom-regexp string start) (= (match-beginning 0) start)) (let ((end (match-end 0))) - (cons (cons 'atom (decode-mime-charset-string + (cons (cons 'atom (mime-charset-decode-string (substring string start end) default-mime-charset)) ;;(substring string end) - end) - ))) + end)))) (defun eword-lexical-analyze-internal (string start must-unfold) (let ((len (length string)) @@ -745,17 +736,13 @@ func r) (while (and (setq func (car rest)) (null - (setq r (funcall func string start must-unfold))) - ) + (setq r (funcall func string start must-unfold)))) (setq rest (cdr rest))) (or r - (cons (cons 'error (substring string start)) (1+ len))) - )) + (cons (cons 'error (substring string start)) (1+ len))))) (setq dest (cons (car ret) dest) - start (cdr ret)) - ) - (nreverse dest) - )) + start (cdr ret))) + (nreverse dest))) (defun eword-lexical-analyze (string &optional start must-unfold) "Return lexical analyzed list corresponding STRING. @@ -763,18 +750,17 @@ characters encoded as encoded-words or invalid \"raw\" format. \"Raw\" non us-ascii characters are regarded as variable `default-mime-charset'." - (let ((key (substring string (or start 0))) + (let ((key (substring-no-properties string start)) ret cell) - (set-text-properties 0 (length key) nil key) (if (setq ret (assoc key eword-lexical-analyze-cache)) (cdr ret) - (setq ret (eword-lexical-analyze-internal key 0 must-unfold)) - (setq eword-lexical-analyze-cache + (setq ret (eword-lexical-analyze-internal key 0 must-unfold) + eword-lexical-analyze-cache (cons (cons key ret) eword-lexical-analyze-cache)) - (if (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max - eword-lexical-analyze-cache))) - (setcdr cell nil)) + (when (cdr (setq cell (nthcdr eword-lexical-analyze-cache-max + eword-lexical-analyze-cache))) + (setcdr cell nil)) ret))) (defun eword-decode-token (token) @@ -783,18 +769,15 @@ (cond ((eq type 'quoted-string) (std11-wrap-as-quoted-string value)) ((eq type 'comment) - (let ((dest "")) + (let (dest) (while value - (setq dest (concat dest - (if (stringp (car value)) - (std11-wrap-as-quoted-pairs - (car value) '(?( ?))) - (eword-decode-token (car value)) - )) - value (cdr value)) - ) - (concat "(" dest ")") - )) + (setq dest (cons (if (stringp (car value)) + (std11-wrap-as-quoted-pairs + (car value) '(?\( ?\))) + (eword-decode-token (car value))) + dest) + value (cdr value))) + (apply 'concat "(" (nreverse (cons ")" dest))))) (t value)))) (defun eword-extract-address-components (string &optional start) @@ -809,10 +792,8 @@ (std11-unfold-string string) start 'must-unfold)))) (phrase (std11-full-name-string structure)) - (address (std11-address-string structure)) - ) - (list phrase address) - )) + (address (std11-address-string structure))) + (list phrase address))) ;;; @ end