mirror of https://codeberg.org/cage/tinmop/
101 lines
3.8 KiB
Common Lisp
101 lines
3.8 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © cage
|
|
|
|
;; This program 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 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program 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 program.
|
|
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
|
|
|
(in-package :program-events-tests)
|
|
|
|
(defsuite program-events-suite (all-suite))
|
|
|
|
(defclass dummy-ask-user-string-events (program-events::ask-user-input-string-event) ())
|
|
|
|
(defmethod process-event ((object dummy-ask-user-string-events))
|
|
(simulate-user-input object))
|
|
|
|
(defun simulate-user-input (ask-event)
|
|
(let ((input-done-event (make-instance 'user-input-string-event
|
|
:payload (payload ask-event)
|
|
:lock
|
|
(program-events::lock ask-event)
|
|
:condition-variable
|
|
(program-events::condition-variable ask-event))))
|
|
(setf (dunbox (payload input-done-event)) "foo")
|
|
(push-event input-done-event)))
|
|
|
|
(defun dummy-ask-string-input (payload)
|
|
(let ((event (make-instance 'dummy-ask-user-string-events
|
|
:payload payload)))
|
|
(with-accessors ((lock program-events::lock)
|
|
(condition-variable program-events::condition-variable)) event
|
|
(push-event event)
|
|
(with-lock (lock)
|
|
(format t "wait!~%")
|
|
(condition-wait condition-variable lock)
|
|
(format t "input was ~a~%" (dunbox (payload event)))))))
|
|
|
|
(defun main-thread ()
|
|
(loop repeat 8 do
|
|
(sleep 1)
|
|
(if (event-available-p)
|
|
(progn
|
|
(format t "heap ~a~%" (pq::heap program-events::*events-queue*))
|
|
(process-event (pop-event)))
|
|
(format t "no event~%"))))
|
|
|
|
(defun simulated-string-input ()
|
|
(let ((payload (dbox "bar"))
|
|
(program-events::*events-queue* (make-instance 'events-queue))
|
|
(main-thread (make-thread #'main-thread)))
|
|
(sleep 3)
|
|
(make-thread (lambda ()
|
|
(dummy-ask-string-input payload)))
|
|
(join-thread main-thread)
|
|
payload))
|
|
|
|
(defclass dummy-window () ())
|
|
|
|
(defmethod (setf command-window:echo-character) (val (object dummy-window))
|
|
t)
|
|
|
|
(deftest test-ask-input (program-events-suite)
|
|
(setf specials:*command-window* (make-instance 'dummy-window))
|
|
(assert-true
|
|
(string= "foo" (dunbox (simulated-string-input)))))
|
|
|
|
(defun callback ()
|
|
"callback called!")
|
|
|
|
(defun callback-example ()
|
|
(flet ((callback () "callback called!"))
|
|
(client-events:start-events-loop)
|
|
(let ((res nil))
|
|
(make-thread (lambda ()
|
|
(sleep 3)
|
|
(format t "push!~%")
|
|
(setf res
|
|
(push-function-and-wait-results #'callback))
|
|
(format t "pop!~%")))
|
|
(map 'nil
|
|
(lambda (a)
|
|
(sleep 1)
|
|
(push-event-unblock (make-instance 'function-event
|
|
:payload (lambda () (format t "~a~%" a)))))
|
|
(loop for i from 0 to 10 collect i))
|
|
(client-events:stop-events-loop)
|
|
res)))
|
|
|
|
(deftest test-callback (program-events-suite)
|
|
(assert-equality #'string= "callback called!" (callback-example)))
|