[bpt/emacs.git] / lisp / gnus / rfc1843.el

;;; rfc1843.el --- HZ (rfc1843) decoding

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
;; Keywords: news HZ HZ+ mail i18n

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Usage:
;; (require 'rfc1843)
;; (rfc1843-gnus-setup)
;;
;; Test:
;; (rfc1843-decode-string  "~{<:Ky2;S{#,NpJ)l6HK!#~}")

;;; Code:

;; For Emacs < 22.2.
(eval-and-compile
  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))

(eval-when-compile (require 'cl))
(require 'mm-util)

(defvar gnus-decode-encoded-word-function)
(defvar gnus-decode-header-function)
(defvar gnus-newsgroup-name)

(defvar rfc1843-word-regexp
  "~\\({\\([\041-\167][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")

(defvar rfc1843-word-regexp-strictly
  "~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\|$\\)")

(defvar rfc1843-hzp-word-regexp
  "~\\({\\([\041-\167][\041-\176]\\| \\)+\\|\
\[<>]\\([\041-\175][\041-\176]\\| \\)+\\)\\(~}\\|$\\)")

(defvar rfc1843-hzp-word-regexp-strictly
  "~\\({\\([\041-\167][\041-\176]\\)+\\|\
\[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\|$\\)")

(defcustom rfc1843-decode-loosely nil
  "Loosely check HZ encoding if non-nil.
When it is set non-nil, only buffers or strings with strictly
HZ-encoded are decoded."
  :type 'boolean
  :group 'mime)

(defcustom rfc1843-decode-hzp t
  "HZ+ decoding support if non-nil.
HZ+ specification (also known as HZP) is to provide a standardized
7-bit representation of mixed Big5, GB, and ASCII text for convenient
e-mail transmission, news posting, etc.
The document of HZ+ 0.78 specification can be found at
ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
  :type 'boolean
  :group 'mime)

(defcustom rfc1843-newsgroups-regexp "chinese\\|hz"
  "Regexp of newsgroups in which might be HZ encoded."
  :type 'string
  :group 'mime)

(defun rfc1843-decode-region (from to)
  "Decode HZ in the region between FROM and TO."
  (interactive "r")
  (let (str firstc)
    (save-excursion
      (goto-char from)
      (if (or rfc1843-decode-loosely
	      (re-search-forward (if rfc1843-decode-hzp
				     rfc1843-hzp-word-regexp-strictly
				   rfc1843-word-regexp-strictly) to t))
	  (save-restriction
	    (narrow-to-region from to)
	    (goto-char (point-min))
	    (while (re-search-forward (if rfc1843-decode-hzp
					  rfc1843-hzp-word-regexp
					rfc1843-word-regexp) (point-max) t)
	      ;;; Text with extents may cause XEmacs crash
	      (setq str (buffer-substring-no-properties
			 (match-beginning 1)
			 (match-end 1)))
	      (setq firstc (aref str 0))
	      (insert (mm-decode-coding-string
		       (rfc1843-decode
			(prog1
			    (substring str 1)
			  (delete-region (match-beginning 0) (match-end 0)))
			firstc)
		       (if (eq firstc ?{) 'cn-gb-2312 'cn-big5))))
	    (goto-char (point-min))
	    (while (search-forward "~" (point-max) t)
	      (cond ((eq (char-after) ?\n)
		     (delete-char -1)
		     (delete-char 1))
		    ((eq (char-after) ?~)
		     (delete-char 1)))))))))

(defun rfc1843-decode-string (string)
  "Decode HZ STRING and return the results."
  (let ((m (mm-multibyte-p)))
    (with-temp-buffer
      (when m
	(mm-enable-multibyte))
      (insert string)
      (inline
	(rfc1843-decode-region (point-min) (point-max)))
      (buffer-string))))

(defun rfc1843-decode (word &optional firstc)
  "Decode HZ WORD and return it."
  (let ((i -1) (s (substring word 0)) v)
    (if (or (not firstc) (eq firstc ?{))
	(while (< (incf i) (length s))
	  (if (eq (setq v (aref s i)) ? ) nil
	    (aset s i (+ 128 v))))
      (while (< (incf i) (length s))
	(if (eq (setq v (aref s i)) ? ) nil
	  (setq v (+ (* 94 v) (aref s (1+ i)) -3135))
	  (aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161)))
	  (setq v (% v 157))
	  (aset s (incf i) (+ v (if (< v 63) 64 98))))))
    s))

(autoload 'mail-header-parse-content-type "mail-parse")
(autoload 'message-narrow-to-head "message")
(declare-function message-fetch-field "message" (header &optional not-all))

(defun rfc1843-decode-article-body ()
  "Decode HZ encoded text in the article body."
  (if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
		    (or gnus-newsgroup-name ""))
      (save-excursion
	(save-restriction
	  (message-narrow-to-head)
	  (let* ((inhibit-point-motion-hooks t)
		 (case-fold-search t)
		 (ct (message-fetch-field "Content-Type" t))
		 (ctl (and ct (mail-header-parse-content-type ct))))
	    (if (and ctl (not (string-match "/" (car ctl))))
		(setq ctl nil))
	    (goto-char (point-max))
	    (widen)
	    (forward-line 1)
	    (narrow-to-region (point) (point-max))
	    (when (or (not ctl)
		      (equal (car ctl) "text/plain"))
	      (rfc1843-decode-region (point) (point-max))))))))

(defvar rfc1843-old-gnus-decode-header-function  nil)
(defvar gnus-decode-header-methods)
(defvar gnus-decode-encoded-word-methods)

(defun rfc1843-gnus-setup ()
  "Setup HZ decoding for Gnus."
  (require 'gnus-art)
  (require 'gnus-sum)
  (add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t)
  (setq gnus-decode-encoded-word-function
	'gnus-multi-decode-encoded-word-string
	gnus-decode-header-function
	'gnus-multi-decode-header
	gnus-decode-encoded-word-methods
	(nconc gnus-decode-encoded-word-methods
	       (list
		(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
		      'rfc1843-decode-string)))
	gnus-decode-header-methods
	(nconc gnus-decode-header-methods
	       (list
		(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
		      'rfc1843-decode-region)))))

(provide 'rfc1843)

;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687
;;; rfc1843.el ends here
Commit	Line	Data
c113de23	1	;;; rfc1843.el --- HZ (rfc1843) decoding
e84b4b86	2
b6c2d8c6	3	;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
e3fe4da0	4	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
c113de23 GM	5
	6	;; Author: Shenghuo Zhu <zsh@cs.rochester.edu>
	7	;; Keywords: news HZ HZ+ mail i18n
	8
715a2ca2	9	;; This file is part of GNU Emacs.
c113de23	10
5e809f55 GM	11	;; GNU Emacs is free software: you can redistribute it and/or modify
	12	;; it under the terms of the GNU General Public License as published by
	13	;; the Free Software Foundation, either version 3 of the License, or
	14	;; (at your option) any later version.
c113de23	15
5e809f55 GM	16	;; GNU Emacs is distributed in the hope that it will be useful,
	17	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	18	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	19	;; GNU General Public License for more details.
c113de23 GM	20
c113de23 GM	21	;; You should have received a copy of the GNU General Public License
5e809f55	22	;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
c113de23 GM	23
	24	;;; Commentary:
	25
	26	;; Usage:
	27	;; (require 'rfc1843)
	28	;; (rfc1843-gnus-setup)
	29	;;
	30	;; Test:
	31	;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}")
	32
	33	;;; Code:
	34
444f6b28 GM	35	;; For Emacs < 22.2.
	36	(eval-and-compile
	37	(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
	38
1391c567	39	(eval-when-compile (require 'cl))
c113de23 GM	40	(require 'mm-util)
c113de23 GM	41
2df35c02 JB	42	(defvar gnus-decode-encoded-word-function)
	43	(defvar gnus-decode-header-function)
	44	(defvar gnus-newsgroup-name)
	45
c113de23 GM	46	(defvar rfc1843-word-regexp
	47	"~\\({\\([\041-\167][\041-\176]\\\| \\)+\\)\\(~}\\\|$\\)")
	48
	49	(defvar rfc1843-word-regexp-strictly
	50	"~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\\|$\\)")
	51
	52	(defvar rfc1843-hzp-word-regexp
	53	"~\\({\\([\041-\167][\041-\176]\\\| \\)+\\\|\
23f87bed	54	\[<>]\\([\041-\175][\041-\176]\\\| \\)+\\)\\(~}\\\|$\\)")
c113de23 GM	55
	56	(defvar rfc1843-hzp-word-regexp-strictly
	57	"~\\({\\([\041-\167][\041-\176]\\)+\\\|\
23f87bed	58	\[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\\|$\\)")
c113de23 GM	59
	60	(defcustom rfc1843-decode-loosely nil
	61	"Loosely check HZ encoding if non-nil.
	62	When it is set non-nil, only buffers or strings with strictly
	63	HZ-encoded are decoded."
	64	:type 'boolean
23f87bed	65	:group 'mime)
c113de23 GM	66
	67	(defcustom rfc1843-decode-hzp t
	68	"HZ+ decoding support if non-nil.
	69	HZ+ specification (also known as HZP) is to provide a standardized
	70	7-bit representation of mixed Big5, GB, and ASCII text for convenient
	71	e-mail transmission, news posting, etc.
	72	The document of HZ+ 0.78 specification can be found at
	73	ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
	74	:type 'boolean
23f87bed	75	:group 'mime)
c113de23 GM	76
	77	(defcustom rfc1843-newsgroups-regexp "chinese\\\|hz"
	78	"Regexp of newsgroups in which might be HZ encoded."
	79	:type 'string
23f87bed	80	:group 'mime)
c113de23 GM	81
	82	(defun rfc1843-decode-region (from to)
	83	"Decode HZ in the region between FROM and TO."
	84	(interactive "r")
	85	(let (str firstc)
	86	(save-excursion
	87	(goto-char from)
	88	(if (or rfc1843-decode-loosely
	89	(re-search-forward (if rfc1843-decode-hzp
	90	rfc1843-hzp-word-regexp-strictly
	91	rfc1843-word-regexp-strictly) to t))
	92	(save-restriction
	93	(narrow-to-region from to)
	94	(goto-char (point-min))
	95	(while (re-search-forward (if rfc1843-decode-hzp
	96	rfc1843-hzp-word-regexp
	97	rfc1843-word-regexp) (point-max) t)
	98	;;; Text with extents may cause XEmacs crash
a1506d29	99	(setq str (buffer-substring-no-properties
c113de23 GM	100	(match-beginning 1)
	101	(match-end 1)))
	102	(setq firstc (aref str 0))
	103	(insert (mm-decode-coding-string
	104	(rfc1843-decode
	105	(prog1
	106	(substring str 1)
	107	(delete-region (match-beginning 0) (match-end 0)))
	108	firstc)
	109	(if (eq firstc ?{) 'cn-gb-2312 'cn-big5))))
	110	(goto-char (point-min))
	111	(while (search-forward "~" (point-max) t)
	112	(cond ((eq (char-after) ?\n)
	113	(delete-char -1)
	114	(delete-char 1))
	115	((eq (char-after) ?~)
	116	(delete-char 1)))))))))
	117
	118	(defun rfc1843-decode-string (string)
	119	"Decode HZ STRING and return the results."
	120	(let ((m (mm-multibyte-p)))
	121	(with-temp-buffer
	122	(when m
	123	(mm-enable-multibyte))
	124	(insert string)
	125	(inline
	126	(rfc1843-decode-region (point-min) (point-max)))
	127	(buffer-string))))
	128
	129	(defun rfc1843-decode (word &optional firstc)
	130	"Decode HZ WORD and return it."
	131	(let ((i -1) (s (substring word 0)) v)
	132	(if (or (not firstc) (eq firstc ?{))
	133	(while (< (incf i) (length s))
	134	(if (eq (setq v (aref s i)) ? ) nil
	135	(aset s i (+ 128 v))))
	136	(while (< (incf i) (length s))
	137	(if (eq (setq v (aref s i)) ? ) nil
	138	(setq v (+ (* 94 v) (aref s (1+ i)) -3135))
	139	(aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161)))
	140	(setq v (% v 157))
	141	(aset s (incf i) (+ v (if (< v 63) 64 98))))))
	142	s))
	143
444f6b28 GM	144	(autoload 'mail-header-parse-content-type "mail-parse")
	145	(autoload 'message-narrow-to-head "message")
	146	(declare-function message-fetch-field "message" (header &optional not-all))
	147
c113de23 GM	148	(defun rfc1843-decode-article-body ()
	149	"Decode HZ encoded text in the article body."
	150	(if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	151	(or gnus-newsgroup-name ""))
	152	(save-excursion
	153	(save-restriction
	154	(message-narrow-to-head)
	155	(let* ((inhibit-point-motion-hooks t)
	156	(case-fold-search t)
	157	(ct (message-fetch-field "Content-Type" t))
c96ec15a	158	(ctl (and ct (mail-header-parse-content-type ct))))
a1506d29	159	(if (and ctl (not (string-match "/" (car ctl))))
c113de23 GM	160	(setq ctl nil))
	161	(goto-char (point-max))
	162	(widen)
	163	(forward-line 1)
	164	(narrow-to-region (point) (point-max))
	165	(when (or (not ctl)
	166	(equal (car ctl) "text/plain"))
	167	(rfc1843-decode-region (point) (point-max))))))))
	168
	169	(defvar rfc1843-old-gnus-decode-header-function nil)
	170	(defvar gnus-decode-header-methods)
	171	(defvar gnus-decode-encoded-word-methods)
	172
	173	(defun rfc1843-gnus-setup ()
	174	"Setup HZ decoding for Gnus."
	175	(require 'gnus-art)
	176	(require 'gnus-sum)
	177	(add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t)
	178	(setq gnus-decode-encoded-word-function
	179	'gnus-multi-decode-encoded-word-string
	180	gnus-decode-header-function
	181	'gnus-multi-decode-header
	182	gnus-decode-encoded-word-methods
	183	(nconc gnus-decode-encoded-word-methods
	184	(list
	185	(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	186	'rfc1843-decode-string)))
	187	gnus-decode-header-methods
	188	(nconc gnus-decode-header-methods
	189	(list
	190	(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	191	'rfc1843-decode-region)))))
	192
	193	(provide 'rfc1843)
	194
cbee283d	195	;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687
c113de23	196	;;; rfc1843.el ends here