git.chise.org Git - elisp/gnus.git-/blob - contrib/gnus-idna.el

   1 ;;; gnus-idna.el --- Internationalized domain names support for Gnus.
   2
   3 ;; Copyright (C) 2003 Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson
   6 ;; Keywords: news, mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package implement crude support for internationalized domain
  28 ;; names in Gnus.
  29
  30 ;; Theory of Operation:
  31
  32 ;; RFC 2822 RHS's inside the From:, To:, and CC: headers are encoded
  33 ;; using IDNA ToASCII() when you send mail using Message.  The hook
  34 ;; used is message-send-hook.
  35 ;;
  36 ;; For incoming articles, when QP in headers are decoded (i.e., when
  37 ;; gnus-article-decode-hook is invoked), it searches for "xn--"
  38 ;; prefixes and decode them if they are found inside (heuristically
  39 ;; determined) RHS in From:, To: and Cc:, using IDNA ToUnicode().
  40
  41 ;; Usage:
  42
  43 ;; You need to install GNU Libidn (0.1.11 or later) and make sure the
  44 ;; idna.el installed by it is found by emacs.
  45
  46 ;; If you use an older Gnus, you may need to put the following in your
  47 ;; init scripts too, but keep in mind that most older Gnuses either
  48 ;; doesn't have these hooks or are buggy in other regards so it
  49 ;; doesn't work anyway.  (The window of Gnus versions that this works
  50 ;; on is a few weeks during the Oort CVS in winter 2003.)  Update to a
  51 ;; recent Gnus instead, then you don't have to do anything.
  52
  53 ;; (add-hook 'message-send-hook 'message-idna-to-ascii-rhs)
  54 ;; (add-hook 'gnus-article-decode-hook 'gnus-idna-to-unicode-rhs 'append)
  55
  56 ;; Revision history:
  57
  58 ;; 2003-02-26 Initial release
  59 ;;
  60 ;; 2003-03-19 Cleanup. Fixes a bug that may corrupt outgoing mail if
  61 ;;            it contains From:, To: or Cc: headers in the body.
  62
  63 ;;; Code:
  64
  65 (require 'gnus)
  66 (require 'gnus-util)
  67 (require 'rfc822)
  68 (autoload 'idna-to-ascii "idna")
  69 (autoload 'idna-to-unicode "idna")
  70
  71 (defcustom message-use-idna 'ask
  72   "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
  73   :type '(choice (const :tag "Ask" ask)
  74                  (const :tag "Never" nil)
  75                  (const :tag "Always" t)))
  76
  77 (defun message-idna-inside-rhs-p ()
  78   "Return t iff point is inside a RHS (heuristically).
  79 Only works properly if header contains mailbox-list or address-list.
  80 I.e., calling it on a Subject: header is useless."
  81   (if (re-search-backward
  82        "[\\\n\r\t ]" (save-excursion (search-backward "@" nil t)) t)
  83       ;; whitespace between @ and point
  84       nil
  85     (let ((dquote 1) (paren 1))
  86       (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
  87         (incf dquote))
  88       (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
  89         (incf paren))
  90       (and (= (% dquote 2) 1) (= (% paren 2) 1)))))
  91
  92 (defun message-idna-to-ascii-rhs-1 (header)
  93   "Interactively potentially IDNA encode domain names in HEADER."
  94   (let (rhs ace start end startpos endpos)
  95     (goto-char (point-min))
  96     (setq start (re-search-forward (concat "^" header) nil t)
  97           end (or (save-excursion (re-search-forward "^[ \t]" nil t))
  98                   (point-max)))
  99     (when (and start end)
 100       (while (re-search-forward "@\\([^ \t\r\n>]+\\)" end t)
 101         (setq rhs (match-string-no-properties 1)
 102               startpos (match-beginning 1)
 103               endpos (match-end 1))
 104         (when (save-match-data
 105                 (and (message-idna-inside-rhs-p)
 106                      (setq ace (idna-to-ascii rhs))
 107                      (not (string= rhs ace))
 108                      (if (eq message-use-idna 'ask)
 109                          (unwind-protect
 110                              (progn
 111                                (replace-highlight startpos endpos)
 112                                (y-or-n-p
 113                                 (format "Replace with `%s'? " ace)))
 114                            (message "")
 115                            (replace-dehighlight))
 116                        message-use-idna)))
 117           (replace-match (concat "@" ace)))))))
 118
 119 ;;;###autoload
 120 (defun message-idna-to-ascii-rhs ()
 121   "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
 122 See `message-idna-encode'."
 123   (interactive)
 124   (when (condition-case nil (require 'idna) (file-error))
 125     (save-excursion
 126       (save-restriction
 127         (message-narrow-to-head)
 128         (message-idna-to-ascii-rhs-1 "From")
 129         (message-idna-to-ascii-rhs-1 "To")
 130         (message-idna-to-ascii-rhs-1 "Cc")))))
 131
 132 ;;;###autoload
 133 (defun gnus-idna-to-unicode-rhs ()
 134   "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer."
 135   (when (condition-case nil (require 'idna) (file-error))
 136     (let ((inhibit-point-motion-hooks t)
 137           buffer-read-only)
 138       (article-narrow-to-head)
 139       (goto-char (point-min))
 140       (while (re-search-forward "\\(xn--.*\\)[ \t\n\r,>]" nil t)
 141         (let (ace unicode)
 142           (when (save-match-data
 143                   (and (setq ace (match-string 1))
 144                        (save-excursion (and (re-search-backward "^[^ \t]" nil t)
 145                                             (looking-at "From\\|To\\|Cc")))
 146                        (save-excursion (backward-char)
 147                                        (message-idna-inside-rhs-p))
 148                        (setq unicode (idna-to-unicode ace))))
 149             (unless (string= ace unicode)
 150               (replace-match unicode nil nil nil 1))))))))
 151
 152 (provide 'gnus-idna)
 153
 154 ;; gnus-idna.el ends here