Author: junrue Date: Tue Mar 21 00:06:45 2006 New Revision: 60

Added: trunk/src/uitoolkit/widgets/timer.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented timer object and event handling -- crashes on CLISP need investigation

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Mar 21 00:06:45 2006 @@ -89,6 +89,7 @@ (:file "widget-generics") (:file "event-source") (:file "widget-utils") + (:file "timer") (:file "item") (:file "widget") (:file "control")

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Mar 21 00:06:45 2006 @@ -206,6 +206,7 @@ #:menu #:menu-item #:panel + #:timer #:top-level #:widget #:widget-with-items @@ -314,6 +315,7 @@ #:cut #:default-item #:defmenu + #:delay-of #:disabled-image #:dispatcher #:display-to-object @@ -353,6 +355,7 @@ #:event-resize #:event-select #:event-show + #:event-timer #:expand #:expanded-p #:focus-index @@ -364,6 +367,8 @@ #:header-visible-p #:iconify #:iconified-p + #:id-of + #:initial-delay-of #:horizontal-scrollbar #:image #:item-at @@ -412,6 +417,7 @@ #:retrieve-span #:right-margin-of #:run-default-message-loop + #:running-p #:scroll #:select #:select-all @@ -429,8 +435,10 @@ #:shutdown #:size #:spacing-of + #:start #:startup #:step-increment + #:stop #:style-of #:sub-menu #:text

Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Mar 21 00:06:45 2006 @@ -37,6 +37,7 @@ (defparameter *event-tester-text* "Hello!") (defvar *event-counter* 0) (defvar *mouse-down-flag* nil) +(defvar *timer* nil)

(defun exit-event-tester () (let ((w *event-tester-window*)) @@ -119,6 +120,14 @@ (gfs:point-y pnt) time (text-for-modifiers))) + +(defun text-for-timer (time) + (format nil + "~a timer tick id: ~d time: 0x~x ~s" + (incf *event-counter*) + (gfw:id-of *timer*) + time + (text-for-modifiers)))

