mirror of
https://github.com/stumpwm/stumpwm.git
synced 2026-09-10 07:26:20 -04:00
136 lines
4.4 KiB
Common Lisp
136 lines
4.4 KiB
Common Lisp
;; Copyright (C) 2003-2008 Shawn Betts
|
|
;; Copyright (C) 2017 David Bjergaard
|
|
;;
|
|
;; This file is part of stumpwm.
|
|
;;
|
|
;; stumpwm is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; stumpwm is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this software; see the file COPYING. If not, see
|
|
;; <http://www.gnu.org/licenses/>.
|
|
|
|
;; Commentary:
|
|
;;
|
|
;; Provides the code for timers.
|
|
;;
|
|
;; Code:
|
|
(in-package :stumpwm)
|
|
(export '(cancel-timer
|
|
timer-p
|
|
idle-time
|
|
run-with-timer))
|
|
|
|
;;; Timers
|
|
|
|
(defvar *toplevel-io* nil
|
|
"Top-level I/O loop")
|
|
|
|
(defvar *timer-list* nil
|
|
"List of active timers.")
|
|
|
|
(defvar *timer-list-lock* (sb-thread:make-mutex)
|
|
"Lock that should be held whenever *TIMER-LIST* is modified.")
|
|
|
|
(defun idle-time (screen)
|
|
"Returns the time in seconds since idle according to the root window
|
|
of the `screen'."
|
|
(/ (xlib:screen-saver-get-idle
|
|
*display* (screen-root screen))
|
|
1000.0))
|
|
|
|
(defun run-with-timer (secs repeat function &rest args)
|
|
"Perform an action after a delay of SECS seconds.
|
|
Repeat the action every REPEAT seconds, if repeat is non-nil.
|
|
SECS and REPEAT may be reals.
|
|
The action is to call FUNCTION with arguments ARGS."
|
|
(check-type secs (real 0 *))
|
|
(check-type repeat (or null (real 0 *)))
|
|
(check-type function (or function symbol))
|
|
(let ((timer (make-timer
|
|
:repeat repeat
|
|
:function function
|
|
:args args)))
|
|
(schedule-timer timer secs)
|
|
(labels ((append-to-list ()
|
|
(sb-thread:with-mutex (*timer-list-lock*)
|
|
(setf *timer-list* (merge 'list *timer-list* (list timer)
|
|
#'< :key #'timer-time)))))
|
|
(call-in-main-thread #'append-to-list)
|
|
timer)))
|
|
|
|
(defun cancel-timer (timer)
|
|
"Remove TIMER from the list of active timers."
|
|
(check-type timer timer)
|
|
(sb-thread:with-mutex (*timer-list-lock*)
|
|
(setf *timer-list* (remove timer *timer-list*))))
|
|
|
|
(defun schedule-timer (timer when)
|
|
(setf (timer-time timer) (+ (get-internal-real-time)
|
|
(* when internal-time-units-per-second))))
|
|
|
|
(defun sort-timers (timers)
|
|
(let ((now (get-internal-real-time))
|
|
(pending ())
|
|
(remaining ()))
|
|
(dolist (timer timers)
|
|
(if (<= (timer-time timer) now)
|
|
(progn (push timer pending)
|
|
(when (timer-repeat timer)
|
|
(schedule-timer timer (timer-repeat timer))
|
|
(push timer remaining)))
|
|
(push timer remaining)))
|
|
(values pending remaining)))
|
|
|
|
|
|
(defun execute-timers (timers)
|
|
(map nil #'execute-timer timers))
|
|
|
|
(defun execute-timer (timer)
|
|
(apply (timer-function timer) (timer-args timer)))
|
|
|
|
(defun run-expired-timers ()
|
|
(let ((expired (sb-thread:with-mutex (*timer-list-lock*)
|
|
(multiple-value-bind (pending remaining)
|
|
(sort-timers *timer-list*)
|
|
(update-timer-list remaining)
|
|
pending))))
|
|
;; Call the timers after the lock has been released
|
|
(execute-timers expired)))
|
|
|
|
(defun update-timer-list (timers)
|
|
"Update the timer list, sorting the timers by which is closer expiry."
|
|
(setf *timer-list*
|
|
(sort timers #'< :key #'timer-time)))
|
|
(defun get-next-timeout (timers)
|
|
"Return the number of seconds until the next timeout or nil if there are no timers."
|
|
(when timers
|
|
(max (/ (- (timer-time (car timers)) (get-internal-real-time))
|
|
internal-time-units-per-second)
|
|
0)))
|
|
|
|
(defclass stumpwm-timer-channel () ())
|
|
|
|
(defmethod io-channel-ioport (io-loop (channel stumpwm-timer-channel))
|
|
(declare (ignore io-loop))
|
|
nil)
|
|
|
|
(defmethod io-channel-events ((channel stumpwm-timer-channel))
|
|
(sb-thread:with-mutex (*timer-list-lock*)
|
|
(if *timer-list*
|
|
`((:timeout ,(timer-time (car *timer-list*))))
|
|
'(:loop))))
|
|
|
|
(defmethod io-channel-handle ((channel stumpwm-timer-channel) (event (eql :timeout)) &key)
|
|
(run-expired-timers))
|
|
|
|
(defmethod io-channel-handle ((channel stumpwm-timer-channel) (event (eql :loop)) &key)
|
|
(run-expired-timers))
|