1 ;;; gnus-compat.el --- Compatability functions for Gnus
3 ;; Copyright (C) 2012-2015 Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
25 ;; This package defines and redefines a bunch of functions for Gnus
26 ;; usage. The basic (and somewhat unsound) idea is to make all
27 ;; Emacsen look like the current trunk of Emacs. So it will define
28 ;; functions "missing" in other Emacs instances, and redefine other
29 ;; functions to work like the Emacs trunk versions.
31 (eval-when-compile (require 'cl
))
36 ;; XEmacs doesn't have this function.
37 (when (and (not (fboundp 'help-function-arglist
))
38 (fboundp 'function-arglist
))
39 (defun help-function-arglist (def &optional preserve-names
)
40 "Return a formal argument list for the function DEF.
41 PRESERVE-NAMES is ignored."
42 (cdr (car (read-from-string (downcase (function-arglist def
)))))))
44 ;; Modify this function on Emacs 23.1 and earlier to always return the
46 (when (and (fboundp 'help-function-arglist
)
47 (eq (help-function-arglist 'car
) t
))
48 (defvar gnus-compat-original-help-function-arglist
49 (symbol-function 'help-function-arglist
))
50 (defun help-function-arglist (def &optional preserve-names
)
51 "Return a formal argument list for the function DEF.
52 PRESERVE-NAMES is ignored."
53 (let ((orig (funcall gnus-compat-original-help-function-arglist def
)))
56 ;; Built-in subrs have the arglist hidden in the doc string.
57 (let ((doc (documentation def
)))
59 (string-match "\n\n\\((fn\\( .*\\)?)\\)\\'" doc
))
60 (cdr (car (read-from-string (downcase (match-string 1 doc
)))))))))))
62 (when (= (length (help-function-arglist 'delete-directory
)) 1)
63 (defvar gnus-compat-original-delete-directory
64 (symbol-function 'delete-directory
))
65 (defun delete-directory (directory &optional recursive trash
)
66 "Delete the directory named DIRECTORY. Does not follow symlinks.
67 If RECURSIVE is non-nil, all files in DIRECTORY are deleted as well.
69 (interactive "DDirectory: ")
71 (funcall gnus-compat-original-delete-directory directory
)
72 (dolist (file (directory-files directory t
))
73 (unless (member (file-name-nondirectory file
) '("." ".."))
74 (if (file-directory-p file
)
75 (delete-directory file t
)
77 (delete-directory directory
))))
81 (when (= (length (help-function-arglist 'url-retrieve
)) 5)
82 (defvar gnus-compat-original-url-retrieve
83 (symbol-function 'url-retrieve
))
84 (defun url-retrieve (url callback
&optional cbargs silent inhibit-cookies
)
85 "Retrieve URL asynchronously and call CALLBACK with CBARGS when finished."
86 (funcall gnus-compat-original-url-retrieve
87 url callback cbargs silent
)))
90 (when (and (not (fboundp 'timer-set-function
))
91 (fboundp 'set-itimer-function
))
92 (defun timer-set-function (timer function
&optional args
)
93 "Make TIMER call FUNCTION with optional ARGS when triggering."
94 (lexical-let ((function function
)
96 (set-itimer-function timer
97 (lambda (process status
)
98 (apply function process status args
))))))
101 (unless (fboundp 'bound-and-true-p
)
102 (defmacro bound-and-true-p
(var)
103 "Return the value of symbol VAR if it is bound, else nil."
105 (symbol-value var
))))
108 ;; Emacs less than 24.3
109 (unless (fboundp 'add-face
)
110 (defun add-face (beg end face
)
111 "Combine FACE BEG and END."
114 (let ((oldval (get-text-property b
'face
)))
116 b
(setq b
(next-single-property-change b
'face nil end
))
117 'face
(cond ((null oldval
)
120 (not (keywordp (car oldval
))))
123 (list face oldval
)))))))))
125 (unless (fboundp 'move-beginning-of-line
)
126 (defun move-beginning-of-line (arg)
130 (beginning-of-line)))
132 (unless (fboundp 'delete-dups
)
133 (defun delete-dups (list)
134 "Destructively remove `equal' duplicates from LIST.
135 Store the result in LIST and return it. LIST must be a proper list.
136 Of several `equal' occurrences of an element in LIST, the first
140 (setcdr tail
(delete (car tail
) (cdr tail
)))
141 (setq tail
(cdr tail
))))
144 (unless (fboundp 'declare-function
)
145 (defmacro declare-function
(&rest r
)))
147 (unless (fboundp 'string-bytes
)
148 (defun string-bytes (string)
149 (length (if (or (mm-coding-system-p 'utf-8
)
151 (let (mucs-ignore-version-incompatibilities)
152 (require 'un-define
))))
153 (mm-encode-coding-string string
'utf-8
)
156 (unless (fboundp 'process-live-p
)
157 (defun process-live-p (process)
158 "Returns non-nil if PROCESS is alive.
159 A process is considered alive if its status is `run', `open',
160 `listen', `connect' or `stop'. Value is nil if PROCESS is not a
162 (and (processp process
)
163 (memq (process-status process
)
164 '(run open listen connect stop
)))))
166 ;; XEmacs doesn't have auto-autoloads for overlay functions.
167 (when (featurep 'xemacs
)
170 (provide 'gnus-compat
)
172 ;; gnus-compat.el ends here