From 2d4b5de106323889c0572afb44dab1579400e086 Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Tue, 4 Mar 1997 18:55:30 +0000 Subject: [PATCH 1/1] *** empty log message *** --- lisp/ChangeLog | 47 +++++++++++ lisp/custom.el | 94 +++++++++++++--------- lisp/dgnushack.el | 2 +- lisp/gnus-cus.el | 2 +- lisp/gnus-msg.el | 2 +- lisp/gnus-nocem.el | 8 +- lisp/gnus-topic.el | 2 +- lisp/gnus-xmas.el | 2 +- lisp/gnus.el | 8 +- lisp/mailheader.el | 180 +++++++++++++++++++++++++++++++++++++++++ lisp/message-xms.el | 94 ++++++++++++++++++++++ lisp/message.el | 12 ++- lisp/nnheader-es.el | 192 ++++++++++++++++++++++++++++++++++++++++++++ lisp/nnheader.el | 2 +- 14 files changed, 593 insertions(+), 54 deletions(-) create mode 100644 lisp/mailheader.el create mode 100644 lisp/message-xms.el create mode 100644 lisp/nnheader-es.el diff --git a/lisp/ChangeLog b/lisp/ChangeLog index daa7e9a54..327a3950d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,52 @@ +Thu May 30 05:04:07 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-article-hide-headers): Show boring headers as + well. + +Tue May 28 15:47:15 1996 Per Abrahamsen + + * custom.el ((fboundp 'event-point)): Wrong test. + +Thu May 30 03:19:21 1996 Lars Magne Ingebrigtsen + + * gnus.el (gnus-headers-decode-quoted-printable): Wrong name. + + * message.el (message-header-hook): Defvarred. + + * gnus-nocem.el (gnus-nocem-verifyer): Couldn't verify that it + works. + +Thu May 30 00:25:46 1996 Lars Magne Ingebrigtsen + + * gnus-nocem.el (gnus-nocem-verify-issuer): Widen before + verifying. + +Wed May 29 23:19:46 1996 Lars Magne Ingebrigtsen + + * custom.el (custom-xmas-set-text-properties): Changed name. + +Wed May 29 23:01:52 1996 Paul D. Smith + + * gnus-cus.el: toggle -> sexp. + +Wed May 29 23:00:48 1996 Lars Magne Ingebrigtsen + + * gnus-msg.el (gnus-inews-add-send-actions): Use `gnus-add-hook'. + +Wed May 29 22:52:47 1996 Francois Felix Ingrand + + * gnus-topic.el (gnus-topic-remove-group): Would not delete groups + from topics. + +Wed May 29 08:57:20 1996 Lars Magne Ingebrigtsen + + * custom.el (custom-face-lookup): Avoid `modify-face' to speed up + face retrieval on Indys & over slow modem lines. + Wed May 29 05:08:04 1996 Lars Magne Ingebrigtsen + * gnus.el: Gnus v5.2.2 is released. + * custom.el (custom-xmas-add-text-properties, custom-xmas-put-text-property): New functions used throughout. May now work under XEmacs. diff --git a/lisp/custom.el b/lisp/custom.el index e1e5a0fdb..5fe9a5a50 100644 --- a/lisp/custom.el +++ b/lisp/custom.el @@ -89,18 +89,26 @@ (progn (fset 'custom-add-text-properties 'custom-xmas-add-text-properties) (fset 'custom-put-text-property 'custom-xmas-put-text-property) - (fset 'custom-extent-start-open 'custom-xmas-extent-start-open)) + (fset 'custom-extent-start-open 'custom-xmas-extent-start-open) + (fset 'custom-set-text-properties + (if (fboundp 'set-text-properties) + 'set-text-properties)) + (fset 'custom-buffer-substring-no-properties + (if (fboundp 'buffer-substring-no-properties) + 'buffer-substring-no-properties + 'custom-xmas-buffer-substring-no-properties))) (fset 'custom-add-text-properties 'add-text-properties) (fset 'custom-put-text-property 'put-text-property) - (fset 'custom-extent-start-open 'ignore)) + (fset 'custom-extent-start-open 'ignore) + (fset 'custom-set-text-properties 'set-text-properties) + (fset 'custom-buffer-substring-no-properties + 'buffer-substring-no-properties)) -(or (fboundp 'buffer-substring-no-properties) - ;; Introduced in Emacs 19.29. - (defun buffer-substring-no-properties (beg end) - "Return the text from BEG to END, without text properties, as a string." - (let ((string (buffer-substring beg end))) - (set-text-properties 0 (length string) nil string) - string))) +(defun custom-xmas-buffer-substring-no-properties (beg end) + "Return the text from BEG to END, without text properties, as a string." + (let ((string (buffer-substring beg end))) + (custom-set-text-properties 0 (length string) nil string) + string)) (or (fboundp 'add-to-list) ;; Introduced in Emacs 19.29. @@ -195,18 +203,16 @@ STRING should be given if the last search was by `string-match' on STRING." (and (fboundp 'set-face-underline-p) (funcall 'set-face-underline-p 'underline t)))) -(or (fboundp 'set-text-properties) - ;; Missing in XEmacs 19.12. - (defun set-text-properties (start end props &optional buffer) - (if (or (null buffer) (bufferp buffer)) - (if props - (while props - (custom-put-text-property - start end (car props) (nth 1 props) buffer) - (setq props (nthcdr 2 props))) - (remove-text-properties start end ()))))) - -(or (fboundp 'event-closest-point) +(defun custom-xmas-set-text-properties (start end props &optional buffer) + (if (or (null buffer) (bufferp buffer)) + (if props + (while props + (custom-put-text-property + start end (car props) (nth 1 props) buffer) + (setq props (nthcdr 2 props))) + (remove-text-properties start end ())))) + +(or (fboundp 'event-point) ;; Missing in Emacs 19.29. (defun event-point (event) "Return the character position of the given mouse-motion, button-press, @@ -1523,8 +1529,7 @@ custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" value)))) (defun custom-face-lookup (fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes. -FG BG STIPPLE BOLD ITALIC UNDERLINE" + "Lookup or create a face with specified attributes." (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" (or fg "default") (or bg "default") @@ -1533,12 +1538,25 @@ FG BG STIPPLE BOLD ITALIC UNDERLINE" (if (and (custom-facep name) (fboundp 'make-face)) () - (make-face name) - (modify-face name - (if (string-equal fg "default") nil fg) - (if (string-equal bg "default") nil bg) - (if (string-equal stipple "default") nil stipple) - bold italic underline)) + (copy-face 'default name) + (when (and fg + (not (string-equal fg "default"))) + (set-face-foreground name fg)) + (when (and bg + (not (string-equal fg "default"))) + (set-face-background name bg)) + (when (and stipple + (not (eq stipple 'as-is))) + (set-face-stipple name)) + (when (and bold + (not (eq bold 'as-is))) + (make-face-bold name)) + (when (and italic + (not (eq italic 'as-is))) + (make-face-italic name)) + (when (and underline + (not (eq underline 'as-is))) + (set-face-underline-p name))) name)) (defun custom-face-hack (field value) @@ -1875,13 +1893,13 @@ If the optional argument SAVE is non-nil, use that for saving changes." "Describe how to execute COMMAND." (let ((from (point))) (insert "`" (key-description (where-is-internal command nil t)) "'") - (set-text-properties from (point) - (list 'face custom-button-face - mouse-face custom-mouse-face - 'custom-jump t ;Make TAB jump over it. - 'custom-tag command - 'start-open t - 'end-open t)) + (custom-set-text-properties from (point) + (list 'face custom-button-face + mouse-face custom-mouse-face + 'custom-jump t ;Make TAB jump over it. + 'custom-tag command + 'start-open t + 'end-open t)) (custom-category-set from (point) 'custom-documentation-properties)) (custom-help-insert ": " (custom-first-line (documentation command)) "\n")) @@ -2203,7 +2221,7 @@ If the optional argument is non-nil, show text iff the argument is positive." (insert-char (custom-padding custom) (- (custom-width custom) (- (point) from))) (custom-field-move field from (point)) - (set-text-properties + (custom-set-text-properties from (point) (list 'custom-field field 'custom-tag field @@ -2214,7 +2232,7 @@ If the optional argument is non-nil, show text iff the argument is positive." (defun custom-field-read (field) ;; Read the screen content of FIELD. (custom-read (custom-field-custom field) - (buffer-substring-no-properties (custom-field-start field) + (custom-buffer-substring-no-properties (custom-field-start field) (custom-field-end field)))) ;; Fields are shown in a special `active' face when point is inside diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el index 6f24e88f3..0abf64bcd 100644 --- a/lisp/dgnushack.el +++ b/lisp/dgnushack.el @@ -47,7 +47,7 @@ (setq byte-compile-warnings '(free-vars unresolved callargs redefine obsolete)))) (when (or (not (member file '("gnus-xmas.el" "gnus-picon.el" - "message-xmas.el" "nnheader-ems.el"))) + "message-xmas.el"))) xemacs) (condition-case () (byte-compile-file file) diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el index a08bf4e28..c97325a7c 100644 --- a/lisp/gnus-cus.el +++ b/lisp/gnus-cus.el @@ -74,7 +74,7 @@ less space and be faster as a result.") page-marker tree-menu binary-menu pick-menu grouplens-menu)) (name . gnus-visual) - (type . toggle)) + (type . sexp)) ((tag . "WWW Browser") (doc . "\ WWW Browser to call when clicking on an URL button in the article buffer. diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index 5583bd754..582755580 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -138,7 +138,7 @@ the group.") (defun gnus-inews-add-send-actions (winconf buffer article) (gnus-make-local-hook 'message-sent-hook) - (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) + (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) (setq message-post-method `(lambda (arg) (gnus-post-method arg ,gnus-newsgroup-name))) diff --git a/lisp/gnus-nocem.el b/lisp/gnus-nocem.el index 65eb6d242..d73cf3382 100644 --- a/lisp/gnus-nocem.el +++ b/lisp/gnus-nocem.el @@ -48,10 +48,10 @@ (defvar gnus-nocem-expiry-wait 15 "*Number of days to keep NoCeM headers in the cache.") -(defvar gnus-nocem-verifyer 'mc-verify +(defvar gnus-nocem-verifyer nil "*Function called to verify that the NoCeM message is valid. -If the function in this variable isn't bound, the message will -be used unconditionally.") +One likely value is `mc-verify'. If the function in this variable +isn't bound, the message will be used unconditionally.") ;;; Internal variables @@ -151,6 +151,7 @@ be used unconditionally.") (defun gnus-nocem-verify-issuer (person) "Verify using PGP that the canceler is who she says she is." + (widen) (if (fboundp gnus-nocem-verifyer) (funcall gnus-nocem-verifyer) ;; If we don't have MailCrypt, then we use the message anyway. @@ -158,7 +159,6 @@ be used unconditionally.") (defun gnus-nocem-enter-article () "Enter the current article into the NoCeM cache." - (widen) (goto-char (point-min)) (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t)) (e (search-forward "\n@@END NCM BODY\n" nil t)) diff --git a/lisp/gnus-topic.el b/lisp/gnus-topic.el index ab9a6fb2d..11f07da19 100644 --- a/lisp/gnus-topic.el +++ b/lisp/gnus-topic.el @@ -772,7 +772,7 @@ If COPYP, copy the groups instead." (buffer-read-only nil)) (when (and topicl group) (gnus-delete-line) - (delq (gnus-group-group-name) topicl)) + (delete group topicl)) (gnus-group-position-point))) (defun gnus-topic-copy-group (n topic) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index e04cd25cd..6d522f3f7 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -28,7 +28,7 @@ (require 'text-props) (eval-when-compile (require 'cl)) (defvar menu-bar-mode t) -(require 'message-xmas) +(require 'message-xms) (defvar gnus-xmas-glyph-directory nil "*Directory where Gnus logos and icons are located. diff --git a/lisp/gnus.el b/lisp/gnus.el index 02113fb26..ab9ae3d6a 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -1723,7 +1723,7 @@ variable (string, integer, character, etc).") "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls + Boys)" "The mail address of the Gnus maintainers.") -(defconst gnus-version-number "5.2.2" +(defconst gnus-version-number "5.2.3" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -13807,7 +13807,9 @@ Provided for backwards compatibility." If given a negative prefix, always show; if given a positive prefix, always hide." (interactive "P") - (unless (gnus-article-check-hidden-text 'headers arg) + (if (gnus-article-check-hidden-text 'headers arg) + ;; Show boring headers as well. + (gnus-article-show-hidden-text 'boring-headers) ;; This function might be inhibited. (unless gnus-inhibit-hiding (save-excursion @@ -14047,7 +14049,7 @@ always hide." (process-send-region "gnus-x-face" beg end) (process-send-eof "gnus-x-face"))))))))) -(defalias 'gnus-header-decode-quoted-printable 'gnus-decode-rfc1522) +(defalias 'gnus-headers-decode-quoted-printable 'gnus-decode-rfc1522) (defun gnus-decode-rfc1522 () "Hack to remove QP encoding from headers." (let ((case-fold-search t) diff --git a/lisp/mailheader.el b/lisp/mailheader.el new file mode 100644 index 000000000..b82fb66e8 --- /dev/null +++ b/lisp/mailheader.el @@ -0,0 +1,180 @@ +;;; mail-header.el --- Mail header parsing, merging, formatting + +;; Copyright (C) 1996 by Free Software Foundation, Inc. + +;; Author: Erik Naggum +;; Keywords: tools, mail, 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This package provides an abstraction to RFC822-style messages, used in +;; mail news, and some other systems. The simple syntactic rules for such +;; headers, such as quoting and line folding, are routinely reimplemented +;; in many individual packages. This package removes the need for this +;; redundancy by representing message headers as association lists, +;; offering functions to extract the set of headers from a message, to +;; parse individual headers, to merge sets of headers, and to format a set +;; of headers. + +;; The car of each element in the message-header alist is a symbol whose +;; print name is the name of the header, in all lower-case. The cdr of an +;; element depends on the operation. After extracting headers from a +;; messge, it is a string, the value of the header. An extracted set of +;; headers may be parsed further, which may turn it into a list, whose car +;; is the original value and whose subsequent elements depend on the +;; header. For formatting, it is evaluated to obtain the strings to be +;; inserted. For merging, one set of headers consists of strings, while +;; the other set will be evaluated with the symbols in the first set of +;; headers bound to their respective values. + +;;; Code: + +;; Make the byte-compiler shut up. +(defvar headers) + +(defun mail-header-extract () + "Extract headers from current buffer after point. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (let ((message-headers ()) (top (point)) + start end) + (while (and (setq start (point)) + (> (skip-chars-forward "^\0- :") 0) + (= (following-char) ?:) + (setq end (point)) + (progn (forward-char) + (> (skip-chars-forward " \t") 0))) + (let ((header (intern (downcase (buffer-substring start end)))) + (value (list (buffer-substring + (point) (progn (end-of-line) (point)))))) + (while (progn (forward-char) (> (skip-chars-forward " \t") 0)) + (push (buffer-substring (point) (progn (end-of-line) (point))) + value)) + (push (if (cdr value) + (cons header (mapconcat #'identity (nreverse value) " ")) + (cons header (car value))) + message-headers))) + (goto-char top) + (nreverse message-headers))) + +(defun mail-header-extract-no-properties () + "Extract headers from current buffer after point, without properties. +Returns a header alist, where each element is a cons cell (name . value), +where NAME is a symbol, and VALUE is the string value of the header having +that name." + (mapcar + (lambda (elt) + (set-text-properties 0 (length (cdr elt)) nil (cdr elt)) + elt) + (mail-header-extract))) + +(defun mail-header-parse (parsing-rules headers) + "Apply PARSING-RULES to HEADERS. +PARSING-RULES is an alist whose keys are header names (symbols) and whose +value is a parsing function. The function takes one argument, a string, +and return a list of values, which will destructively replace the value +associated with the key in HEADERS, after being prepended with the original +value." + (dolist (rule parsing-rules) + (let ((header (assq (car rule) headers))) + (when header + (if (consp (cdr header)) + (setf (cddr header) (funcall (cdr rule) (cadr header))) + (setf (cdr header) + (cons (cdr header) (funcall (cdr rule) (cdr header)))))))) + headers) + +(defsubst mail-header (header &optional header-alist) + "Return the value associated with header HEADER in HEADER-ALIST. +If the value is a string, it is the original value of the header. If the +value is a list, its first element is the original value of the header, +with any subsequent elements bing the result of parsing the value. +If HEADER-ALIST is nil, the dynamically bound variable `headers' is used." + (cdr (assq header (or header-alist headers)))) + +(defun mail-header-set (header value &optional header-alist) + "Set the value associated with header HEADER to VALUE in HEADER-ALIST. +HEADER-ALIST defaults to the dynamically bound variable `headers' if nil. +See `mail-header' for the semantics of VALUE." + (let* ((alist (or header-alist headers)) + (entry (assq header alist))) + (if entry + (setf (cdr entry) value) + (nconc alist (list (cons header value))))) + value) + +(defsetf mail-header (header &optional header-alist) (value) + `(mail-header-set ,header ,value ,header-alist)) + +(defun mail-header-merge (merge-rules headers) + "Return a new header alist with MERGE-RULES applied to HEADERS. +MERGE-RULES is an alist whose keys are header names (symbols) and whose +values are forms to evaluate, the results of which are the new headers. It +should be a string or a list of string. The first element may be nil to +denote that the formatting functions must use the remaining elements, or +skip the header altogether if there are no other elements. + The macro `mail-header' can be used to access headers in HEADERS." + (mapcar + (lambda (rule) + (cons (car rule) (eval (cdr rule)))) + merge-rules)) + +(defvar mail-header-format-function + (lambda (header value) + "Function to format headers without a specified formatting function." + (insert (capitalize (symbol-name header)) + ": " + (if (consp value) (car value) value) + "\n"))) + +(defun mail-header-format (format-rules headers) + "Use FORMAT-RULES to format HEADERS and insert into current buffer. +FORMAT-RULES is an alist whose keys are header names (symbols), and whose +values are functions that format the header, the results of which are +inserted, unless it is nil. The function takes two arguments, the header +symbol, and the value of that header. If the function itself is nil, the +default action is to insert the value of the header, unless it is nil. +The headers are inserted in the order of the FORMAT-RULES. +A key of t represents any otherwise unmentioned headers. +A key of nil has as its value a list of defaulted headers to ignore." + (let ((ignore (append (cdr (assq nil format-rules)) + (mapcar #'car format-rules)))) + (dolist (rule format-rules) + (let* ((header (car rule)) + (value (mail-header header))) + (cond ((null header) 'ignore) + ((eq header t) + (dolist (defaulted headers) + (unless (memq (car defaulted) ignore) + (let* ((header (car defaulted)) + (value (cdr defaulted))) + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (value + (if (cdr rule) + (funcall (cdr rule) header value) + (funcall mail-header-format-function header value)))))) + (insert "\n"))) + +(provide 'mailheader) + +;;; mail-header.el ends here diff --git a/lisp/message-xms.el b/lisp/message-xms.el new file mode 100644 index 000000000..1f4a07ba6 --- /dev/null +++ b/lisp/message-xms.el @@ -0,0 +1,94 @@ +;;; message-xms.el --- XEmacs extensions to message +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; Keywords: mail, 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(defvar message-xmas-glyph-directory nil + "*Directory where Message logos and icons are located. +If this variable is nil, Message will try to locate the directory +automatically.") + +(defvar message-use-toolbar 'default-toolbar + "*If nil, do not use a toolbar. +If it is non-nil, it must be a toolbar. The five legal values are +`default-toolbar', `top-toolbar', `bottom-toolbar', +`right-toolbar', and `left-toolbar'.") + +(defvar message-toolbar + '([message-spell toolbar-ispell t "Spell"] + [message-help toolbar-info t "Message help"]) + "The message buffer toolbar.") + +(defun message-xmas-find-glyph-directory (&optional package) + (setq package (or package "message")) + (let ((path load-path) + dir result) + ;; We try to find the dir by looking at the load path, + ;; stripping away the last component and adding "etc/". + (while path + (if (and (car path) + (file-exists-p + (setq dir (concat + (file-name-directory + (directory-file-name (car path))) + "etc/" (or package "message") "/"))) + (file-directory-p dir)) + (setq result dir + path nil) + (setq path (cdr path)))) + result)) + +(defun message-xmas-setup-toolbar (bar &optional force package) + (let ((dir (message-xmas-find-glyph-directory package)) + icon up down disabled name) + (unless package + (setq message-xmas-glyph-directory dir)) + (when dir + (if (and (not force) + (boundp (aref (car bar) 0))) + dir + (while bar + (setq icon (aref (car bar) 0) + name (symbol-name icon) + bar (cdr bar)) + (setq up (concat dir name "-up.xpm")) + (setq down (concat dir name "-down.xpm")) + (setq disabled (concat dir name "-disabled.xpm")) + (if (not (file-exists-p up)) + (set icon nil) + (set icon (toolbar-make-button-list + up (and (file-exists-p down) down) + (and (file-exists-p disabled) disabled))))) + dir)))) + +(defun message-setup-toolbar () + (and message-use-toolbar + (message-xmas-setup-toolbar message-toolbar) + (set-specifier (symbol-value message-use-toolbar) + (cons (current-buffer) message-toolbar)))) + +(provide 'message-xms) + +;;; message-xms.el ends here diff --git a/lisp/message.el b/lisp/message.el index 2d40bac07..f236ec2eb 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -31,7 +31,7 @@ (eval-when-compile (require 'cl)) -(require 'mail-header) +(require 'mailheader) (require 'nnheader) (require 'timezone) (require 'easymenu) @@ -255,6 +255,9 @@ The function `message-setup' runs this hook.") (defvar message-mode-hook nil "Hook run in message mode buffers.") +(defvar message-header-hook nil + "Hook run in a message mode buffer narrowed to the headers.") + (defvar message-header-setup-hook nil "Hook called narrowed to the headers when setting up a message buffer.") @@ -467,7 +470,7 @@ The cdr of ech entry is a function for applying the face to a region.") "Alist used for formatting headers.") (eval-and-compile - (autoload 'message-setup-toolbar "message-xmas") + (autoload 'message-setup-toolbar "message-xms") (autoload 'mh-send-letter "mh-comp")) @@ -734,6 +737,9 @@ Return the number of headers removed." ["Send Message" message-send-and-exit t] ["Abort Message" message-dont-send t])) +(defvar facemenu-add-face-function) +(defvar facemenu-remove-face-function) + ;;;###autoload (defun message-mode () "Major mode for editing mail and news to be sent. @@ -2757,7 +2763,7 @@ which specify the range to operate on." ;; Support for toolbar (when (string-match "XEmacs\\|Lucid" emacs-version) - (require 'message-xmas)) + (require 'message-xms)) ;;; Group name completion. diff --git a/lisp/nnheader-es.el b/lisp/nnheader-es.el new file mode 100644 index 000000000..fb02e0f66 --- /dev/null +++ b/lisp/nnheader-es.el @@ -0,0 +1,192 @@ +;;; nnheader-es.el --- making Gnus backends work under different Emacsen +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen +;; 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., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Code: + +(defun nnheader-xmas-run-at-time (time repeat function &rest args) + (start-itimer + "nnheader-run-at-time" + `(lambda () + (,function ,@args)) + time repeat)) + +(defun nnheader-xmas-cancel-timer (timer) + (delete-itimer timer)) + +;; Written by Erik Naggum . +;; Saved by Steve Baur . +(defun nnheader-xmas-insert-file-contents-literally (filename &optional visit beg end replace) + "Like `insert-file-contents', q.v., but only reads in the file. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ( ; (file-name-handler-alist nil) + (format-alist nil) + (after-insert-file-functions nil) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil))) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + +(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile) + "Read file FILENAME into a buffer and return the buffer. +If a buffer exists visiting FILENAME, return that one, but +verify that the file has not changed since visited or saved. +The buffer is not selected, just returned to the caller." + (setq filename + (abbreviate-file-name + (expand-file-name filename))) + (if (file-directory-p filename) + (if find-file-run-dired + (dired-noselect filename) + (error "%s is a directory." filename)) + (let* ((buf (get-file-buffer filename)) + (truename (abbreviate-file-name (file-truename filename))) + (number (nthcdr 10 (file-attributes truename))) + ;; Find any buffer for a file which has same truename. + (other (and (not buf) + (if (fboundp 'find-buffer-visiting) + (find-buffer-visiting filename) + (get-file-buffer filename)))) + error) + ;; Let user know if there is a buffer with the same truename. + (if other + (progn + (or nowarn + (string-equal filename (buffer-file-name other)) + (message "%s and %s are the same file" + filename (buffer-file-name other))) + ;; Optionally also find that buffer. + (if (or (and (boundp 'find-file-existing-other-name) + find-file-existing-other-name) + find-file-visit-truename) + (setq buf other)))) + (if buf + (or nowarn + (verify-visited-file-modtime buf) + (cond ((not (file-exists-p filename)) + (error "File %s no longer exists!" filename)) + ((yes-or-no-p + (if (string= (file-name-nondirectory filename) + (buffer-name buf)) + (format + (if (buffer-modified-p buf) + "File %s changed on disk. Discard your edits? " + "File %s changed on disk. Reread from disk? ") + (file-name-nondirectory filename)) + (format + (if (buffer-modified-p buf) + "File %s changed on disk. Discard your edits in %s? " + "File %s changed on disk. Reread from disk into %s? ") + (file-name-nondirectory filename) + (buffer-name buf)))) + (save-excursion + (set-buffer buf) + (revert-buffer t t))))) + (save-excursion +;;; The truename stuff makes this obsolete. +;;; (let* ((link-name (car (file-attributes filename))) +;;; (linked-buf (and (stringp link-name) +;;; (get-file-buffer link-name)))) +;;; (if (bufferp linked-buf) +;;; (message "Symbolic link to file in buffer %s" +;;; (buffer-name linked-buf)))) + (setq buf (create-file-buffer filename)) + ;; (set-buffer-major-mode buf) + (set-buffer buf) + (erase-buffer) + (if rawfile + (condition-case () + (nnheader-insert-file-contents-literally filename t) + (file-error + ;; Unconditionally set error + (setq error t))) + (condition-case () + (insert-file-contents filename t) + (file-error + ;; Run find-file-not-found-hooks until one returns non-nil. + (or t ; (run-hook-with-args-until-success 'find-file-not-found-hooks) + ;; If they fail too, set error. + (setq error t))))) + ;; Find the file's truename, and maybe use that as visited name. + (setq buffer-file-truename truename) + (setq buffer-file-number number) + ;; On VMS, we may want to remember which directory in a search list + ;; the file was found in. + (and (eq system-type 'vax-vms) + (let (logical) + (if (string-match ":" (file-name-directory filename)) + (setq logical (substring (file-name-directory filename) + 0 (match-beginning 0)))) + (not (member logical find-file-not-true-dirname-list))) + (setq buffer-file-name buffer-file-truename)) + (if find-file-visit-truename + (setq buffer-file-name + (setq filename + (expand-file-name buffer-file-truename)))) + ;; Set buffer's default directory to that of the file. + (setq default-directory (file-name-directory filename)) + ;; Turn off backup files for certain file names. Since + ;; this is a permanent local, the major mode won't eliminate it. + (and (not (funcall backup-enable-predicate buffer-file-name)) + (progn + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (if rawfile + nil + (after-find-file error (not nowarn))))) + buf))) + +(eval-and-compile + (cond + ;; Do XEmacs function bindings. + ((string-match "XEmacs\\|Lucid" emacs-version) + (fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time) + (fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer) + (fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect) + (fset 'nnheader-insert-file-contents-literally + (if (fboundp 'insert-file-contents-literally) + 'insert-file-contents-literally + 'nnheader-xmas-insert-file-contents-literally))) + ;; Do Emacs function bindings. + (t + (fset 'nnheader-run-at-time 'run-at-time) + (fset 'nnheader-cancel-timer 'cancel-timer) + (fset 'nnheader-find-file-noselect 'find-file-noselect) + (fset 'nnheader-insert-file-contents-literally + 'insert-file-contents-literally) + ))) + +(provide 'nnheader-es) + +;;; nnheader-es.el ends here. diff --git a/lisp/nnheader.el b/lisp/nnheader.el index 147f4dbd4..197b2d042 100644 --- a/lisp/nnheader.el +++ b/lisp/nnheader.el @@ -544,7 +544,7 @@ without formatting." "Concat DIR as directory to FILE." (concat (file-name-as-directory dir) file)) -(require 'nnheader-ems) +(require 'nnheader-es) (run-hooks 'nnheader-load-hook) -- 2.25.1