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

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

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006 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 2, 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; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

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

;;; Code:

(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))

(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,
88e6695f	4	;; 2005, 2006 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 GM	10
	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
	13	;; by the Free Software Foundation; either version 2, or (at your
	14	;; option) any later version.
	15
	16	;; GNU Emacs 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
3a35cf56 LK	23	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
3a35cf56 LK	24	;; Boston, MA 02110-1301, USA.
c113de23 GM	25
	26	;;; Commentary:
	27
	28	;; Usage:
	29	;; (require 'rfc1843)
	30	;; (rfc1843-gnus-setup)
	31	;;
	32	;; Test:
	33	;; (rfc1843-decode-string "~{<:Ky2;S{#,NpJ)l6HK!#~}")
	34
	35	;;; Code:
	36
1391c567	37	(eval-when-compile (require 'cl))
c113de23 GM	38	(require 'mm-util)
c113de23 GM	39
2df35c02 JB	40	(defvar gnus-decode-encoded-word-function)
	41	(defvar gnus-decode-header-function)
	42	(defvar gnus-newsgroup-name)
	43
c113de23 GM	44	(defvar rfc1843-word-regexp
	45	"~\\({\\([\041-\167][\041-\176]\\\| \\)+\\)\\(~}\\\|$\\)")
	46
	47	(defvar rfc1843-word-regexp-strictly
	48	"~\\({\\([\041-\167][\041-\176]\\)+\\)\\(~}\\\|$\\)")
	49
	50	(defvar rfc1843-hzp-word-regexp
	51	"~\\({\\([\041-\167][\041-\176]\\\| \\)+\\\|\
23f87bed	52	\[<>]\\([\041-\175][\041-\176]\\\| \\)+\\)\\(~}\\\|$\\)")
c113de23 GM	53
	54	(defvar rfc1843-hzp-word-regexp-strictly
	55	"~\\({\\([\041-\167][\041-\176]\\)+\\\|\
23f87bed	56	\[<>]\\([\041-\175][\041-\176]\\)+\\)\\(~}\\\|$\\)")
c113de23 GM	57
	58	(defcustom rfc1843-decode-loosely nil
	59	"Loosely check HZ encoding if non-nil.
	60	When it is set non-nil, only buffers or strings with strictly
	61	HZ-encoded are decoded."
	62	:type 'boolean
23f87bed	63	:group 'mime)
c113de23 GM	64
	65	(defcustom rfc1843-decode-hzp t
	66	"HZ+ decoding support if non-nil.
	67	HZ+ specification (also known as HZP) is to provide a standardized
	68	7-bit representation of mixed Big5, GB, and ASCII text for convenient
	69	e-mail transmission, news posting, etc.
	70	The document of HZ+ 0.78 specification can be found at
	71	ftp://ftp.math.psu.edu/pub/simpson/chinese/hzp/hzp.doc"
	72	:type 'boolean
23f87bed	73	:group 'mime)
c113de23 GM	74
	75	(defcustom rfc1843-newsgroups-regexp "chinese\\\|hz"
	76	"Regexp of newsgroups in which might be HZ encoded."
	77	:type 'string
23f87bed	78	:group 'mime)
c113de23 GM	79
	80	(defun rfc1843-decode-region (from to)
	81	"Decode HZ in the region between FROM and TO."
	82	(interactive "r")
	83	(let (str firstc)
	84	(save-excursion
	85	(goto-char from)
	86	(if (or rfc1843-decode-loosely
	87	(re-search-forward (if rfc1843-decode-hzp
	88	rfc1843-hzp-word-regexp-strictly
	89	rfc1843-word-regexp-strictly) to t))
	90	(save-restriction
	91	(narrow-to-region from to)
	92	(goto-char (point-min))
	93	(while (re-search-forward (if rfc1843-decode-hzp
	94	rfc1843-hzp-word-regexp
	95	rfc1843-word-regexp) (point-max) t)
	96	;;; Text with extents may cause XEmacs crash
a1506d29	97	(setq str (buffer-substring-no-properties
c113de23 GM	98	(match-beginning 1)
	99	(match-end 1)))
	100	(setq firstc (aref str 0))
	101	(insert (mm-decode-coding-string
	102	(rfc1843-decode
	103	(prog1
	104	(substring str 1)
	105	(delete-region (match-beginning 0) (match-end 0)))
	106	firstc)
	107	(if (eq firstc ?{) 'cn-gb-2312 'cn-big5))))
	108	(goto-char (point-min))
	109	(while (search-forward "~" (point-max) t)
	110	(cond ((eq (char-after) ?\n)
	111	(delete-char -1)
	112	(delete-char 1))
	113	((eq (char-after) ?~)
	114	(delete-char 1)))))))))
	115
	116	(defun rfc1843-decode-string (string)
	117	"Decode HZ STRING and return the results."
	118	(let ((m (mm-multibyte-p)))
	119	(with-temp-buffer
	120	(when m
	121	(mm-enable-multibyte))
	122	(insert string)
	123	(inline
	124	(rfc1843-decode-region (point-min) (point-max)))
	125	(buffer-string))))
	126
	127	(defun rfc1843-decode (word &optional firstc)
	128	"Decode HZ WORD and return it."
	129	(let ((i -1) (s (substring word 0)) v)
	130	(if (or (not firstc) (eq firstc ?{))
	131	(while (< (incf i) (length s))
	132	(if (eq (setq v (aref s i)) ? ) nil
	133	(aset s i (+ 128 v))))
	134	(while (< (incf i) (length s))
	135	(if (eq (setq v (aref s i)) ? ) nil
	136	(setq v (+ (* 94 v) (aref s (1+ i)) -3135))
	137	(aset s i (+ (/ v 157) (if (eq firstc ?<) 201 161)))
	138	(setq v (% v 157))
	139	(aset s (incf i) (+ v (if (< v 63) 64 98))))))
	140	s))
	141
	142	(defun rfc1843-decode-article-body ()
	143	"Decode HZ encoded text in the article body."
	144	(if (string-match (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	145	(or gnus-newsgroup-name ""))
	146	(save-excursion
	147	(save-restriction
	148	(message-narrow-to-head)
	149	(let* ((inhibit-point-motion-hooks t)
	150	(case-fold-search t)
	151	(ct (message-fetch-field "Content-Type" t))
c96ec15a	152	(ctl (and ct (mail-header-parse-content-type ct))))
a1506d29	153	(if (and ctl (not (string-match "/" (car ctl))))
c113de23 GM	154	(setq ctl nil))
	155	(goto-char (point-max))
	156	(widen)
	157	(forward-line 1)
	158	(narrow-to-region (point) (point-max))
	159	(when (or (not ctl)
	160	(equal (car ctl) "text/plain"))
	161	(rfc1843-decode-region (point) (point-max))))))))
	162
	163	(defvar rfc1843-old-gnus-decode-header-function nil)
	164	(defvar gnus-decode-header-methods)
	165	(defvar gnus-decode-encoded-word-methods)
	166
	167	(defun rfc1843-gnus-setup ()
	168	"Setup HZ decoding for Gnus."
	169	(require 'gnus-art)
	170	(require 'gnus-sum)
	171	(add-hook 'gnus-article-decode-hook 'rfc1843-decode-article-body t)
	172	(setq gnus-decode-encoded-word-function
	173	'gnus-multi-decode-encoded-word-string
	174	gnus-decode-header-function
	175	'gnus-multi-decode-header
	176	gnus-decode-encoded-word-methods
	177	(nconc gnus-decode-encoded-word-methods
	178	(list
	179	(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	180	'rfc1843-decode-string)))
	181	gnus-decode-header-methods
	182	(nconc gnus-decode-header-methods
	183	(list
	184	(cons (concat "\\<\\(" rfc1843-newsgroups-regexp "\\)\\>")
	185	'rfc1843-decode-region)))))
	186
	187	(provide 'rfc1843)
	188
ab5796a9	189	;;; arch-tag: 5149c301-a6ca-4731-9c9d-ba616e2cb687
c113de23	190	;;; rfc1843.el ends here