Mercurial > emacs
view lisp/gnus/rfc1843.el @ 83310:e58cb448e07c
Merged from miles@gnu.org--gnu-2005 (patch 80-82, 350-422)
Patches applied:
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-350
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-351
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-352
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-353
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-354
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-355
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-356
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-357
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-358
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-359
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-360
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-361
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-362
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-363
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-364
Remove "-face" suffix from widget faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-365
Remove "-face" suffix from custom faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-366
Remove "-face" suffix from change-log faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-367
Remove "-face" suffix from compilation faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-368
Remove "-face" suffix from diff-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-369
lisp/longlines.el (longlines-visible-face): Face removed
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-370
Remove "-face" suffix from woman faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-371
Remove "-face" suffix from whitespace-highlight face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-372
Remove "-face" suffix from ruler-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-373
Remove "-face" suffix from show-paren faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-374
Remove "-face" suffix from log-view faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-375
Remove "-face" suffix from smerge faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-376
Remove "-face" suffix from show-tabs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-377
Remove "-face" suffix from highlight-changes faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-378
Remove "-face" suffix from and downcase info faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-379
Remove "-face" suffix from pcvs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-380
Update uses of renamed pcvs faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-381
Tweak ChangeLog
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-382
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-383
Remove "-face" suffix from strokes-char face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-384
Remove "-face" suffix from compare-windows face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-385
Remove "-face" suffix from calendar faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-386
Remove "-face" suffix from diary-button face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-387
Remove "-face" suffix from testcover faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-388
Remove "-face" suffix from viper faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-389
Remove "-face" suffix from org faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-390
Remove "-face" suffix from sgml-namespace face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-391
Remove "-face" suffix from table-cell face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-392
Remove "-face" suffix from tex-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-393
Remove "-face" suffix from texinfo-heading face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-394
Remove "-face" suffix from flyspell faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-395
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-396
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-397
Remove "-face" suffix from gomoku faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-398
Remove "-face" suffix from mpuz faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-399
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-400
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-401
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-402
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-403
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-404
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-405
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-406
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-407
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-408
Remove "-face" suffix from Buffer-menu-buffer face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-409
Remove "-face" suffix from antlr-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-410
Remove "-face" suffix from ebrowse faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-411
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-412
Remove "-face" suffix from flymake faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-413
Remove "-face" suffix from idlwave faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-414
Remove "-face" suffix from sh-script faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-415
Remove "-face" suffix from vhdl-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-416
Update from CVS
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-417
Remove "-face" suffix from which-func face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-418
Remove "-face" suffix from cperl-mode faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-419
Remove "-face" suffix from ld-script faces
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-420
Fix cperl-mode font-lock problem
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-421
Tweak which-func face
* miles@gnu.org--gnu-2005/emacs--cvs-trunk--0--patch-422
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-80
Merge from emacs--cvs-trunk--0
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-81
Update from CVS
* miles@gnu.org--gnu-2005/gnus--rel--5.10--patch-82
Update from CVS
git-archimport-id: lorentey@elte.hu--2004/emacs--multi-tty--0--patch-350
author | Karoly Lorentey <lorentey@elte.hu> |
---|---|
date | Wed, 15 Jun 2005 12:57:51 +0000 |
parents | 55fd4f77387a |
children | 18a818a2ee7c cce1c0ee76ee |
line wrap: on
line source
;;; rfc1843.el --- HZ (rfc1843) decoding ;; Copyright (c) 1998, 1999, 2000, 2003 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., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, 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 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 (ignore-errors (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