Author: junrue Date: Mon Nov 27 02:18:14 2006 New Revision: 404 Modified: trunk/NEWS.txt trunk/docs/manual/gfw-symbols.xml trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented with-cursor/with-wait-cursor macros; implemented process-events function; textedit demo now uses wait cursor when loading or saving files Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 27 02:18:14 2006 @@ -1,8 +1,14 @@ +. Implemented cursor support. Applications can choose from the system-defined + cursors or load them from external files. Also provided are convenience + macros GFW:WITH-CURSOR and GFW:WITH-WAIT-CURSOR. + +. Implemented a new layout manager called GFW:BORDER-LAYOUT which allows + applications to assign children to 5 possible regions, identified by + :top, :left, :right, :bottom, or :center. -. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns - children to 5 possible regions identified by :top, :left, :right, - :bottom, or :center. +. Implemented the function GFW:PROCESS-EVENTS to help applications flush + the event queue of pending events. . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 27 02:18:14 2006 @@ -2195,6 +2195,22 @@ <!-- FUNCTIONS --> + <function name="process-events"> + <syntax> + <return> + <emphasis>undefined</emphasis> + </return> + </syntax> + <description> + Call this function to processing pending events until the event queue + is empty. + </description> + <seealso> + <reftopic>gfw:default-message-filter</reftopic> + <reftopic>gfw:message-loop</reftopic> + </seealso> + </function> + <function name="obtain-pointer-location"> <syntax> <return> @@ -2462,6 +2478,9 @@ it is passed to <reftopic>gfw:message-loop</reftopic>. </para> </description> + <seealso> + <reftopic>gfw:process-events</reftopic> + </seealso> </function> <function name="message-loop"> @@ -2487,6 +2506,7 @@ </description> <seealso> <reftopic>gfw:default-message-filter</reftopic> + <reftopic>gfw:process-events</reftopic> </seealso> </function> Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Nov 27 02:18:14 2006 @@ -62,13 +62,15 @@ paths :filters *textedit-file-filters*) (when paths - (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths))) + (gfw:with-wait-cursor (*textedit-win*) + (setf (gfw:text *textedit-control*) (load-textedit-doc (first paths)))) (setf (file-path-of *textedit-model*) (namestring (first paths))) (setf (gfw:text *textedit-win*) (format nil "~a - TextEdit" (first paths)))))) (defun textedit-file-save (disp item) (if (file-path-of *textedit-model*) - (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*)) + (gfw:with-wait-cursor (*textedit-win*) + (save-textedit-doc (file-path-of *textedit-model*) (gfw:text *textedit-control*))) (textedit-file-save-as disp item)) (if (file-path-of *textedit-model*) (setf (gfw:text-modified-p *textedit-control*) nil))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 27 02:18:14 2006 @@ -561,11 +561,13 @@ #:visible-item-count #:visible-p #:with-color-dialog + #:with-cursor #:with-drawing-disabled #:with-file-dialog #:with-font-dialog #:with-graphics-context #:with-root-window + #:with-wait-cursor ;; conditions )) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Nov 27 02:18:14 2006 @@ -68,13 +68,23 @@ ;;; (defun message-loop (msg-filter) + (push msg-filter (message-filters (thread-context))) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) (cffi:with-foreign-slots ((gfs::message gfs::wparam) msg-ptr gfs::msg) (when (funcall msg-filter gm msg-ptr) + (pop (message-filters (thread-context))) (return-from message-loop gfs::wparam))))))) +(defun process-events () + (let ((filter (first (message-filters (thread-context))))) + (unless filter + (return-from process-events nil)) + (cffi:with-foreign-object (msg-ptr 'gfs::msg) + (loop until (zerop (gfs::peek-message msg-ptr (cffi:null-pointer) 0 0 gfs::+pm-remove+)) + do (funcall filter 1 msg-ptr))))) + (defun key-down-p (key-code) "Return T if the key corresponding to key-code is currently down." (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000)) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Nov 27 02:18:14 2006 @@ -42,6 +42,7 @@ (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) (items-by-id :initform (make-hash-table :test #'equal)) + (message-filters :initform nil :accessor message-filters) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) (move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt) (next-item-id :initform 10000 :reader next-item-id) @@ -70,7 +71,7 @@ (setf *the-thread-context* (make-instance 'thread-context)) (handler-case (init-utility-hwnd *the-thread-context*) - (win32-error (e) + (gfs:win32-error (e) (setf *the-thread-context* nil) (format *error-output* "~a~%" e)))) *the-thread-context*) @@ -90,7 +91,7 @@ (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) (handler-case (init-utility-hwnd tc) - (win32-error (e) + (gfs:win32-error (e) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil) (format *error-output* "~a~%" e)))) tc)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon Nov 27 02:18:14 2006 @@ -104,7 +104,6 @@ (funcall start-fn) (message-loop #'default-message-filter)))) -(declaim (inline shutdown)) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Nov 27 02:18:14 2006 @@ -83,6 +83,27 @@ (cffi:pointer-eq capture-hwnd (gfs:handle widget))) (gfs::set-cursor (gfs:handle cursor))))) +(defmacro with-cursor ((widget &key file hotspot image system) &body body) + (lispworks:with-unique-names (old new retval) + `(let ((,old (slot-value ,widget 'cursor)) + (,new (make-instance 'gfg:cursor + :file ,file + :hotspot ,hotspot + :image ,image + :system ,system)) + (,retval nil)) + (setf (slot-value ,widget 'cursor) nil) + (setf (cursor-of ,widget) ,new) + (process-events) + (unwind-protect + (setf ,retval (progn ,@body)) + (setf (slot-value ,widget 'cursor) ,old) + (gfs:dispose ,new)) + ,retval))) + +(defmacro with-wait-cursor ((widget) &body body) + `(with-cursor (,widget :system gfg:+wait-cursor+) + ,@body)) ;;; ;;; widget methods ;;; Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Nov 27 02:18:14 2006 @@ -116,7 +116,8 @@ (gfs::zero-mem wc-ptr gfs::wndclassex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex)) (when (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer)) str-ptr wc-ptr)) - (warn 'gfs:win32-warning :detail (format nil "class ~a not registered")) + (warn 'gfs:win32-warning + :detail (format nil "class ~a not registered" (get-window-class-name hwnd))) (return-from get-window-class-cursor nil)) (if (not (gfs::null-handle-p gfs::hcursor)) (make-instance 'gfg:cursor :handle gfs::hcursor :shared t))))))