diff options
Diffstat (limited to 'lisp/gnus')
| -rw-r--r-- | lisp/gnus/ChangeLog | 56 | ||||
| -rw-r--r-- | lisp/gnus/flow-fill.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/gmm-utils.el | 413 | ||||
| -rw-r--r-- | lisp/gnus/gnus-art.el | 1 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 171 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 197 | ||||
| -rw-r--r-- | lisp/gnus/message.el | 161 | ||||
| -rw-r--r-- | lisp/gnus/mm-bodies.el | 13 | ||||
| -rw-r--r-- | lisp/gnus/mm-util.el | 121 |
9 files changed, 1004 insertions, 131 deletions
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 792fb2a5c0d..09dbe9e0027 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,52 @@ +2006-04-17 Reiner Steib <Reiner.Steib@gmx.de> + + [ Merge from Gnus trunk. ] + + * mm-util.el (mm-charset-synonym-alist): Improve doc string. + (mm-charset-override-alist): New variable. + (mm-charset-to-coding-system): Use it. + (mm-codepage-setup): New helper function. + (mm-charset-eval-alist): New variable. + (mm-charset-to-coding-system): Use mm-charset-eval-alist. Warn + about unknown charsets. Add allow-override. Use + `mm-charset-override-alist' only when decoding. + (mm-detect-mime-charset-region): Use :mime-charset. + + * mm-bodies.el (mm-decode-body, mm-decode-string): Call + `mm-charset-to-coding-system' with allow-override argument. + + * message.el (message-tool-bar-zap-list, message-tool-bar) + (message-tool-bar-gnome, message-tool-bar-retro): New variables. + (message-tool-bar-local-item-from-menu): Remove. + (message-tool-bar-map): Replace by `message-make-tool-bar'. + (message-make-tool-bar): New function. + (message-mode): Use `message-make-tool-bar'. + + * gnus-sum.el (gnus-summary-tool-bar) + (gnus-summary-tool-bar-gnome, gnus-summary-tool-bar-retro) + (gnus-summary-tool-bar-zap-list): New variables. + (gnus-summary-make-tool-bar): Complete rewrite using + `gmm-tool-bar-from-list'. + + * gnus-group.el (gnus-group-tool-bar, gnus-group-tool-bar-gnome) + (gnus-group-tool-bar-retro, gnus-group-tool-bar-zap-list): New + variables. + (gnus-group-make-tool-bar): Complete rewrite using + `gmm-tool-bar-from-list'. + (gnus-group-tool-bar-update): New function. + + * gmm-utils.el: New file. + +2006-04-12 Ralf Angeli <angeli@iwi.uni-sb.de> + + * flow-fill.el (fill-flowed): Remove trailing space from blank + quoted lines. + +2006-04-12 Reiner Steib <Reiner.Steib@gmx.de> + + * gnus-art.el (gnus-article-mode): Set + cursor-in-non-selected-windows to nil. + 2006-04-12 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-art.el (gnus-mime-view-part-as-charset): Ignore charset @@ -12,13 +61,6 @@ * gnus-uu.el (gnus-uu-save-article): Put mml tags instead of part tag to summarized topics part in order to encode non-ASCII text. -2006-04-12 Kenichi Handa <handa@m17n.org> - - * rfc2231.el (rfc2231-decode-encoded-string): Work on unibyte - buffer and then decode the buffer text if necessary. - (rfc2231-encode-string): Be sure to work on multibyte buffer at - first, and after mm-encode-body, change the buffer to unibyte. - 2006-04-11 Reiner Steib <Reiner.Steib@gmx.de> * gnus-art.el (gnus-button-valid-localpart-regexp): Exclude `@'. diff --git a/lisp/gnus/flow-fill.el b/lisp/gnus/flow-fill.el index 98697439106..b47e9ba8365 100644 --- a/lisp/gnus/flow-fill.el +++ b/lisp/gnus/flow-fill.el @@ -114,7 +114,7 @@ RFC 2646 suggests 66 characters for readability." (set-buffer (or (current-buffer) buffer)) (goto-char (point-min)) ;; Remove space stuffing. - (while (re-search-forward "^ " nil t) + (while (re-search-forward "^\\( \\|>+ $\\)" nil t) (delete-char -1) (forward-line 1)) (goto-char (point-min)) diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el new file mode 100644 index 00000000000..4db811053ec --- /dev/null +++ b/lisp/gnus/gmm-utils.el @@ -0,0 +1,413 @@ +;;; gmm-utils.el --- Utility functions for Gnus, Message and MML + +;; Copyright (C) 2006 Free Software Foundation, Inc. + +;; Author: Reiner Steib <reiner.steib@gmx.de> +;; Keywords: news + +;; 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: + +;; This library provides self-contained utility functions. The functions are +;; used in Gnus, Message and MML, but within this library there are no +;; dependencies on Gnus, Message, or MML or Gnus. + +;;; Code: + +;; (require 'wid-edit) + +(defgroup gmm nil + "Utility functions for Gnus, Message and MML" + :prefix "gmm-" + :version "23.0" ;; No Gnus + :group 'lisp) + +;; Helper functions from `gnus-utils.el': gmm-verbose, gmm-message, gmm-error + +(defcustom gmm-verbose 7 + "Integer that says how verbose gmm should be. +The higher the number, the more messages will flash to say what +it done. At zero, it will be totally mute; at five, it will +display most important messages; and at ten, it will keep on +jabbering all the time." + :type 'integer + :group 'gmm) + +;;;###autoload +(defun gmm-message (level &rest args) + "If LEVEL is lower than `gmm-verbose' print ARGS using `message'. + +Guideline for numbers: +1 - error messages, 3 - non-serious error messages, 5 - messages for things +that take a long time, 7 - not very important messages on stuff, 9 - messages +inside loops." + (if (<= level gmm-verbose) + (apply 'message args) + ;; We have to do this format thingy here even if the result isn't + ;; shown - the return value has to be the same as the return value + ;; from `message'. + (apply 'format args))) + +;;;###autoload +(defun gmm-error (level &rest args) + "Beep an error if LEVEL is equal to or less than `gmm-verbose'. +ARGS are passed to `message'." + (when (<= (floor level) gmm-verbose) + (apply 'message args) + (ding) + (let (duration) + (when (and (floatp level) + (not (zerop (setq duration (* 10 (- level (floor level))))))) + (sit-for duration)))) + nil) + +;;;###autoload +(defun gmm-widget-p (symbol) + "Non-nil iff SYMBOL is a widget." + (get symbol 'widget-type)) + +;; Copy of the `nnmail-lazy' code from `nnmail.el': +(define-widget 'gmm-lazy 'default + "Base widget for recursive datastructures. + +This is copy of the `lazy' widget in Emacs 22.1 provided for compatibility." + :format "%{%t%}: %v" + :convert-widget 'widget-value-convert-widget + :value-create (lambda (widget) + (let ((value (widget-get widget :value)) + (type (widget-get widget :type))) + (widget-put widget :children + (list (widget-create-child-value + widget (widget-convert type) value))))) + :value-delete 'widget-children-value-delete + :value-get (lambda (widget) + (widget-value (car (widget-get widget :children)))) + :value-inline (lambda (widget) + (widget-apply (car (widget-get widget :children)) + :value-inline)) + :default-get (lambda (widget) + (widget-default-get + (widget-convert (widget-get widget :type)))) + :match (lambda (widget value) + (widget-apply (widget-convert (widget-get widget :type)) + :match value)) + :validate (lambda (widget) + (widget-apply (car (widget-get widget :children)) :validate))) + +;; Note: The format of `gmm-tool-bar-item' may change if some future Emacs +;; version will provide customizable tool bar buttons using a different +;; interface. + +;; TODO: Extend API so that the "Command" entry can be a function or a plist. +;; In case of a list it should have the format... +;; +;; (:none command-without-modifier +;; :shift command-with-shift-pressed +;; :control command-with-ctrl-pressed +;; :control-shift command-with-control-and-shift-pressed +;; ;; mouse-2 and mouse-3 can't be used in Emacs yet. +;; :mouse-2 command-on-mouse-2-press +;; :mouse-3 command-on-mouse-3-press) ;; typically a menu of related commands +;; +;; Combinations of mouse-[23] plus shift and/or controll might be overkill. +;; +;; Then use (plist-get rs-command :none), (plist-get rs-command :shift) + +(define-widget 'gmm-tool-bar-item (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) + "Tool bar list item." + :tag "Tool bar item" + :type '(choice + (list :tag "Command and Icon" + (function :tag "Command") + (string :tag "Icon file") + (choice + (const :tag "Default map" nil) + ;; Note: Usually we need non-nil attributes if map is t. + (const :tag "No menu" t) + (sexp :tag "Other map")) + (plist :inline t :tag "Properties")) + (list :tag "Separator" + (const :tag "No command" gmm-ignore) + (string :tag "Icon file") + (const :tag "No map") + (plist :inline t :tag "Properties")))) + +(define-widget 'gmm-tool-bar-zap-list (if (gmm-widget-p 'lazy) 'lazy 'gmm-lazy) + "Tool bar zap list." + :tag "Tool bar zap list" + :type '(choice (const :tag "Zap all" t) + (const :tag "Keep all" nil) + (list + ;; :value + ;; Work around (bug in customize?), see + ;; <news:v9is48jrj1.fsf@marauder.physik.uni-ulm.de> + ;; (new-file open-file dired kill-buffer write-file + ;; print-buffer customize help) + (set :inline t + (const new-file) + (const open-file) + (const dired) + (const kill-buffer) + (const save-buffer) + (const write-file) + (const undo) + (const cut) + (const copy) + (const paste) + (const search-forward) + (const print-buffer) + (const customize) + (const help)) + (repeat :inline t + :tag "Other" + (symbol :tag "Icon item"))))) + +;; (defun gmm-color-cells (&optional display) +;; "Return the number of color cells supported by DISPLAY. +;; Compatibility function." +;; ;; `display-color-cells' doesn't return more than 256 even if color depth is +;; ;; > 8 in Emacs 21. +;; ;; +;; ;; Feel free to add proper XEmacs support. +;; (let* ((cells (and (fboundp 'display-color-cells) +;; (display-color-cells display))) +;; (plane (and (fboundp 'x-display-planes) +;; (ash 1 (x-display-planes)))) +;; (none -1)) +;; (max (if (integerp cells) cells none) +;; (if (integerp plane) plane none)))) + +(defcustom gmm-tool-bar-style + (if (and (boundp 'tool-bar-mode) + tool-bar-mode + (and (fboundp 'display-visual-class) + (not (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color))))) + 'gnome + 'retro) + "Prefered tool bar style." + :type '(choice (const :tag "GNOME style" 'gnome) + (const :tag "Retro look" 'retro)) + :group 'gmm) + +(defvar tool-bar-map) + +;;;###autoload +(defun gmm-tool-bar-from-list (icon-list zap-list default-map) + "Make a tool bar from ICON-LIST. + +Within each entry of ICON-LIST, the first element is a menu +command, the second element is an icon file name and the third +element is a test function. You can use \\[describe-key] +<menu-entry> to find out the name of a menu command. The fourth +and all following elements are passed a the PROPS argument to the +function `tool-bar-local-item'. + +If ZAP-LIST is a list, remove those item from the default +`tool-bar-map'. If it is t, start with a new sparse map. You +can use \\[describe-key] <icon> to find out the name of an icon +item. When \\[describe-key] <icon> shows \"<tool-bar> <new-file> +runs the command find-file\", then use `new-file' in ZAP-LIST. + +DEFAULT-MAP specifies the default key map for ICON-LIST." + (let (;; For Emacs 21, we must let-bind `tool-bar-map'. In Emacs 22, we + ;; could use some other local variable. + (tool-bar-map (if (eq zap-list t) + (make-sparse-keymap) + (copy-keymap tool-bar-map)))) + (when (listp zap-list) + ;; Zap some items which aren't relevant for this mode and take up space. + (dolist (key zap-list) + (define-key tool-bar-map (vector key) nil))) + (mapc (lambda (el) + (let ((command (car el)) + (icon (nth 1 el)) + (fmap (or (nth 2 el) default-map)) + (props (cdr (cdr (cdr el)))) ) + ;; command may stem from different from-maps: + (cond ((eq command 'gmm-ignore) + ;; The dummy `gmm-ignore', see `gmm-tool-bar-item' + ;; widget. Suppress tooltip by adding `:enable nil'. + (if (fboundp 'tool-bar-local-item) + (apply 'tool-bar-local-item icon nil nil + tool-bar-map :enable nil props) + ;; (tool-bar-local-item ICON DEF KEY MAP &rest PROPS) + ;; (tool-bar-add-item ICON DEF KEY &rest PROPS) + (apply 'tool-bar-add-item icon nil nil :enable nil props))) + ((equal fmap t) ;; Not a menu command + (if (fboundp 'tool-bar-local-item) + (apply 'tool-bar-local-item + icon command + (intern icon) ;; reuse icon or fmap here? + tool-bar-map props) + ;; Emacs 21 compatibility: + (apply 'tool-bar-add-item + icon command + (intern icon) + props))) + (t ;; A menu command + (if (fboundp 'tool-bar-local-item-from-menu) + (apply 'tool-bar-local-item-from-menu + ;; (apply 'tool-bar-local-item icon def key + ;; tool-bar-map props) + command icon tool-bar-map (symbol-value fmap) + props) + ;; Emacs 21 compatibility: + (apply 'tool-bar-add-item-from-menu + command icon (symbol-value fmap) + props)))) + t)) + (if (symbolp icon-list) + (eval icon-list) + icon-list)) + tool-bar-map)) + +;; WARNING: The following is subject to change. Don't rely on it yet. + +;; From MH-E without modifications: + +(defmacro gmm-defun-compat (name function arg-list &rest body) + "Create function NAME. +If FUNCTION exists, then NAME becomes an alias for FUNCTION. +Otherwise, create function NAME with ARG-LIST and BODY." + (let ((defined-p (fboundp function))) + (if defined-p + `(defalias ',name ',function) + `(defun ,name ,arg-list ,@body)))) + +(gmm-defun-compat gmm-image-search-load-path + image-search-load-path (file &optional path) + "Emacs 21 and XEmacs don't have `image-search-load-path'. +This function returns nil on those systems." + nil) + +;; From MH-E with modifications: + +;; Don't use `gmm-defun-compat' until API changes in +;; `image-load-path-for-library' in Emacs CVS are completed. + +(defun gmm-image-load-path-for-library (library image &optional path no-error) + "Return a suitable search path for images relative to LIBRARY. + +First it searches for IMAGE in `image-load-path' (excluding +\"`data-directory'/images\") and `load-path', followed by a path +suitable for LIBRARY, which includes \"../../etc/images\" and +\"../etc/images\" relative to the library file itself, and then +in \"`data-directory'/images\". + +Then this function returns a list of directories which contains +first the directory in which IMAGE was found, followed by the +value of `load-path'. If PATH is given, it is used instead of +`load-path'. + +If NO-ERROR is non-nil and a suitable path can't be found, don't +signal an error. Instead, return a list of directories as before, +except that nil appears in place of the image directory. + +Here is an example that uses a common idiom to provide +compatibility with versions of Emacs that lack the variable +`image-load-path': + + ;; Shush compiler. + (defvar image-load-path) + + (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\")) + (image-load-path (cons (car load-path) + (when (boundp 'image-load-path) + image-load-path)))) + (mh-tool-bar-folder-buttons-init))" + (unless library (error "No library specified")) + (unless image (error "No image specified")) + (let (image-directory image-directory-load-path) + ;; Check for images in image-load-path or load-path. + (let ((img image) + (dir (or + ;; Images in image-load-path. + (gmm-image-search-load-path image) ;; "gmm-" prefix! + ;; Images in load-path. + (locate-library image))) + parent) + ;; Since the image might be in a nested directory (for + ;; example, mail/attach.pbm), adjust `image-directory' + ;; accordingly. + (when dir + (setq dir (file-name-directory dir)) + (while (setq parent (file-name-directory img)) + (setq img (directory-file-name parent) + dir (expand-file-name "../" dir)))) + (setq image-directory-load-path dir)) + + ;; If `image-directory-load-path' isn't Emacs' image directory, + ;; it's probably a user preference, so use it. Then use a + ;; relative setting if possible; otherwise, use + ;; `image-directory-load-path'. + (cond + ;; User-modified image-load-path? + ((and image-directory-load-path + (not (equal image-directory-load-path + (file-name-as-directory + (expand-file-name "images" data-directory))))) + (setq image-directory image-directory-load-path)) + ;; Try relative setting. + ((let (library-name d1ei d2ei) + ;; First, find library in the load-path. + (setq library-name (locate-library library)) + (if (not library-name) + (error "Cannot find library %s in load-path" library)) + ;; And then set image-directory relative to that. + (setq + ;; Go down 2 levels. + d2ei (file-name-as-directory + (expand-file-name + (concat (file-name-directory library-name) "../../etc/images"))) + ;; Go down 1 level. + d1ei (file-name-as-directory + (expand-file-name + (concat (file-name-directory library-name) "../etc/images")))) + (setq image-directory + ;; Set it to nil if image is not found. + (cond ((file-exists-p (expand-file-name image d2ei)) d2ei) + ((file-exists-p (expand-file-name image d1ei)) d1ei))))) + ;; Use Emacs' image directory. + (image-directory-load-path + (setq image-directory image-directory-load-path)) + (no-error + (message "Could not find image %s for library %s" image library)) + (t + (error "Could not find image %s for library %s" image library))) + + ;; Return an augmented `path' or `load-path'. + (nconc (list image-directory) + (delete image-directory (copy-sequence (or path load-path)))))) + +(defun gmm-customize-mode (&optional mode) + "Customize customization group for MODE. +If mode is nil, use `major-mode' of the curent buffer." + (interactive) + (customize-group + (or mode + (intern (let ((mode (symbol-name major-mode))) + (string-match "^\\(.+\\)-mode$" mode) + (match-string 1 mode)))))) + +(provide 'gmm-utils) + +;; arch-tag: e0b60920-2ce6-40c1-bfc0-cadbbe26b602 +;;; gmm-utils.el ends here diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index a4da4ae85f3..7e3b843d500 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -3809,6 +3809,7 @@ commands: (make-local-variable 'gnus-article-ignored-charsets) ;; Prevent recent Emacsen from displaying non-break space as "\ ". (set (make-local-variable 'nobreak-char-display) nil) + (setq cursor-in-non-selected-windows nil) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 24e4df14712..51af7d48d9c 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -39,6 +39,7 @@ (require 'gnus-range) (require 'gnus-win) (require 'gnus-undo) +(require 'gmm-utils) (require 'time-date) (require 'gnus-ems) @@ -979,36 +980,135 @@ simple manner.") (gnus-run-hooks 'gnus-group-menu-hook))) -(defvar gnus-group-toolbar-map nil) - -;; Emacs 21 tool bar. Should be no-op otherwise. -(defun gnus-group-make-tool-bar () - (if (and - (condition-case nil (require 'tool-bar) (error nil)) - (fboundp 'tool-bar-add-item-from-menu) - (default-value 'tool-bar-mode) - (not gnus-group-toolbar-map)) - (setq gnus-group-toolbar-map - (let ((tool-bar-map (make-sparse-keymap)) - (load-path (mm-image-load-path))) - (tool-bar-add-item-from-menu - 'gnus-group-get-new-news "get-news" gnus-group-mode-map) - (tool-bar-add-item-from-menu - 'gnus-group-get-new-news-this-group "gnntg" gnus-group-mode-map) - (tool-bar-add-item-from-menu - 'gnus-group-catchup-current "catchup" gnus-group-mode-map) - (tool-bar-add-item-from-menu - 'gnus-group-describe-group "describe-group" gnus-group-mode-map) - (tool-bar-add-item "subscribe" 'gnus-group-subscribe 'subscribe - :help "Subscribe to the current group") - (tool-bar-add-item "unsubscribe" 'gnus-group-unsubscribe - 'unsubscribe - :help "Unsubscribe from the current group") - (tool-bar-add-item-from-menu - 'gnus-group-exit "exit-gnus" gnus-group-mode-map) - tool-bar-map))) - (if gnus-group-toolbar-map - (set (make-local-variable 'tool-bar-map) gnus-group-toolbar-map))) + +(defvar gnus-group-tool-bar-map nil) + +(defun gnus-group-tool-bar-update (&optional symbol value) + "Update group buffer toolbar. +Setter function for custom variables." + (when symbol + (set-default symbol value)) + ;; (setq-default gnus-group-tool-bar-map nil) + ;; (use-local-map gnus-group-mode-map) + (when (gnus-alive-p) + (with-current-buffer gnus-group-buffer + (gnus-group-make-tool-bar t)))) + +(defcustom gnus-group-tool-bar (if (eq gmm-tool-bar-style 'gnome) + 'gnus-group-tool-bar-gnome + 'gnus-group-tool-bar-retro) + "Specifies the Gnus group tool bar. + +It can be either a list or a symbol refering to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-group-mode-map'. + +Pre-defined symbols include `gnus-group-tool-bar-gnome' and +`gnus-group-tool-bar-retro'." + :type '(choice (const :tag "GNOME style" gnus-group-tool-bar-gnome) + (const :tag "Retro look" gnus-group-tool-bar-retro) + (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-group-tool-bar-update + :group 'gnus-group) + +(defcustom gnus-group-tool-bar-gnome + '((gnus-group-post-news "mail/compose") + ;; Some useful agent icons? I don't use the agent so agent users should + ;; suggest useful commands: + (gnus-agent-toggle-plugged "connect" t + :visible (and gnus-agent (not gnus-plugged))) + (gnus-agent-toggle-plugged "disconnect" t + :visible (and gnus-agent gnus-plugged)) + ;; FIXME: gnus-agent-toggle-plugged (in gnus-agent-group-make-menu-bar) + ;; should have a better help text. + (gnus-group-send-queue "mail/outbox" t + :visible (and gnus-agent gnus-plugged) + :help "Send articles from the queue group") + (gnus-group-get-new-news "mail/inbox" nil + :visible (or (not gnus-agent) + gnus-plugged)) + ;; FIXME: gnus-*-read-group should have a better help text. + (gnus-topic-read-group "open" nil + :visible (and (boundp 'gnus-topic-mode) + gnus-topic-mode)) + (gnus-group-read-group "open" nil + :visible (not (and (boundp 'gnus-topic-mode) + gnus-topic-mode))) + ;; (gnus-group-find-new-groups "???" nil) + (gnus-group-save-newsrc "save") + (gnus-group-describe-group "describe") + (gnus-group-unsubscribe-current-group "gnus/toggle-subscription") + (gnus-group-prev-unread-group "left-arrow") + (gnus-group-next-unread-group "right-arrow") + (gnus-group-exit "exit") + (gmm-customize-mode "preferences" t :help "Edit mode preferences") + (gnus-info-find-node "help")) + "List of functions for the group tool bar (GNOME style). + +See `gmm-tool-bar-from-list' for the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-group-tool-bar-update + :group 'gnus-group) + +(defcustom gnus-group-tool-bar-retro + '((gnus-group-get-new-news "gnus/get-news") + (gnus-group-get-new-news-this-group "gnus/gnntg") + (gnus-group-catchup-current "gnus/catchup") + (gnus-group-describe-group "gnus/describe-group") + (gnus-group-subscribe "gnus/subscribe" t + :help "Subscribe to the current group") + (gnus-group-unsubscribe "gnus/unsubscribe" t + :help "Unsubscribe from the current group") + (gnus-group-exit "gnus/exit-gnus" gnus-group-mode-map)) + "List of functions for the group tool bar (retro look). + +See `gmm-tool-bar-from-list' for the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-group-tool-bar-update + :group 'gnus-group) + +(defcustom gnus-group-tool-bar-zap-list t + "List of icon items from the global tool bar. +These items are not displayed in the Gnus group mode tool bar. + +See `gmm-tool-bar-from-list' for the format of the list." + :type 'gmm-tool-bar-zap-list + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-group-tool-bar-update + :group 'gnus-group) + +(defvar image-load-path) + +(defun gnus-group-make-tool-bar (&optional force) + "Make a group mode tool bar from `gnus-group-tool-bar'. +When FORCE, rebuild the tool bar." + (when (and (not (featurep 'xemacs)) + (boundp 'tool-bar-mode) + tool-bar-mode + ;; The Gnus 5.10.6 code checked (default-value 'tool-bar-mode). + ;; Why? --rsteib + (or (not gnus-group-tool-bar-map) force)) + (let* ((load-path + (gmm-image-load-path-for-library "gnus" + "gnus/toggle-subscription.xpm" + nil t)) + (image-load-path (cons (car load-path) + (when (boundp 'image-load-path) + image-load-path))) + (map (gmm-tool-bar-from-list gnus-group-tool-bar + gnus-group-tool-bar-zap-list + 'gnus-group-mode-map))) + (if map + (set (make-local-variable 'tool-bar-map) map)))) + gnus-group-tool-bar-map) (defun gnus-group-mode () "Major mode for reading news. @@ -1379,6 +1479,17 @@ if it is a string, only list groups matching REGEXP." (gnus-range-difference (list active) (gnus-info-read info)) seen)))))) +;; Moving through the Group buffer (in topic mode) e.g. with C-n doesn't +;; update the state (enabled/disabled) of the icon `gnus-group-describe-group' +;; automatically. After `C-l' the state is correct. See the following report +;; on emacs-devel +;; <http://thread.gmane.org/v9acdmrcse.fsf@marauder.physik.uni-ulm.de>: +;; From: Reiner Steib +;; Subject: tool bar icons not updated according to :active condition +;; Newsgroups: gmane.emacs.devel +;; Date: Mon, 23 Jan 2006 19:59:13 +0100 +;; Message-ID: <v9acdmrcse.fsf@marauder.physik.uni-ulm.de> + (defcustom gnus-group-update-tool-bar (and (not (featurep 'xemacs)) (boundp 'tool-bar-mode) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index bea7cb2445e..0de73bc879a 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -38,6 +38,7 @@ (require 'gnus-int) (require 'gnus-undo) (require 'gnus-util) +(require 'gmm-utils) (require 'mm-decode) (require 'nnoo) @@ -2546,47 +2547,161 @@ gnus-summary-show-article-from-menu-as-charset-%s" cs)))) (defvar gnus-summary-tool-bar-map nil) -;; Emacs 21 tool bar. Should be no-op otherwise. -(defun gnus-summary-make-tool-bar () - (if (and (fboundp 'tool-bar-add-item-from-menu) - (default-value 'tool-bar-mode) - (not gnus-summary-tool-bar-map)) - (setq gnus-summary-tool-bar-map - (let ((tool-bar-map (make-sparse-keymap)) - (load-path (mm-image-load-path))) - (tool-bar-add-item-from-menu - 'gnus-summary-prev-unread "prev-ur" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-next-unread "next-ur" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-post-news "post" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-followup-with-original "fuwo" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-followup "followup" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-reply-with-original "reply-wo" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-reply "reply" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-caesar-message "rot13" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-uu-decode-uu "uu-decode" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-save-article-file "save-aif" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-save-article "save-art" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-uu-post-news "uu-post" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-catchup "catchup" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-catchup-and-exit "cu-exit" gnus-summary-mode-map) - (tool-bar-add-item-from-menu - 'gnus-summary-exit "exit-summ" gnus-summary-mode-map) - tool-bar-map))) - (if gnus-summary-tool-bar-map - (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map))) +;; Note: The :set function in the `gnus-summary-tool-bar*' variables will only +;; affect _new_ message buffers. We might add a function that walks thru all +;; summary-mode buffers and force the update. +(defun gnus-summary-tool-bar-update (&optional symbol value) + "Update summary mode toolbar. +Setter function for custom variables." + (setq-default gnus-summary-tool-bar-map nil) + (when symbol + ;; When used as ":set" function: + (set-default symbol value)) + (when (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + (gnus-summary-make-tool-bar)))) + +(defcustom gnus-summary-tool-bar (if (eq gmm-tool-bar-style 'gnome) + 'gnus-summary-tool-bar-gnome + 'gnus-summary-tool-bar-retro) + "Specifies the Gnus summary tool bar. + +It can be either a list or a symbol refering to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `gnus-summary-mode-map'. + +Pre-defined symbols include `gnus-summary-tool-bar-gnome' and +`gnus-summary-tool-bar-retro'." + :type '(choice (const :tag "GNOME style" gnus-summary-tool-bar-gnome) + (const :tag "Retro look" gnus-summary-tool-bar-retro) + (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-summary-tool-bar-update + :group 'gnus-summary) + +(defcustom gnus-summary-tool-bar-gnome + '((gnus-summary-post-news "mail/compose" nil) + (gnus-summary-insert-new-articles "mail/inbox" nil + :visible (or (not gnus-agent) + gnus-plugged)) + (gnus-summary-reply-with-original "mail/reply") + (gnus-summary-reply "mail/reply" nil :visible nil) + (gnus-summary-followup-with-original "mail/reply-all") + (gnus-summary-followup "mail/reply-all" nil :visible nil) + (gnus-summary-mail-forward "mail/forward") + (gnus-summary-save-article "mail/save") + (gnus-summary-search-article-forward "search" nil :visible nil) + (gnus-summary-print-article "print") + (gnus-summary-tick-article-forward "flag-followup" nil :visible nil) + ;; Some new commands that may need more suitable icons: + (gnus-summary-save-newsrc "save" nil :visible nil) + ;; (gnus-summary-show-article "stock_message-display" nil :visible nil) + (gnus-summary-prev-article "left-arrow") + (gnus-summary-next-article "right-arrow") + (gnus-summary-next-page "next-page") + ;; (gnus-summary-enter-digest-group "right_arrow" nil :visible nil) + ;; + ;; Maybe some sort-by-... could be added: + ;; (gnus-summary-sort-by-author "sort-a-z" nil :visible nil) + ;; (gnus-summary-sort-by-date "sort-1-9" nil :visible nil) + (gnus-summary-mark-as-expirable + "delete" nil + :visible (gnus-check-backend-function 'request-expire-articles + gnus-newsgroup-name)) + (gnus-summary-mark-as-spam + "mail/spam" t + :visible (and (fboundp 'spam-group-ham-contents-p) + (spam-group-ham-contents-p gnus-newsgroup-name)) + :help "Mark as spam") + (gnus-summary-mark-as-read-forward + "mail/not-spam" nil + :visible (and (fboundp 'spam-group-spam-contents-p) + (spam-group-spam-contents-p gnus-newsgroup-name))) + ;; + (gnus-summary-exit "exit") + (gmm-customize-mode "preferences" t :help "Edit mode preferences") + (gnus-info-find-node "help")) + "List of functions for the summary tool bar (GNOME style). + +See `gmm-tool-bar-from-list' for the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-summary-tool-bar-update + :group 'gnus-summary) + +(defcustom gnus-summary-tool-bar-retro + '((gnus-summary-prev-unread-article "gnus/prev-ur") + (gnus-summary-next-unread-article "gnus/next-ur") + (gnus-summary-post-news "gnus/post") + (gnus-summary-followup-with-original "gnus/fuwo") + (gnus-summary-followup "gnus/followup") + (gnus-summary-reply-with-original "gnus/reply-wo") + (gnus-summary-reply "gnus/reply") + (gnus-summary-caesar-message "gnus/rot13") + (gnus-uu-decode-uu "gnus/uu-decode") + (gnus-summary-save-article-file "gnus/save-aif") + (gnus-summary-save-article "gnus/save-art") + (gnus-uu-post-news "gnus/uu-post") + (gnus-summary-catchup "gnus/catchup") + (gnus-summary-catchup-and-exit "gnus/cu-exit") + (gnus-summary-exit "gnus/exit-summ") + ;; Some new command that may need more suitable icons: + (gnus-summary-print-article "gnus/print" nil :visible nil) + (gnus-summary-mark-as-expirable "gnus/close" nil :visible nil) + (gnus-summary-save-newsrc "gnus/save" nil :visible nil) + ;; (gnus-summary-enter-digest-group "gnus/right_arrow" nil :visible nil) + (gnus-summary-search-article-forward "gnus/search" nil :visible nil) + ;; (gnus-summary-insert-new-articles "gnus/paste" nil :visible nil) + ;; (gnus-summary-toggle-threads "gnus/open" nil :visible nil) + ;; + (gnus-info-find-node "gnus/help" nil :visible nil)) + "List of functions for the summary tool bar (retro look). + +See `gmm-tool-bar-from-list' for the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-summary-tool-bar-update + :group 'gnus-summary) + +(defcustom gnus-summary-tool-bar-zap-list t + "List of icon items from the global tool bar. +These items are not displayed in the Gnus summary mode tool bar. + +See `gmm-tool-bar-from-list' for the format of the list." + :type 'gmm-tool-bar-zap-list + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'gnus-summary-tool-bar-update + :group 'gnus-summary) + +(defvar image-load-path) + +(defun gnus-summary-make-tool-bar (&optional force) + "Make a summary mode tool bar from `gnus-summary-tool-bar'. +When FORCE, rebuild the tool bar." + (when (and (not (featurep 'xemacs)) + (boundp 'tool-bar-mode) + tool-bar-mode + (or (not gnus-summary-tool-bar-map) force)) + (let* ((load-path + (gmm-image-load-path-for-library "gnus" + "mail/save.xpm" + nil t)) + (image-load-path (cons (car load-path) + (when (boundp 'image-load-path) + image-load-path))) + (map (gmm-tool-bar-from-list gnus-summary-tool-bar + gnus-summary-tool-bar-zap-list + 'gnus-summary-mode-map))) + (when map + ;; Need to set `gnus-summary-tool-bar-map' because `gnus-article-mode' + ;; uses it's value. + (setq gnus-summary-tool-bar-map map)))) + (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)) (defun gnus-score-set-default (var value) "A version of set that updates the GNU Emacs menu-bar." diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 741b193f779..472eb2468dd 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -37,6 +37,7 @@ (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary (require 'canlock) (require 'mailheader) +(require 'gmm-utils) (require 'nnheader) ;; This is apparently necessary even though things are autoloaded. ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better @@ -2529,7 +2530,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) (if (boundp 'tool-bar-map) - (set (make-local-variable 'tool-bar-map) (message-tool-bar-map)))) + (set (make-local-variable 'tool-bar-map) (message-make-tool-bar)))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) (gnus-make-local-hook 'after-change-functions) @@ -6586,53 +6587,123 @@ which specify the range to operate on." ;; Support for toolbar (eval-when-compile - (defvar tool-bar-map) (defvar tool-bar-mode)) -(defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props) - ;; We need to make tool bar entries in local keymaps with - ;; `tool-bar-local-item-from-menu' in Emacs >= 22 - (if (fboundp 'tool-bar-local-item-from-menu) - (tool-bar-local-item-from-menu command icon in-map from-map props) - (tool-bar-add-item-from-menu command icon from-map props))) - -(defun message-tool-bar-map () - (or message-tool-bar-map - (setq message-tool-bar-map - (and - (condition-case nil (require 'tool-bar) (error nil)) - (fboundp 'tool-bar-add-item-from-menu) +;; Note: The :set function in the `message-tool-bar*' variables will only +;; affect _new_ message buffers. We might add a function that walks thru all +;; message-mode buffers and force the update. +(defun message-tool-bar-update (&optional symbol value) + "Update message mode toolbar. +Setter function for custom variables." + (setq-default message-tool-bar-map nil) + (when symbol + ;; When used as ":set" function: + (set-default symbol value))) + +(defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome) + 'message-tool-bar-gnome + 'message-tool-bar-retro) + "Specifies the message mode tool bar. + +It can be either a list or a symbol refering to a list. See +`gmm-tool-bar-from-list' for the format of the list. The +default key map is `message-mode-map'. + +Pre-defined symbols include `message-tool-bar-gnome' and +`message-tool-bar-retro'." + :type '(repeat gmm-tool-bar-list-item) + :type '(choice (const :tag "GNOME style" message-tool-bar-gnome) + (const :tag "Retro look" message-tool-bar-retro) + (repeat :tag "User defined list" gmm-tool-bar-item) + (symbol)) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'message-tool-bar-update + :group 'message) + +(defcustom message-tool-bar-gnome + '((ispell-message "spell" nil + :visible (or (not (boundp 'flyspell-mode)) + (not flyspell-mode))) + (flyspell-buffer "spell" t + :visible (and (boundp 'flyspell-mode) + flyspell-mode) + :help "Flyspell whole buffer") + (gmm-ignore "separator") + (message-send-and-exit "mail/send") + (message-dont-send "mail/save-draft") + (message-kill-buffer "close") ;; stock_cancel + (mml-attach-file "attach" mml-mode-map) + (mml-preview "mail/preview" mml-mode-map) + ;; (mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil) + (message-insert-importance-high "important" nil :visible nil) + (message-insert-importance-low "unimportant" nil :visible nil) + (message-insert-disposition-notification-to "receipt" nil :visible nil) + (gmm-customize-mode "preferences" t :help "Edit mode preferences") + (message-info "help" t :help "Message manual")) + "List of items for the message tool bar (GNOME style). + +See `gmm-tool-bar-from-list' for details on the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'message-tool-bar-update + :group 'message) + +(defcustom message-tool-bar-retro + '(;; Old Emacs 21 icon for consistency. + (message-send-and-exit "gnus/mail_send") + (message-kill-buffer "close") + (message-dont-send "cancel") + (mml-attach-file "attach" mml-mode-map) + (ispell-message "spell") + (mml-preview "preview" mml-mode-map) + (message-insert-importance-high "gnus/important") + (message-insert-importance-low "gnus/unimportant") + (message-insert-disposition-notification-to "gnus/receipt")) + "List of items for the message tool bar (retro style). + +See `gmm-tool-bar-from-list' for details on the format of the list." + :type '(repeat gmm-tool-bar-item) + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'message-tool-bar-update + :group 'message) + +(defcustom message-tool-bar-zap-list + '(new-file open-file dired kill-buffer write-file + print-buffer customize help) + "List of icon items from the global tool bar. +These items are not displayed on the message mode tool bar. + +See `gmm-tool-bar-from-list' for the format of the list." + :type 'gmm-tool-bar-zap-list + :version "22.1" ;; Gnus 5.10.9 + :initialize 'custom-initialize-default + :set 'message-tool-bar-update + :group 'message) + +(defvar image-load-path) + +(defun message-make-tool-bar (&optional force) + "Make a message mode tool bar from `message-tool-bar-list'. +When FORCE, rebuild the tool bar." + (when (and (not (featurep 'xemacs)) + (boundp 'tool-bar-mode) tool-bar-mode - (let ((tool-bar-map (copy-keymap tool-bar-map)) - (load-path (mm-image-load-path))) - ;; Zap some items which aren't so relevant and take - ;; up space. - (dolist (key '(print-buffer kill-buffer save-buffer - write-file dired open-file)) - (define-key tool-bar-map (vector key) nil)) - (message-tool-bar-local-item-from-menu - 'message-send-and-exit "mail/send" tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'message-kill-buffer "close" tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'message-dont-send "cancel" tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'mml-attach-file "attach" tool-bar-map mml-mode-map) - (message-tool-bar-local-item-from-menu - 'ispell-message "spell" tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'mml-preview "preview" - tool-bar-map mml-mode-map) - (message-tool-bar-local-item-from-menu - 'message-insert-importance-high "important" - tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'message-insert-importance-low "unimportant" - tool-bar-map message-mode-map) - (message-tool-bar-local-item-from-menu - 'message-insert-disposition-notification-to "receipt" - tool-bar-map message-mode-map) - tool-bar-map))))) + (or (not message-tool-bar-map) force)) + (setq message-tool-bar-map + (let* ((load-path + (gmm-image-load-path-for-library "message" + "mail/save-draft.xpm" + nil t)) + (image-load-path (cons (car load-path) + (when (boundp 'image-load-path) + image-load-path)))) + (gmm-tool-bar-from-list message-tool-bar + message-tool-bar-zap-list + 'message-mode-map)))) + message-tool-bar-map) ;;; Group name completion. diff --git a/lisp/gnus/mm-bodies.el b/lisp/gnus/mm-bodies.el index c58eb6bd41d..a10b8b28399 100644 --- a/lisp/gnus/mm-bodies.el +++ b/lisp/gnus/mm-bodies.el @@ -56,6 +56,8 @@ ;; known to break servers. ;; Note: UTF-16 variants are invalid for text parts [RFC 2781], ;; so this can't happen :-/. + ;; PPS: Yes, it can happen if the user specifies UTF-16 in the MML + ;; markup. - jh. (utf-16 . base64) (utf-16be . base64) (utf-16le . base64)) @@ -251,7 +253,10 @@ decoding. If it is nil, default to `mail-parse-charset'." (mm-decode-content-transfer-encoding encoding type)) (when (and (featurep 'mule) ;; Fixme: Wrong test for unibyte session. (not (eq charset 'gnus-decoded))) - (let ((coding-system (mm-charset-to-coding-system charset))) + (let ((coding-system (mm-charset-to-coding-system + ;; Allow overwrite using + ;; `mm-charset-override-alist'. + charset nil t))) (if (and (not coding-system) (listp mail-parse-ignored-charsets) (memq 'gnus-unknown mail-parse-ignored-charsets)) @@ -282,7 +287,11 @@ decoding. If it is nil, default to `mail-parse-charset'." (setq charset mail-parse-charset)) (or (when (featurep 'mule) - (let ((coding-system (mm-charset-to-coding-system charset))) + (let ((coding-system (mm-charset-to-coding-system + charset + ;; Allow overwrite using + ;; `mm-charset-override-alist'. + nil t))) (if (and (not coding-system) (listp mail-parse-ignored-charsets) (memq 'gnus-unknown mail-parse-ignored-charsets)) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index a8c1f3a87a1..e16750cfcf6 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -177,6 +177,29 @@ system object in XEmacs." ;; no-MULE XEmacs: (car (memq cs (mm-get-coding-system-list)))))) +(defun mm-codepage-setup (number &optional alias) + "Create a coding system cpNUMBER. +The coding system is created using `codepage-setup'. If ALIAS is +non-nil, an alias is created and added to +`mm-charset-synonym-alist'. If ALIAS is a string, it's used as +the alias. Else windows-NUMBER is used." + (interactive + (let ((completion-ignore-case t) + (candidates (cp-supported-codepages))) + (list (completing-read "Setup DOS Codepage: (default 437) " candidates + nil t nil nil "437")))) + (when alias + (setq alias (if (stringp alias) + (intern alias) + (intern (format "windows-%s" number))))) + (let* ((cp (intern (format "cp%s" number)))) + (unless (mm-coding-system-p cp) + (codepage-setup number)) + (when (and alias + ;; Don't add alias if setup of cp failed. + (mm-coding-system-p cp)) + (add-to-list 'mm-charset-synonym-alist (cons alias cp))))) + (defvar mm-charset-synonym-alist `( ;; Not in XEmacs, but it's not a proper MIME charset anyhow. @@ -200,8 +223,61 @@ system object in XEmacs." ,@(if (and (not (mm-coding-system-p 'windows-1250)) (mm-coding-system-p 'cp1250)) '((windows-1250 . cp1250))) + ;; A Microsoft misunderstanding. + ,@(if (and (not (mm-coding-system-p 'unicode)) + (mm-coding-system-p 'utf-16-le)) + '((unicode . utf-16-le))) + ;; A Microsoft misunderstanding. + ,@(unless (mm-coding-system-p 'ks_c_5601-1987) + (if (mm-coding-system-p 'cp949) + '((ks_c_5601-1987 . cp949)) + '((ks_c_5601-1987 . euc-kr)))) ) - "A mapping from invalid charset names to the real charset names.") + "A mapping from unknown or invalid charset names to the real charset names.") + +(defcustom mm-charset-override-alist + `((iso-8859-1 . windows-1252)) + "A mapping from undesired charset names to their replacement. + +You may add pairs like (iso-8859-1 . windows-1252) here, +i.e. treat iso-8859-1 as windows-1252. windows-1252 is a +superset of iso-8859-1." + :type '(list (set :inline t + (const (iso-8859-1 . windows-1252)) + (const (undecided . windows-1252))) + (repeat :inline t + :tag "Other options" + (cons (symbol :tag "From charset") + (symbol :tag "To charset")))) + :version "23.0" ;; No Gnus + :group 'mime) + +(defcustom mm-charset-eval-alist + (if (featurep 'xemacs) + nil ;; I don't know what would be useful for XEmacs. + '(;; Emacs 21 offers 1250 1251 1253 1257. Emacs 22 provides autoloads for + ;; 1250-1258 (i.e. `mm-codepage-setup' does nothing). + (windows-1250 . (mm-codepage-setup 1250 t)) + (windows-1251 . (mm-codepage-setup 1251 t)) + (windows-1253 . (mm-codepage-setup 1253 t)) + (windows-1257 . (mm-codepage-setup 1257 t)))) + "An alist of (CHARSET . FORM) pairs. +If an article is encoded in an unknown CHARSET, FORM is +evaluated. This allows to load additional libraries providing +charsets on demand. If supported by your Emacs version, you +could use `autoload-coding-system' here." + :version "23.0" ;; No Gnus + :type '(list (set :inline t + (const (windows-1250 . (mm-codepage-setup 1250 t))) + (const (windows-1251 . (mm-codepage-setup 1251 t))) + (const (windows-1253 . (mm-codepage-setup 1253 t))) + (const (windows-1257 . (mm-codepage-setup 1257 t))) + (const (cp850 . (mm-codepage-setup 850 nil)))) + (repeat :inline t + :tag "Other options" + (cons (symbol :tag "charset") + (symbol :tag "form")))) + :group 'mime) (defvar mm-binary-coding-system (cond @@ -426,11 +502,17 @@ mail with multiple parts is preferred to sending a Unicode one.") (pop alist)) out))) -(defun mm-charset-to-coding-system (charset &optional lbt) +(defun mm-charset-to-coding-system (charset &optional lbt + allow-override) "Return coding-system corresponding to CHARSET. CHARSET is a symbol naming a MIME charset. If optional argument LBT (`unix', `dos' or `mac') is specified, it is -used as the line break code type of the coding system." +used as the line break code type of the coding system. + +If ALLOW-OVERRIDE is given, use `mm-charset-override-alist' to +map undesired charset names to their replacement. This should +only be used for decoding, not for encoding." + ;; OVERRIDE is used (only) in `mm-decode-body' and `mm-decode-string'. (when (stringp charset) (setq charset (intern (downcase charset)))) (when lbt @@ -442,6 +524,11 @@ used as the line break code type of the coding system." ((or (null (mm-get-coding-system-list)) (not (fboundp 'coding-system-get))) charset) + ;; Check override list quite early. Should only used for decoding, not for + ;; encoding! + ((and allow-override + (let ((cs (cdr (assq charset mm-charset-override-alist)))) + (and cs (mm-coding-system-p cs) cs)))) ;; ascii ((eq charset 'us-ascii) 'ascii) @@ -454,9 +541,27 @@ used as the line break code type of the coding system." ;;; (eq charset (coding-system-get charset 'mime-charset)) ) charset) + ;; Eval expressions from `mm-charset-eval-alist' + ((let* ((el (assq charset mm-charset-eval-alist)) + (cs (car el)) + (form (cdr el))) + (and cs + form + (prog2 + ;; Avoid errors... + (condition-case nil (eval form) (error nil)) + ;; (message "Failed to eval `%s'" form)) + (mm-coding-system-p cs) + (message "Added charset `%s' via `mm-charset-eval-alist'" cs)) + cs))) ;; Translate invalid charsets. ((let ((cs (cdr (assq charset mm-charset-synonym-alist)))) - (and cs (mm-coding-system-p cs) cs))) + (and cs + (mm-coding-system-p cs) + ;; (message + ;; "Using synonym `%s' from `mm-charset-synonym-alist' for `%s'" + ;; cs charset) + cs))) ;; Last resort: search the coding system list for entries which ;; have the right mime-charset in case the canonical name isn't ;; defined (though it should be). @@ -468,6 +573,11 @@ used as the line break code type of the coding system." (eq charset (or (coding-system-get c :mime-charset) (coding-system-get c 'mime-charset)))) (setq cs c))) + (unless cs + ;; Warn the user about unknown charset: + (if (fboundp 'gnus-message) + (gnus-message 7 "Unknown charset: %s" charset) + (message "Unknown charset: %s" charset))) cs)))) (defsubst mm-replace-chars-in-string (string from to) @@ -1070,7 +1180,8 @@ If SUFFIX is non-nil, add that at the end of the file name." (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) - (coding-system-get cs 'mime-charset))) + (or (coding-system-get cs :mime-charset) + (coding-system-get cs 'mime-charset)))) (defun mm-detect-mime-charset-region (start end) "Detect MIME charset of the text in the region between START and END." (let ((cs (mm-detect-coding-region start end))) |