(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char) (setf *event-tester-text* (text-for-key "down" time key-code char)) @@ -184,6 +193,33 @@ (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated")) (gfw:redraw *event-tester-window*))

+(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time) + (declare (ignore disp timer)) + (setf *event-tester-text* (text-for-timer time)) + (gfw:redraw *event-tester-window*)) + +(defun manage-file-menu (disp menu time) + (declare (ignore disp time)) + (let ((item (gfw:item-at menu 0))) + (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer")))) + +(defun manage-timer (disp item time rect) + (declare (ignore disp item time rect)) + (if *timer* + (progn + (gfw:stop *timer*) + (setf *timer* nil) + (setf *event-tester-text* "timer stopped by user")) + (progn + (setf *timer* (make-instance 'gfw:timer :delay 1000 :dispatcher (make-instance 'event-tester-echo-dispatcher))) + (gfw:start *timer*) + (setf *event-tester-text* (format nil + "timer ~d started init delay: ~d delay ~d" + (gfw:id-of *timer*) + (gfw:initial-delay-of *timer*) + (gfw:delay-of *timer*))))) + (gfw:redraw *event-tester-window*)) + (defun run-event-tester-internal () (setf *event-tester-text* "Hello!") (setf *event-counter* 0) @@ -192,16 +228,15 @@ (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) :style '(:style-workspace))) - (setf menubar (gfw:defmenu ((:item "&File" :dispatcher echo-md - :submenu ((:item "&Open..." :dispatcher echo-md) - (:item "&Save..." :disabled :dispatcher echo-md) + (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu + :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) (:item "E&xit" :dispatcher exit-md))) - (:item "&Options" :dispatcher echo-md - :submenu ((:item "&Enabled" :checked :dispatcher echo-md) - (:item "&Tools" :dispatcher echo-md - :submenu ((:item "&Fonts" :dispatcher echo-md :disabled) - (:item "&Colors" :dispatcher echo-md))))) + (:item "&Test Menu" :dispatcher echo-md + :submenu ((:item "&Checked Item" :checked :dispatcher echo-md) + (:item "&Submenu" :dispatcher echo-md + :submenu ((:item "&Item A" :dispatcher echo-md :disabled) + (:item "&Item B" :dispatcher echo-md))))) (:item "&Help" :dispatcher echo-md :submenu ((:item "&About" :dispatcher echo-md)))))) (setf (gfw:menu-bar *event-tester-window*) menubar)

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Mar 21 00:06:45 2006 @@ -562,6 +562,9 @@ (defconstant +tpm-noanimation+ #x4000) (defconstant +tpm-layoutrtl+ #x8000)

+(defconstant +user-timer-maximum+ #x7FFFFFFF) +(defconstant +user-timer-minimum+ #x0000000A) + (defconstant +wm-create+ #x0001) (defconstant +wm-destroy+ #x0002) (defconstant +wm-move+ #x0003) @@ -595,6 +598,10 @@ (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message (defconstant +wm-command+ #x0111) +(defconstant +wm-syscommand+ #x0112) +(defconstant +wm-timer+ #x0113) +(defconstant +wm-hscroll+ #x0114) +(defconstant +wm-vscroll+ #x0115) (defconstant +wm-initmenu+ #x0116) (defconstant +wm-initmenupopup+ #x0117) (defconstant +wm-menuselect+ #x011F)

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Mar 21 00:06:45 2006 @@ -166,10 +166,11 @@

#+lispworks (fli:define-foreign-function - (enum-child-windows "EnumChildWindows" :result-type :int) + (enum-child-windows "EnumChildWindows") ((hwnd :pointer) (func :pointer) - (lparam :long))) + (lparam :long)) + :result-type :int)

#+clisp (ffi:def-call-out enum-child-windows @@ -326,6 +327,12 @@ (hwnd HANDLE))

(defcfun + ("KillTimer" kill-timer) + BOOL + (hwnd HANDLE) + (id UINT)) + +(defcfun ("LoadImageA" load-image) HANDLE (instance HANDLE) @@ -415,6 +422,47 @@ (by-pos BOOL) (item-info LPTR))

+;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("SetTimer" set-timer) + UINT + (hwnd HANDLE) + (id UINT) + (elapse UINT) + (callback :pointer)) ;; TIMERPROC +|# + +#+lispworks +(fli:define-foreign-function + (set-timer "SetTimer") + ((hwnd :pointer) + (id :unsigned-int) + (elapse :unsigned-int) + (func :pointer)) + :result-type :unsigned-int) + +#+clisp +(ffi:def-call-out set-timer + (:name "SetTimer") + (:library "user32.dll") + (:language :stdc) + (:arguments (hwnd ffi:c-pointer) + (id ffi:uint) + (elapse ffi:uint) + (func (ffi:c-function + (:arguments + (hwnd ffi:c-pointer) + (msg ffi:uint) + (id ffi:uint) + (time ffi:long)) + (:return-type nil) + (:language :stdc-stdcall)))) + (:return-type ffi:uint)) + ;;; SetWindowLong is deprecated in favor of SetWindowLongPtr ;;; which can be used to write code compatible to both Win32 ;;; and Win64. But on Win32, SetWindowLongPtr is actually

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Tue Mar 21 00:06:45 2006 @@ -187,3 +187,8 @@ (:documentation "Implement this to respond to an object being shown.") (:method (dispatcher widget time) (declare (ignorable dispatcher widget time)))) + +(defgeneric event-timer (dispatcher timer time) + (:documentation "Implement this to respond to a tick from a specific timer.") + (:method (dispatcher timer time) + (declare (ignorable dispatcher timer time))))

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Mar 21 00:06:45 2006 @@ -42,6 +42,10 @@ ;;; window procedures ;;;

+;;; NOTE: these defcallback's work even without stdcall support in +;;; CFFI because Windows looks for wndprocs that are not stdcall +;;; and takes care of stack fixup + (cffi:defcallback uit_widgets_wndproc gfs::UINT ((hwnd gfs::HANDLE) @@ -128,7 +132,7 @@ (gfs::def-window-proc hwnd msg wparam lparam))

(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if w @@ -166,7 +170,7 @@ 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) - (declare (ignorable hwnd lparam)) + (declare (ignore hwnd lparam)) (let* ((tc (thread-context)) (menu (get-widget tc (cffi:make-pointer wparam)))) (unless (null menu) @@ -176,7 +180,7 @@ 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam) - (declare (ignorable hwnd lparam)) ; FIXME: handle system menus + (declare (ignore hwnd lparam)) ; FIXME: handle system menus (let* ((tc (thread-context)) (item (get-menuitem tc (lo-word wparam)))) (unless (null item) @@ -186,12 +190,12 @@ 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (remove-widget (thread-context) hwnd) 0)

@@ -262,7 +266,7 @@ (process-mouse-message #'event-mouse-move hwnd lparam btn-sym)))

(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (when w @@ -271,7 +275,7 @@ 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if (and w (event-pre-move (dispatcher w) w (event-time tc))) @@ -279,7 +283,7 @@ 0)))

(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (gc (make-instance 'gfg:graphics-context))) @@ -329,13 +333,25 @@ 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd))) (if (and w (event-pre-resize (dispatcher w) w (event-time tc))) 1 0)))

+(defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) + (declare (ignore hwnd lparam)) + (let* ((tc (thread-context)) + (timer (get-timer tc wparam))) + (if (null timer) + (gfs::kill-timer (cffi:null-pointer) wparam) + (progn + (event-timer (dispatcher timer) timer (event-time tc)) + (when (<= (delay-of timer) 0) + (stop timer))))) + 0) + ;;; ;;; process-subclass-message methods ;;; @@ -347,7 +363,7 @@ (gfs::def-window-proc hwnd msg wparam lparam))))

(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) - (declare (ignorable wparam lparam)) + (declare (ignore wparam lparam)) (remove-widget (thread-context) hwnd) (call-next-method))

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Tue Mar 21 00:06:45 2006 @@ -46,6 +46,7 @@ (next-menuitem-id :initform 10000 :reader next-menuitem-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (timers-by-id :initform (make-hash-table :test #'equal)) (wip :initform nil)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))

@@ -139,3 +140,20 @@ (let ((id (next-menuitem-id tc))) (incf (slot-value tc 'next-menuitem-id)) id)) + +(defmethod get-timer ((tc thread-context) id) + "Returns the timer identified by the specified (system-defined) id." + (gethash id (slot-value tc 'timers-by-id))) + +(defmethod put-timer ((tc thread-context) (timer timer)) + "Stores a timer using its id as the key." + (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer)) + +(defmethod remove-timer ((tc thread-context) (timer timer)) + "Removes the timer using its id as the key." + (maphash + #'(lambda (k v) + (declare (ignore v)) + (if (eql k (id-of timer)) + (remhash k (slot-value tc 'timers-by-id)))) + (slot-value tc 'timers-by-id)))

Added: trunk/src/uitoolkit/widgets/timer.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/timer.lisp Tue Mar 21 00:06:45 2006 @@ -0,0 +1,122 @@ +;;;; +;;;; timer.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +#+lispworks +(fli:define-foreign-callable + ("timer_proc" :result-type :void :calling-convention :stdcall) + ((hwnd :pointer) + (msg :unsigned-int) + (id :unsigned-int) + (time :long)) + (process-message hwnd gfs::+wm-timer+ id time)) + +#+lispworks +(defun gf-set-timer (delay) + (gfs::set-timer (cffi:null-pointer) + 0 delay + (fli:make-pointer :symbol-name "timer_proc"))) + +#+clisp +(defun timer_proc (hwnd msg id time) + (declare (ignore msg)) + (process-message hwnd gfs::+wm-timer+ id time) + nil) + +#+clisp +(defun gf-set-timer (delay) + (gfs::set-timer nil 0 delay #'timer_proc)) + +(defun clamp-delay-values (init-delay delay) + "Adjust delay settings based on system-defined limits." + ;; + ;; SetTimer is going to impose them anyway, so might as + ;; well make the slot values agree with reality. + ;; On original WinXP (pre-SP1) and earlier, delay values less + ;; than USER_TIMER_MINIMUM get set to 1ms, which MS rectified + ;; in later releases. + ;; + (when (and (> init-delay 0) (< init-delay gfs::+user-timer-minimum+)) + (setf init-delay gfs::+user-timer-minimum+)) + (when (> init-delay gfs::+user-timer-maximum+) + (setf init-delay gfs::+user-timer-maximum+)) + (when (and (> delay 0) (< delay gfs::+user-timer-minimum+)) + (setf delay gfs::+user-timer-minimum+)) + (when (> delay gfs::+user-timer-maximum+) + (setf delay gfs::+user-timer-maximum+)) + (values init-delay delay)) + +(defmethod (setf delay-of) :around (value (self timer)) + (multiple-value-bind (init-delay delay) + (clamp-delay-values 0 value) + (declare (ignore init-delay)) + (if (/= delay (slot-value self 'delay)) + (setf (slot-value self 'delay) delay) + (let ((tc (thread-context)) + (new-id (gf-set-timer delay))) + (unless (or (not (running-p self)) (= new-id (id-of self))) + (remove-timer tc self) + (put-timer tc self)) + (setf (slot-value self 'id-of) new-id))))) + +(defmethod initialize-instance :after ((self timer) &key) + (if (null (delay-of self)) + (error 'gfs:toolkit-error :detail ":delay value required")) + (if (null (initial-delay-of self)) + (setf (slot-value self 'initial-delay) (delay-of self))) + (multiple-value-bind (init-delay delay) + (clamp-delay-values (initial-delay-of self) (delay-of self)) + (setf (slot-value self 'initial-delay) init-delay) + (setf (slot-value self 'delay) delay))) + +(defmethod start ((self timer)) + ;; use init-delay as the elapse interval for the very first + ;; tick; the interval will be adjusted (or the timer killed) + ;; as part of processing the first event + ;; + (let ((init-delay (initial-delay-of self)) + (delay (delay-of self))) + (if (> init-delay 0) + (setf delay init-delay)) + (let ((id (gf-set-timer delay))) + (if (zerop id) + (error 'gfs:win32-error :detail "set-timer failed")) + (setf (slot-value self 'id) id) + (put-timer (thread-context) self)))) + +(defmethod stop ((self timer)) + (remove-timer (thread-context) self)) ;; kill-timer will be called on the next tick + +(defmethod running-p ((self timer)) + (get-timer (thread-context) (id-of self)))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Mar 21 00:06:45 2006 @@ -93,3 +93,17 @@

(defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) + +(defclass timer (event-source) + ((id + :reader id-of + :initform 0) + (initial-delay + :reader initial-delay-of + :initarg :initial-delay + :initform 1000) + (delay + :accessor delay-of + :initarg :delay + :initform 1000)) + (:documentation "A timer is a non-windowed object that generates events at a regular (adjustable) frequency."))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Mar 21 00:06:45 2006 @@ -282,6 +282,9 @@ (defgeneric retrieve-span (object) (:documentation "Returns the span object indicating the range of values that are valid for the object."))

+(defgeneric running-p (object) + (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) + (defgeneric scroll (object dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))

@@ -327,9 +330,15 @@ (defgeneric size (object) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system."))

+(defgeneric start (object) + (:documentation "Enable event generation at regular intervals.")) + (defgeneric step-increment (object) (:documentation "Return an integer representing the configured step size for the object."))

+(defgeneric stop (object) + (:documentation "Stop producing events.")) + (defgeneric text (object) (:documentation "Returns the object's text."))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Mar 21 00:06:45 2006 @@ -98,7 +98,7 @@

(defmethod gfs:dispose ((w widget)) (unless (null (dispatcher w)) - (event-dispose (dispatcher w) w 0)) + (event-dispose (dispatcher w) w (event-time (thread-context)))) (let ((hwnd (gfs:handle w))) (if (not (gfs:null-handle-p hwnd)) (if (zerop (gfs::destroy-window hwnd))