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
  28 ;; (non-ASCII) domain names in Gnus.  It is meant as a proof of
  29 ;; concept.
  30
  31 ;; Theory of Operation:
  32
  33 ;; RFC 2822 RHS's inside the From:, To:, and CC: headers are encoded
  34 ;; using IDNA ToASCII() when you send mail using Message.  The hook
  35 ;; used is message-send-hook.
  36 ;;
  37 ;; For incoming articles, when QP in headers are decoded, it searches
  38 ;; for "xn--" prefixes and decode them using IDNA ToUnicode().  The
  39 ;; hook used is gnus-article-decode-hook.
  40
  41 ;; Usage:
  42
  43 ;; Simply put (require 'gnus-idna) in your ~/.gnus or ~/.emacs and it
  44 ;; should work.  You need to install GNU Libidn (0.1.11 or later) and
  45 ;; make sure the idna.el installed by it is found by emacs.
  46
  47 ;;; Code:
  48
  49 (require 'gnus)
  50 (require 'rfc822)
  51 (require 'idna)
  52
  53 (eval-and-compile
  54   (cond
  55    ((fboundp 'replace-in-string)
  56     (defalias 'gnus-replace-in-string 'replace-in-string))
  57    ((fboundp 'replace-regexp-in-string)
  58     (defun gnus-replace-in-string  (string regexp newtext &optional literal)
  59       (replace-regexp-in-string regexp newtext string nil literal)))
  60    (t
  61     (defun gnus-replace-in-string (string regexp newtext &optional literal)
  62       (let ((start 0) tail)
  63         (while (string-match regexp string start)
  64           (setq tail (- (length string) (match-end 0)))
  65           (setq string (replace-match newtext nil literal string))
  66           (setq start (- (length string) tail))))
  67       string))))
  68
  69 (defun gnus-idna-to-ascii-rhs-1 (header)
  70   (save-excursion
  71     (let (address header-data new-header-data rhs ace)
  72       (setq header-data (message-fetch-field header))
  73       (when header-data
  74         (dolist (element (message-tokenize-header header-data))
  75           (setq address (car (rfc822-addresses element)))
  76           (when (string-match "\\(.*\\)@\\([^@]+\\)" address)
  77             (setq ace (if (setq rhs (match-string 2 address))
  78                           (idna-to-ascii rhs)))
  79             (push (if (string= rhs ace)
  80                       element
  81                     (gnus-replace-in-string element (regexp-quote rhs) ace t))
  82                   new-header-data)))
  83         (message-remove-header header)
  84         (message-position-on-field header)
  85         (dolist (addr (reverse new-header-data))
  86           (insert addr ", "))
  87         (when new-header-data
  88           (delete-backward-char 2))))))
  89
  90 (defun gnus-idna-to-ascii-rhs ()
  91   (gnus-idna-to-ascii-rhs-1 "From")
  92   (gnus-idna-to-ascii-rhs-1 "To")
  93   (gnus-idna-to-ascii-rhs-1 "Cc"))
  94
  95 (add-hook 'message-send-hook 'gnus-idna-to-ascii-rhs)
  96
  97 (defun gnus-idna-to-unicode-rhs ()
  98   (let ((inhibit-point-motion-hooks t)
  99         buffer-read-only)
 100     (goto-char (point-min))
 101     (while (re-search-forward "xn--.*[ \t\n\r.,<>()@!]" nil t)
 102       ;(or (eobp) (forward-char))
 103       (let (ace unicode)
 104         (when (setq ace (match-string 0))
 105           (setq unicode (idna-to-unicode ace))
 106           (unless (string= ace unicode)
 107             (replace-match unicode)))))))
 108
 109 (add-hook 'gnus-article-decode-hook 'gnus-idna-to-unicode-rhs 'append)
 110
 111 (provide 'gnus-idna)
 112
 113 ;; gnus-idna.el ends here