+Thu May 30 05:04:07 1996 Lars Magne Ingebrigtsen <larsi@aegir.ifi.uio.no>
+
+ * gnus.el (gnus-article-hide-headers): Show boring headers as
+ well.
+
+Tue May 28 15:47:15 1996 Per Abrahamsen <abraham@dina.kvl.dk>
+
+ * custom.el ((fboundp 'event-point)): Wrong test.
+
+Thu May 30 03:19:21 1996 Lars Magne Ingebrigtsen <larsi@aegir.ifi.uio.no>
+
+ * 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 <larsi@ylfing.ifi.uio.no>
+
+ * gnus-nocem.el (gnus-nocem-verify-issuer): Widen before
+ verifying.
+
+Wed May 29 23:19:46 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * custom.el (custom-xmas-set-text-properties): Changed name.
+
+Wed May 29 23:01:52 1996 Paul D. Smith <psmith@baynetworks.com>
+
+ * gnus-cus.el: toggle -> sexp.
+
+Wed May 29 23:00:48 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * gnus-msg.el (gnus-inews-add-send-actions): Use `gnus-add-hook'.
+
+Wed May 29 22:52:47 1996 Francois Felix Ingrand <felix@laas.fr>
+
+ * gnus-topic.el (gnus-topic-remove-group): Would not delete groups
+ from topics.
+
+Wed May 29 08:57:20 1996 Lars Magne Ingebrigtsen <lars@eyesore.no>
+
+ * 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 <larsi@ifi.uio.no>
+ * 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.
(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.
(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,
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")
(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)
"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"))
(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
(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
(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)
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.
(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)))
(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
(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.
(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))
(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)
(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.
"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)
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
(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)
--- /dev/null
+;;; mail-header.el --- Mail header parsing, merging, formatting
+
+;; Copyright (C) 1996 by Free Software Foundation, Inc.
+
+;; Author: Erik Naggum <erik@arcana.naggum.no>
+;; 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
--- /dev/null
+;;; message-xms.el --- XEmacs extensions to message
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 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
(eval-when-compile
(require 'cl))
-(require 'mail-header)
+(require 'mailheader)
(require 'nnheader)
(require 'timezone)
(require 'easymenu)
(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.")
"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"))
\f
["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.
;; Support for toolbar
(when (string-match "XEmacs\\|Lucid" emacs-version)
- (require 'message-xmas))
+ (require 'message-xms))
;;; Group name completion.
--- /dev/null
+;;; nnheader-es.el --- making Gnus backends work under different Emacsen
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 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 <erik@naggum.no>.
+;; Saved by Steve Baur <steve@miranova.com>.
+(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.
"Concat DIR as directory to FILE."
(concat (file-name-as-directory dir) file))
-(require 'nnheader-ems)
+(require 'nnheader-es)
(run-hooks 'nnheader-load-hook)
projects / gnus / commitdiff