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 (provide 'gnus-compat)
 108
 109 ;; gnus-compat.el ends here