[graphic-forms-cvs] r404 - in trunk: . docs/manual src src/demos/textedit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Nov 27 07:18:18 UTC 2006
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 , at 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+)
+ , at 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))))))
More information about the Graphic-forms-cvs
mailing list