Update copyright year to 2016
[gnus] / lisp / gnus-compat.el
1 ;;; gnus-compat.el --- Compatability functions for Gnus
2
3 ;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: compat
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
22
23 ;;; Commentary:
24
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.
30
31 (eval-when-compile (require 'cl))
32
33 (ignore-errors
34   (require 'help-fns))
35
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)))))))
43
44 ;; Modify this function on Emacs 23.1 and earlier to always return the
45 ;; right answer.
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)))
54       (if (not (eq orig t))
55           orig
56         ;; Built-in subrs have the arglist hidden in the doc string.
57         (let ((doc (documentation def)))
58           (when (and doc
59                      (string-match "\n\n\\((fn\\( .*\\)?)\\)\\'" doc))
60             (cdr (car (read-from-string (downcase (match-string 1 doc)))))))))))
61
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.
68 TRASH is ignored."
69     (interactive "DDirectory: ")
70     (if (not recursive)
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)
76             (delete-file file))))
77       (delete-directory directory))))
78
79 ;; Emacs 24.0.93
80 (require 'url)
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)))
88
89 ;; XEmacs
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)
95                   (args args))
96       (set-itimer-function timer
97                            (lambda (process status)
98                              (apply function process status args))))))
99
100 ;; XEmacs 21.4
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."
104     (and (boundp var)
105          (symbol-value var))))
106
107
108 ;; Emacs less than 24.3
109 (unless (fboundp 'add-face)
110   (defun add-face (beg end face)
111     "Combine FACE BEG and END."
112     (let ((b beg))
113       (while (< b end)
114         (let ((oldval (get-text-property b 'face)))
115           (put-text-property
116            b (setq b (next-single-property-change b 'face nil end))
117            'face (cond ((null oldval)
118                         face)
119                        ((and (consp oldval)
120                              (not (keywordp (car oldval))))
121                         (cons face oldval))
122                        (t
123                         (list face oldval)))))))))
124
125 (unless (fboundp 'move-beginning-of-line)
126   (defun move-beginning-of-line (arg)
127     (interactive "p")
128     (unless (= arg 1)
129       (forward-line arg))
130     (beginning-of-line)))
131
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
137 one is kept."
138     (let ((tail list))
139       (while tail
140         (setcdr tail (delete (car tail) (cdr tail)))
141         (setq tail (cdr tail))))
142     list))
143
144 (unless (fboundp 'declare-function)
145   (defmacro declare-function (&rest r)))
146
147 (unless (fboundp 'string-bytes)
148   (defun string-bytes (string)
149     (length (if (or (mm-coding-system-p 'utf-8)
150                     (ignore-errors
151                       (let (mucs-ignore-version-incompatibilities)
152                         (require 'un-define))))
153                 (mm-encode-coding-string string 'utf-8)
154               string))))
155
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
161 process."
162     (and (processp process)
163          (memq (process-status process)
164                '(run open listen connect stop)))))
165
166 ;; XEmacs doesn't have auto-autoloads for overlay functions.
167 (when (featurep 'xemacs)
168   (require 'overlay))
169
170 (provide 'gnus-compat)
171
172 ;; gnus-compat.el ends here