Fix last commit.

[elisp/apel.git] / poe-xemacs.el

diff --git a/poe-xemacs.el b/poe-xemacs.el
index 0ab7128..e22a299 100644 (file)
--- a/poe-xemacs.el
+++ b/poe-xemacs.el
@@ -78,6 +78,86 @@ When called interactively, prompt for the name of the color to use."
   (switch-to-buffer-other-frame (dired-noselect dirname switches)))
 
 
+;;; @ timer
+;;;
+
+(condition-case nil
+    (require 'timer)
+  (error
+   (require 'itimer)
+   (defun-maybe run-at-time (time repeat function &rest args)
+     (start-itimer (make-temp-name "rat")
+                  `(lambda ()
+                     (,function ,@args))
+                  time repeat))
+   (defalias 'cancel-timer 'delete-itimer)
+   (defun with-timeout-handler (tag)
+     (throw tag 'timeout))
+   (defmacro-maybe with-timeout (list &rest body)
+     (let ((seconds (car list))
+          (timeout-forms (cdr list)))
+       `(let ((with-timeout-tag (cons nil nil))
+             with-timeout-value with-timeout-timer)
+         (if (catch with-timeout-tag
+               (progn
+                 (setq with-timeout-timer
+                       (run-at-time ,seconds nil
+                                    'with-timeout-handler
+                                    with-timeout-tag))
+                 (setq with-timeout-value (progn . ,body))
+                 nil))
+             (progn . ,timeout-forms)
+           (cancel-timer with-timeout-timer)
+           with-timeout-value))))))
+
+(require 'broken)
+
+(broken-facility run-at-time-tick-tock
+  "`run-at-time' is not punctual."
+  ;; It should be fixed when someone improves itimer in the future.
+  ;; Note that it doesn't support XEmacsen of versions prior to 19.15
+  ;; since `start-itimer' doesn't pass arguments to a timer function.
+  (and (= emacs-major-version 19) (<= emacs-minor-version 14)))
+
+(when-broken run-at-time-tick-tock
+  (defadvice run-at-time (around make-it-punctual
+                                (time repeat function &rest args)
+                                activate)
+    "This function was redefined to be made punctual by APEL.
+Note that it allows neither a string nor a time in the Emacs style
+\(a list of integers) as the first argument TIME."
+    (let ((itimers (list nil)))
+      (setcar
+       itimers
+       (apply #'start-itimer "run-at-time"
+             (lambda (itimers repeat function &rest args)
+               (let ((itimer (car itimers)))
+                 (if repeat
+                     (progn
+                       (set-itimer-function
+                        itimer
+                        (lambda (itimer repeat function &rest args)
+                          (set-itimer-restart itimer repeat)
+                          (set-itimer-function itimer function)
+                          (set-itimer-function-arguments itimer args)
+                          (apply function args)))
+                       (set-itimer-function-arguments
+                        itimer
+                        (append (list itimer repeat function) args)))
+                   (set-itimer-function
+                    itimer
+                    (lambda (itimer function &rest args)
+                      (set-itimer-restart itimer nil)
+                      (delete-itimer itimer)
+                      (apply function args)))
+                   (set-itimer-function-arguments
+                    itimer
+                    (append (list itimer function) args)))))
+             1e-9 (if time (max time 1e-9) 1e-9)
+             nil t itimers repeat function args))
+      (setq ad-return-value (car itimers)))))
+
+
 ;;; @ to avoid bug of XEmacs 19.14
 ;;;
 
@@ -105,6 +185,17 @@ When called interactively, prompt for the name of the color to use."
 (defalias-maybe 'line-beginning-position 'point-at-bol)
 (defalias-maybe 'line-end-position 'point-at-eol)
 
+;;; @ XEmacs 21 emulation
+;;;
+
+;; XEmacs 20.5 and later: (set-extent-properties EXTENT PLIST)
+(defun-maybe set-extent-properties (extent plist)
+  "Change some properties of EXTENT.
+PLIST is a property list.
+For a list of built-in properties, see `set-extent-property'."
+  (while plist
+    (set-extent-property extent (car plist) (cadr plist))
+    (setq plist (cddr plist))))  
 
 ;;; @ end
 ;;;