cgit.sxemacs.org Git - gnus/blob - lisp/gnus-compat.el

   1 ;;; gnus-compat.el --- Compatability functions for Gnus
   2
   3 ;; Copyright (C) 2012 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 (provide 'gnus-compat)
 133
 134 ;; gnus-compat.el ends here