- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r425 - in trunk/src: demos/textedit uitoolkit/system uitoolkit/widgets
by junrue＠common-lisp.net 07 Jan '07

07 Jan '07

Author: junrue Date: Sun Jan 7 02:16:30 2007 New Revision: 425 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: text now displays in simple status bars; related refactoring Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jan 7 02:16:30 2007 @@ -200,6 +200,7 @@ (gfw:text *textedit-win*) *textedit-new-title*) (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) + (gfw::stb-set-text (gfw:status-bar-of *textedit-win*) "Testing...1, 2, 3") (gfw:show *textedit-win* t))) (defun textedit () Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jan 7 02:16:30 2007 @@ -951,6 +951,11 @@ ;;; statusbar constants ;;; +(defconstant +sb-simpleid+ #x00FF) + +(defconstant +sb-settext+ #x0401) ; (WM_USER+1) SB_SETTEXTA +(defconstant +sb-gettext+ #x0402) ; (WM_USER+2) SB_GETTEXTA +(defconstant +sb-gettextlength+ #x0403) ; (WM_USER+3) SB_GETTEXTLENGTHA (defconstant +sb-setparts+ #x0404) ; (WM_USER+4) (defconstant +sb-getparts+ #x0406) ; (WM_USER+6) (defconstant +sb-getborders+ #x0407) ; (WM_USER+7) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jan 7 02:16:30 2007 @@ -65,7 +65,8 @@ ;; it won't work if virtual containers like group are implemented. ;; (when (and parent (layout-of parent)) - (append-layout-item (layout-of parent) ctrl))))) + (append-layout-item (layout-of parent) ctrl)) + hwnd))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Jan 7 02:16:30 2007 @@ -34,12 +34,92 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(declaim (inline stb-is-simple)) +(defun stb-is-simple (status-bar) + (/= (gfs::send-message (gfs:handle status-bar) gfs::+sb-issimple+ 0 0) 0)) + +(defun stb-get-border-widths (status-bar) + "Returns a list of integer widths (0: horz border, 1: vert border, 2: internal)" + (cffi:with-foreign-pointer (array (* (cffi:foreign-type-size :int) 3)) + (when (zerop (gfs::send-message (gfs:handle status-bar) + gfs::+sb-getborders+ + 0 + (cffi:pointer-address array))) + (warn 'gfs:win32-warning :detail "SB_GETBORDERS message failed") + (return-from stb-get-border-widths (list 0 0 0))) + (loop for index from 0 to 2 + collect (cffi:mem-aref array :int index)))) + +(defun stb-set-min-height (status-bar height) + (let ((widths (stb-get-border-widths status-bar)) + (hstatus (gfs:handle status-bar))) + (when (zerop (gfs::send-message hstatus + gfs::+sb-setminheight+ + (+ height (* (second widths) 2)) + 0)) + (warn 'gfs:win32-warning :detail "SB_SETMINHEIGHT message failed") + (return-from stb-set-min-height nil)) + (gfs::send-message hstatus gfs::+wm-size+ 0 0)) + height) + +(defun stb-set-text (status-bar str &optional item-index) + (let ((part-id (if (stb-is-simple status-bar) gfs::+sb-simpleid+ item-index))) + (cffi:with-foreign-string (str-ptr str) + (if (zerop (gfs::send-message (gfs:handle status-bar) + gfs::+sb-settext+ + part-id + (cffi:pointer-address str-ptr))) + (warn 'gfs:win32-warning :detail "SB_SETTEXT message failed")))) + str) + +(defun stb-get-text-properties (status-bar item-index) + "Returns the text length and operation type of the status bar part at item-index." + (let ((hresult (gfs::send-message (gfs:handle status-bar) + gfs::+sb-gettextlength+ + item-index + 0))) + (values (gfs::lparam-low-word hresult) (gfs::lparam-high-word hresult)))) + +(defun stb-get-text (status-bar item-index) + (multiple-value-bind (length op-type) + (stb-get-text-properties status-bar item-index) + (declare (ignore op-type)) + (if (zerop length) + "" + (cffi:with-foreign-pointer-as-string (str-ptr (1+ length)) + (gfs::send-message (gfs:handle status-bar) + gfs::+sb-gettext+ + item-index + (cffi:pointer-address str-ptr)))))) + +;;; ;;; methods ;;; +(defmethod border-width ((self status-bar)) + (let ((widths (stb-get-border-widths self))) + (max (first widths) (second widths)))) + (defmethod compute-style-flags ((self status-bar) &rest extra-data) (declare (ignore extra-data)) (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (create-control self parent "" gfs::+icc-win95-classes+)) + (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (gfs::send-message hctl gfs::+sb-simple+ 1 0)) + (let ((widths (stb-get-border-widths self))) + (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) + +(defmethod preferred-size ((self status-bar) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((client-area (client-size (parent self))) + (tmp-size (compute-size (layout-of self) self width-hint height-hint)) + (widths (stb-get-border-widths self))) + (gfs:make-size :width (gfs:size-width client-area)) + :height (+ (gfs:size-height tmp-size) (* (first widths) 2)))) + Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jan 7 02:16:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-utils.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -162,20 +162,16 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) -(defun get-widget-text (w) - (if (gfs:disposed-p w) +(defun get-widget-text (widget) + (if (gfs:disposed-p widget) (error 'gfs:disposed-error)) (let* ((text "") - (hwnd (gfs:handle w)) - (len (gfs::get-window-text-length hwnd))) - (unless (zerop len) - (incf len) - (let ((str-ptr (cffi:foreign-alloc :char :count len))) - (unwind-protect - (unless (zerop (gfs::get-window-text hwnd str-ptr len)) - (setf text (cffi:foreign-string-to-lisp str-ptr))) - (cffi:foreign-free str-ptr)))) - text)) + (hwnd (gfs:handle widget)) + (length (gfs::get-window-text-length hwnd))) + (if (zerop length) + "" + (cffi:with-foreign-pointer-as-string (str-ptr (1+ length)) + (gfs::get-window-text hwnd str-ptr (1+ length)))))) (defun outer-location (w pnt) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)

1 0

[graphic-forms-cvs] r424 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 04 Jan '07

04 Jan '07

Author: junrue Date: Thu Jan 4 01:03:07 2007 New Revision: 424 Modified: trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: replace thread-context GFs with simple functions; add a thread-context slot for storing raw event data; move status-bar resizing logic from WM_SIZE process-message to top-level and dialog event-resize methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Jan 4 01:03:07 2007 @@ -171,6 +171,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method)) +(defmethod event-resize (disp (self dialog) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jan 4 01:03:07 2007 @@ -502,13 +502,10 @@ ((= wparam gfs::+size-minimized+) :minimized) ((= wparam gfs::+size-restored+) :restored) (t nil)))) - (when (and w (not (typep w 'status-bar))) + (record-raw-event tc hwnd msg wparam lparam) + (when w (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) w (size-event-size tc) type) - (if (or (typep w 'top-level) (typep w 'dialog)) - (let ((sbar (status-bar-of w))) - (if sbar - (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ wparam lparam)))))) + (event-resize (dispatcher w) w (size-event-size tc) type))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Jan 4 01:03:07 2007 @@ -33,11 +33,14 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defstruct event (hwnd (cffi:null-pointer)) (msg 0) (wparam 0) (lparam 0)) + (defclass thread-context () ((child-visitor-func :initform nil :accessor child-visitor-func) (child-visitor-results :initform nil :accessor child-visitor-results) (display-visitor-func :initform nil :accessor display-visitor-func) (display-visitor-results :initform nil :accessor display-visitor-results) + (raw-event :initform (make-event) :reader raw-event) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) @@ -55,7 +58,7 @@ (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + (widget-in-progress :initform nil :accessor widget-in-progress)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) ;; TODO: change this when CLISP acquires MT support @@ -107,32 +110,7 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) -(defgeneric init-utility-hwnd (self)) -(defgeneric call-child-visitor-func (self parent child)) -(defgeneric call-display-visitor-func (self hmonitor data)) -(defgeneric call-top-level-visitor-func (self window)) -(defgeneric get-widget (self hwnd)) -(defgeneric put-widget (self widget)) -(defgeneric delete-widget (self hwnd)) -(defgeneric widget-in-progress (self)) -(defgeneric (setf widget-in-progress) (widget self)) -(defgeneric clear-widget-in-progress (self)) -(defgeneric put-kbdnav-widget (self widget)) -(defgeneric delete-kbdnav-widget (self widget)) -(defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-item (self id)) -(defgeneric put-item (self item)) -(defgeneric delete-tc-item (self item)) -(defgeneric increment-item-id (self)) -(defgeneric put-job (self id closure)) -(defgeneric take-job (self id)) -(defgeneric increment-job-id (self)) -(defgeneric get-timer (self id)) -(defgeneric put-timer (self timer)) -(defgeneric delete-timer (self timer)) -(defgeneric increment-widget-id (self)) - -(defmethod init-utility-hwnd ((tc thread-context)) +(defun init-utility-hwnd (tc) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here "" ; because of circular dependency @@ -144,65 +122,57 @@ 0))) (setf (slot-value tc 'utility-hwnd) hwnd))) -(defmethod call-child-visitor-func ((tc thread-context) parent child) +(defun call-child-visitor-func (tc parent child) (let ((func (child-visitor-func tc))) (if func (funcall func parent child) (warn 'gfs:toolkit-warning :detail "child visitor function is nil")))) -(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) +(defun call-display-visitor-func (tc hmonitor data) (let ((func (display-visitor-func tc))) (if func (funcall func hmonitor data) (warn 'gfs:toolkit-warning :detail "display visitor function is nil")))) -(defmethod call-top-level-visitor-func ((tc thread-context) win) +(defun call-top-level-visitor-func (tc win) (let ((func (top-level-visitor-func tc))) (if func (funcall func win) (warn 'gfs:toolkit-warning :detail "top-level visitor function is nil")))) -(defmethod get-widget ((tc thread-context) hwnd) +(defun get-widget (tc hwnd) "Return the widget object corresponding to the specified native window handle." - (let ((tmp-widget (slot-value tc 'wip))) + (let ((tmp-widget (widget-in-progress tc))) (when tmp-widget (setf (slot-value tmp-widget 'gfs:handle) hwnd) (return-from get-widget tmp-widget))) (unless (gfs:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) -(defmethod put-widget ((tc thread-context) (w widget)) +(defun put-widget (tc w) "Add the specified widget to the widget table using its native handle as the key." (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) -(defmethod delete-widget ((tc thread-context) hwnd) +(defun delete-widget (tc hwnd) "Remove the widget object corresponding to the specified native window handle." - (when (not (slot-value tc 'wip)) + (when (not (widget-in-progress tc)) (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) -(defmethod widget-in-progress ((tc thread-context)) - "Return the widget currently under construction." - (slot-value tc 'wip)) - -(defmethod (setf widget-in-progress) ((w widget) (tc thread-context)) +(defun clear-widget-in-progress (tc) "Store the widget currently under construction." - (setf (slot-value tc 'wip) w)) + (setf (widget-in-progress tc) nil)) -(defmethod clear-widget-in-progress ((tc thread-context)) - "Store the widget currently under construction." - (setf (slot-value tc 'wip) nil)) - -(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) +(defun put-kbdnav-widget (tc widget) (if (find :keyboard-navigation (style-of widget)) (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) -(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget)) +(defun delete-kbdnav-widget (tc widget) (setf (kbdnav-widgets tc) (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) (kbdnav-widgets tc) :key #'gfs:handle))) -(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) +(defun intercept-kbdnav-message (tc msg-ptr) (let ((widgets (kbdnav-widgets tc))) (unless widgets (return-from intercept-kbdnav-message nil)) @@ -217,15 +187,15 @@ (return-from intercept-kbdnav-message widget)))) nil) -(defmethod get-item ((tc thread-context) id) +(defun get-item (tc id) "Returns the item identified by id." (gethash id (slot-value tc 'items-by-id))) -(defmethod put-item ((tc thread-context) (it item)) +(defun put-item (tc it) "Stores an item using its id as the key." (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it)) -(defmethod delete-tc-item ((tc thread-context) (it item)) +(defun delete-tc-item (tc it) "Removes the item using its id as the key." (maphash #'(lambda (k v) @@ -234,37 +204,37 @@ (remhash k (slot-value tc 'items-by-id)))) (slot-value tc 'items-by-id))) -(defmethod increment-item-id ((tc thread-context)) +(defun increment-item-id (tc) "Return the next menu item ID; also increment the internal value." (let ((id (next-item-id tc))) (incf (slot-value tc 'next-item-id)) id)) -(defmethod put-job ((tc thread-context) id closure) +(defun put-job (tc id closure) "Stores a closure using the specified ID for later retrieval." ;; FIXME: thread-safety (setf (gethash id (slot-value tc 'job-table)) closure)) -(defmethod take-job ((tc thread-context) id) +(defun take-job (tc id) (let ((closure (gethash id (slot-value tc 'job-table)))) (remhash id (slot-value tc 'job-table)) closure)) -(defmethod increment-job-id ((tc thread-context)) +(defun increment-job-id (tc) "Return the next job ID; also increment the internal value." (let ((id (next-job-id tc))) (incf (slot-value tc 'next-job-id)) id)) -(defmethod get-timer ((tc thread-context) id) +(defun get-timer (tc 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)) +(defun put-timer (tc timer) "Stores a timer using its id as the key." (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer)) -(defmethod delete-timer ((tc thread-context) (timer timer)) +(defun delete-timer (tc timer) "Removes the timer using its id as the key." (maphash #'(lambda (k v) @@ -273,8 +243,16 @@ (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) -(defmethod increment-widget-id ((tc thread-context)) +(defun increment-widget-id (tc) "Return the next timer ID; also increment the internal value." (let ((id (next-widget-id tc))) (incf (slot-value tc 'next-widget-id)) id)) + +(defun record-raw-event (tc hwnd msg wparam lparam) + (let ((event (raw-event tc))) + (setf (event-hwnd event) hwnd + (event-msg event) msg + (event-wparam event) wparam + (event-lparam event) lparam) + event)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Jan 4 01:03:07 2007 @@ -137,6 +137,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method)) +(defmethod event-resize (disp (self top-level) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner)

1 0

[graphic-forms-cvs] r423 - in trunk: . docs/manual docs/website src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 04 Jan '07

04 Jan '07

Author: junrue Date: Wed Jan 3 22:04:43 2007 New Revision: 423 Added: trunk/src/uitoolkit/widgets/status-bar.lisp Modified: trunk/docs/manual/api.xml trunk/docs/manual/gfw-symbols.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/protocols.xml trunk/docs/website/index.html trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: check in a snapshot of status bar work Modified: trunk/docs/manual/api.xml ============================================================================== --- trunk/docs/manual/api.xml (original) +++ trunk/docs/manual/api.xml Wed Jan 3 22:04:43 2007 @@ -11,6 +11,7 @@ </para> &constants; + &protocols; &gfcpkg; &gfgpkg; &gfspkg; Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Jan 3 22:04:43 2007 @@ -2,7 +2,7 @@  <package name="gfw" fullname="graphic-forms.uitoolkit.widgets"> @@ -1284,8 +1284,8 @@ <argument name=":style"> <description> This is a <refclhs>list</refclhs> of keyword symbols that define - the look-and-feel of the dialog. Currently, only one of the following - symbols may be specified: + the look-and-feel of the dialog. One of the following + primary styles may be specified: <enum> <argument name=":application-modal"> <description> @@ -1309,6 +1309,10 @@ </description> </argument> </enum> + The following optional style may also be specified: + <enum> + <argument name=":status-bar"/> + </enum> </description> </argument> <argument name=":text"> @@ -1335,6 +1339,7 @@ <reftopic>gfw:owner</reftopic> <reftopic>gfw:parent</reftopic> <reftopic>gfw:text</reftopic> + <reftopic>gfw:status-bar-of</reftopic> </seealso> </class> @@ -1415,7 +1420,7 @@ One or more of the following optional styles: <enum> <argument name=":horizontal-scrollbar"/> - <argument name=":statusbar"/> + <argument name=":status-bar"/> <argument name=":vertical-scrollbar"/> </enum> </description> @@ -1449,7 +1454,7 @@ <reftopic>gfw:text</reftopic> <reftopic>gfw:obtain-horizontal-scrollbar</reftopic> <reftopic>gfw:obtain-vertical-scrollbar</reftopic> - <reftopic>gfw:obtain-status-bar</reftopic> + <reftopic>gfw:status-bar-of</reftopic> </seealso> </class> @@ -3783,29 +3788,6 @@ </seealso> </generic-function> - <generic-function name="obtain-status-bar"> - <syntax> - <arguments> - <argument name="self"> - <description> - An object configured with a statusbar. - </description> - </argument> - </arguments> - <return> - <reftopic>gfw:status-bar</reftopic> - </return> - </syntax> - <description> - Returns the <reftopic>gfw:status-bar</reftopic> - attached to the bottom of <arg0/>, if <arg0/> is configured to - have one. - </description> - <seealso> - <reftopic>gfw:status-item</reftopic> - </seealso> - </generic-function> - <generic-function name="menu-bar"> <syntax with-setf="t"> <arguments> @@ -6121,6 +6103,30 @@  + <slot-accessor name="status-bar-of"> + <syntax> + <arguments> + <argument name="self"> + <description> + An instance of <reftopic>gfw:top-level</reftopic> or + <reftopic>gfw:dialog</reftopic>. + </description> + </argument> + </arguments> + <return> + <reftopic>gfw:status-bar</reftopic> + </return> + </syntax> + <description> + If <arg0/> was created with the :status-bar style, then this function + returns an object representing the status bar widget; otherwise, this + function returns NIL. + </description> + <seealso> + <reftopic>gfw:status-item</reftopic> + </seealso> + </slot-accessor> + <slot-accessor name="style-of"> <syntax with-setf="t"> <arguments> Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Wed Jan 3 22:04:43 2007 @@ -34,7 +34,6 @@ &legal; &introduction; &api; - &protocols; &misctopics; &glossary; Modified: trunk/docs/manual/protocols.xml ============================================================================== --- trunk/docs/manual/protocols.xml (original) +++ trunk/docs/manual/protocols.xml Wed Jan 3 22:04:43 2007 @@ -7,7 +7,7 @@ <title>Protocols</title> <para role="normal"> - This chapter's sections discuss the <glossterm linkend="protocol">protocols</glossterm> + This section discusses the <glossterm linkend="protocol">protocols</glossterm> representing major functional areas of Graphic-Forms. </para> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Jan 3 22:04:43 2007 @@ -76,12 +76,8 @@ <div class="footer"> <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> - Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> + Copyright © 2006-2007 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a> </div> - - </body> </html> Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Jan 3 22:04:43 2007 @@ -147,6 +147,7 @@ (:file "scrolling-helper") (:file "scrollbar") (:file "slider") + (:file "status-bar") (:file "window") (:file "root-window") (:file "top-level") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Jan 3 22:04:43 2007 @@ -189,7 +189,7 @@ :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win* :style '(:multi-line :auto-vscroll Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; packages.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -285,6 +285,7 @@ #:scrollbar #:scrolling-helper #:slider + #:status-bar #:timer #:top-level #:widget @@ -536,6 +537,7 @@ #:size #:spacing-of #:startup + #:status-bar-of #:step-increments #:style-of #:sub-menu Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-constants.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; dialog.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -165,6 +165,10 @@ (reenable-top-levels) (if (visible-p self) (show self nil)) + (let ((sbar (status-bar-of self))) + (when sbar + (delete-widget (thread-context) (gfs:handle sbar)) + (setf (slot-value self 'status-bar) nil))) (call-next-method)) (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Jan 3 22:04:43 2007 @@ -495,7 +495,6 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) - (declare (ignore lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (type (cond @@ -503,9 +502,13 @@ ((= wparam gfs::+size-minimized+) :minimized) ((= wparam gfs::+size-restored+) :restored) (t nil)))) - (when w + (when (and w (not (typep w 'status-bar))) (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) w (size-event-size tc) type))) + (event-resize (dispatcher w) w (size-event-size tc) type) + (if (or (typep w 'top-level) (typep w 'dialog)) + (let ((sbar (status-bar-of w))) + (if sbar + (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ wparam lparam)))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; label.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -81,30 +81,30 @@ ;;; methods ;;; -(defmethod (setf gfg:background-color) (color (label label)) +(defmethod (setf gfg:background-color) (color (self label)) (declare (ignorable color)) (call-next-method) - (let ((image (image label)) - (pnt (pixel-point-of label))) + (let ((image (image self)) + (pnt (pixel-point-of self))) (when image (if pnt (setf (gfg:transparency-pixel-of image) pnt)) - (setf (image label) image)))) + (setf (image self) image)))) -(defmethod compute-style-flags ((label label) &rest extra-data) +(defmethod compute-style-flags ((self label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) (let ((std-style (logior gfs::+ws-child+ gfs::+ws-visible+ (cond ((first extra-data) - (compute-image-style-flags (style-of label))) + (compute-image-style-flags (style-of self))) ((second extra-data) - (if (find :vertical (style-of label)) + (if (find :vertical (style-of self)) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) (t - (compute-text-style-flags (style-of label))))))) + (compute-text-style-flags (style-of self))))))) (values std-style 0))) (defmethod initialize-instance :after ((self label) &key image parent text &allow-other-keys) Added: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Wed Jan 3 22:04:43 2007 @@ -0,0 +1,45 @@ +;;;; +;;;; status-bar.lisp +;;;; +;;;; Copyright (C) 2007, 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) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((self status-bar) &rest extra-data) + (declare (ignore extra-data)) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) + +(defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) + (create-control self parent "" gfs::+icc-win95-classes+)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; top-level.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -120,15 +120,21 @@ |# (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:status-bar) ;; nothing to do, but need to allow this style symbol (:vertical-scrollbar (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags))) (defmethod gfs:dispose ((self top-level)) - (let ((m (menu-bar self))) - (unless (null m) - (visit-menu-tree m #'menu-cleanup-callback) - (delete-widget (thread-context) (gfs:handle m)))) + (let ((menu (menu-bar self)) + (sbar (status-bar-of self)) + (tc (thread-context))) + (when menu + (visit-menu-tree menu #'menu-cleanup-callback) + (delete-widget tc (gfs:handle menu))) + (when sbar + (delete-widget tc (gfs:handle sbar)) + (setf (slot-value self 'status-bar) nil))) (call-next-method)) (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-classes.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -245,6 +245,13 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The menu class represents a container for menu items (and submenus).")) +(defclass status-bar (control item-manager layout-managed) + ((system-classname + :reader system-classname-of + :initform "msctls_statusbar32" + :allocation :class)) + (:documentation "This class represents the status bar widget configured within top-level windows.")) + (defclass window (widget layout-managed) ((max-size :initarg :maximum-size @@ -254,7 +261,10 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) -(defclass dialog (window) () +(defclass dialog (window) + ((status-bar + :reader status-bar-of + :initform nil)) (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) (defclass panel (window) () @@ -263,7 +273,10 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) () +(defclass top-level (window) + ((status-bar + :reader status-bar-of + :initform nil)) (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) (defclass timer (event-source) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -61,6 +61,8 @@ (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) (put-widget tc win)) + (if (find :status-bar (style-of win)) + (setf (slot-value win 'status-bar) (make-instance 'status-bar :parent win))) ;; FIXME: this is a temporary hack to allow layout management testing; ;; it breaks in the presence of virtual containers like group ;; @@ -269,8 +271,8 @@ (update-scrollbar-page-sizes self) (update-scrolling-state self :both)) -(defmethod event-resize ((disp event-dispatcher) (self window) size type) - (declare (ignore size type)) +(defmethod event-resize (disp (self window) size type) + (declare (ignore disp size type)) (unless (null (layout-of self)) (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))

1 0

[graphic-forms-cvs] r422 - in trunk: docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 23 Dec '06

23 Dec '06

Author: junrue Date: Sat Dec 23 01:31:46 2006 New Revision: 422 Added: trunk/docs/manual/protocols.xml Modified: trunk/docs/manual/Makefile trunk/docs/manual/gf-data.xsl trunk/docs/manual/gfw-symbols.xml trunk/docs/manual/glossary.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/miscellaneous-topics.xml trunk/src/uitoolkit/system/system-constants.lisp Log: more documentation, some of which related to status-bar and friends, and some just general doc update Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Sat Dec 23 01:31:46 2006 @@ -10,7 +10,7 @@ CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml gfc-tmp-pkg.xml \ constants.xml api.xml \ catalog.xml glossary.xml graphic-forms.xml image-data-plugins.xml \ - introduction.xml legal.xml miscellaneous-topics.xml + introduction.xml legal.xml protocols.xml miscellaneous-topics.xml COMMON-DEPS = gf-data.xsl gf-package.xsl clhs-table.xml win32-api-table.xml TMP-XML = gfs-tmp-pkg.xml gfs-tmp-syms.xml gfg-tmp-pkg.xml gfg-tmp-syms.xml \ Modified: trunk/docs/manual/gf-data.xsl ============================================================================== --- trunk/docs/manual/gf-data.xsl (original) +++ trunk/docs/manual/gf-data.xsl Sat Dec 23 01:31:46 2006 @@ -2,7 +2,7 @@  <xsl:stylesheet xmlns:exsl="http://exslt.org/common" Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Sat Dec 23 01:31:46 2006 @@ -532,6 +532,7 @@ <hierarchy> <inheritedby> <reftopic>gfw:window</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is a mix-in for widgets that employ a <reftopic>gfw:layout-manager</reftopic> @@ -709,6 +710,7 @@ <inheritedby> <reftopic>gfw:menu</reftopic> <reftopic>gfw:list-box</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is a mix-in for widgets that contain and display sub-elements. @@ -790,6 +792,7 @@ <reftopic>gfw:font-dialog</reftopic> <reftopic>gfw:menu</reftopic> <reftopic>gfw:window</reftopic> + <reftopic>gfw:status-bar</reftopic> </inheritedby> </hierarchy> This is the base class for all windowed user interface objects whose @@ -1444,6 +1447,9 @@ <reftopic>gfs:dispose</reftopic> <reftopic>gfw:owner</reftopic> <reftopic>gfw:text</reftopic> + <reftopic>gfw:obtain-horizontal-scrollbar</reftopic> + <reftopic>gfw:obtain-vertical-scrollbar</reftopic> + <reftopic>gfw:obtain-status-bar</reftopic> </seealso> </class> @@ -2049,9 +2055,82 @@ </initargs> <seealso> <reftopic>gfs:dispose</reftopic> - <reftopic>gfw:dialog</reftopic> + <reftopic>gfw:update-native-style</reftopic> + <reftopic>gfw:parent</reftopic> + <reftopic>gfw:style-of</reftopic> + <reftopic>gfw:list-item</reftopic> <reftopic>gfw:auto-vscroll-p</reftopic> <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> + <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:update-from-items</reftopic> + <reftopic>gfw:item-index</reftopic> + </seealso> + </class> + + <class name="status-bar"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:widget</reftopic> + <reftopic>gfw:layout-managed</reftopic> + <reftopic>gfw:item-manager</reftopic> + </inherits> + </hierarchy> + This class represents the status bar widget with which <reftopic>gfw:top-level</reftopic> + instances may be configured. Application code does not instantiate this class directly. + </description> + <initargs> + <argument name=":parent"> + <description> + This initarg specifies the parent of the control. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + <reftopic>gfw:update-native-style</reftopic> + <reftopic>gfw:parent</reftopic> + <reftopic>gfw:style-of</reftopic> + <reftopic>gfw:status-item</reftopic> + <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> + <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:update-from-items</reftopic> + <reftopic>gfw:item-index</reftopic> + </seealso> + </class> + + <class name="status-item"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:item</reftopic> + </inherits> + </hierarchy> + This class represents an element of a <reftopic>gfw:status-bar</reftopic>. + </description> + <initargs> + <argument name=":parent"> + <description> + This initarg specifies the parent of the control. + </description> + </argument> + <argument name=":data"> + <description> + See <reftopic>gfw:item</reftopic>. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> </seealso> </class> @@ -2946,7 +3025,11 @@ </para> </description> <seealso> + <reftopic>gfw:append-item</reftopic> + <reftopic>gfw:delete-item</reftopic> + <reftopic>gfw:item-count</reftopic> <reftopic>gfw:items-of</reftopic> + <reftopic>gfw:item-index</reftopic> </seealso> </generic-function> @@ -3700,6 +3783,29 @@ </seealso> </generic-function> + <generic-function name="obtain-status-bar"> + <syntax> + <arguments> + <argument name="self"> + <description> + An object configured with a statusbar. + </description> + </argument> + </arguments> + <return> + <reftopic>gfw:status-bar</reftopic> + </return> + </syntax> + <description> + Returns the <reftopic>gfw:status-bar</reftopic> + attached to the bottom of <arg0/>, if <arg0/> is configured to + have one. + </description> + <seealso> + <reftopic>gfw:status-item</reftopic> + </seealso> + </generic-function> + <generic-function name="menu-bar"> <syntax with-setf="t"> <arguments> Modified: trunk/docs/manual/glossary.xml ============================================================================== --- trunk/docs/manual/glossary.xml (original) +++ trunk/docs/manual/glossary.xml Sat Dec 23 01:31:46 2006 @@ -1,7 +1,7 @@  <glossary id="glossary"><title>Glossary</title> <indexterm><primary>Glossary</primary></indexterm> @@ -11,7 +11,7 @@ <glossentry id="accelerator"><glossterm>accelerator</glossterm> <glossdef> <para> - An accelerator is a key sequence assigned to an application + An <emphasis>accelerator</emphasis> is a key sequence assigned to an application function allowing a user to bypass navigation of the menu or control hierarchy normally required to invoke the function. Some accelerators are established by Windows style guidelines, such as control-c for @@ -27,7 +27,7 @@ <glossentry id="auto-scrolling"><glossterm>auto-scrolling</glossterm> <glossdef> <para> - Auto-scrolling is a feature whereby scrolling occurs as a side + <emphasis>Auto-scrolling</emphasis> is a feature whereby scrolling occurs as a side effect of user input so content can remain visible, thus avoiding the need to explicitly manipulate scrollbars to achieve the same result. </para> @@ -44,9 +44,9 @@ <glossentry id="control"><glossterm>control</glossterm> <glossdef> <para> - A control is a system-defined window class whose role is to accept - user input and possibly generate notification events based on such - input. + A <emphasis>control</emphasis> is a system-defined window class whose + role is to accept user input and possibly generate notification events + based on such input. </para> </glossdef> </glossentry> @@ -58,9 +58,9 @@ <glossentry id="default action"><glossterm>default action</glossterm> <glossdef> <para> - Conceptually, a default action is a secondary event initiated by - user input that is a logical follow-up to a previous event. Examples - of such user gestures include double-clicking an item in a list box + Conceptually, a <emphasis>default action</emphasis> is a secondary event + initiated by user input that is a logical follow-up to a previous event. + Examples of such user gestures include double-clicking an item in a list box control, or pressing enter when an edit control has the keyboard focus. The response to a default action makes use of context established by the preceding event (e.g., the selection set by an initial click @@ -72,8 +72,8 @@ <glossentry id="dialog"><glossterm>dialog</glossterm> <glossdef> <para> - A dialog is a mechanism for collecting user input or showing - information. The system defines common dialogs for tasks like + A <emphasis>dialog</emphasis> is a mechanism for collecting user input + or showing information. The system defines common dialogs for tasks like choosing files, fonts, or colors. Custom dialogs can be defined by application code. </para> @@ -87,8 +87,8 @@ <glossentry id="extension"><glossterm>extension</glossterm> <glossdef> <para> - An extension is code providing additional functionality beyond the - original scope of a system. An extension framework encourages + An <emphasis>extension</emphasis> is code providing additional functionality + beyond the original scope of a system. An extension framework encourages modularity. More importantly, it is a conscious design choice to allow a system to be stretched beyond what the original designers may have anticipated. @@ -126,9 +126,9 @@ <glossdef> <para> A collection of menu items presented within a single rectangular - region. Menus are often anchored to a menu bar, but may also be - invoked in a context-sensitive manner via the mouse or an - <glossseealso otherterm="accelerator"/>. + region. <emphasis>Menus</emphasis> are often anchored to a menu bar, + but may also be invoked in a context-sensitive manner via the mouse + or an <glossseealso otherterm="accelerator"/>. </para> </glossdef> </glossentry> @@ -136,8 +136,8 @@ <glossentry id="mix-in"><glossterm>mix-in class</glossterm> <glossdef> <para> - A mix-in class represents a specific abstraction that complements - the role(s) of other class(es) in a class hierarchy. + A <emphasis>mix-in</emphasis> class represents a specific abstraction + that complements the role(s) of other class(es) in a class hierarchy. </para> </glossdef> </glossentry> @@ -145,10 +145,10 @@ <glossentry id="mnemonic"><glossterm>mnemonic</glossterm> <glossdef> <para> - A mnemonic is a key sequence (usually a single character modified - by the <Alt> key) enabling mouse-free navigation of a menu or - control hierarchy to invoke an application function. Depending on - the user's system settings, mnemonic characters may be hidden until + A <emphasis>mnemonic</emphasis> is a key sequence (usually a single + character modified by the <Alt> key) enabling mouse-free navigation + of a menu or control hierarchy to invoke an application function. Depending + on the user's system settings, mnemonic characters may be hidden until the user presses the <Alt> key. </para> <glossseealso otherterm="accelerator"/> @@ -167,15 +167,26 @@ <glossentry id="plugin"><glossterm>plugin</glossterm> <glossdef> <para> - A plugin is a unit of code integrated into a larger system in order - to implement a specific instance of an established category of - services. A plugin framework encourages modularity within a - defined scope of functionality. + A <emphasis>plugin</emphasis> is a unit of code integrated into + a larger system in order to implement a specific instance of an + established category of services. A plugin framework encourages + modularity within a defined scope of functionality. </para> <glossseealso otherterm="extension"/> </glossdef> </glossentry> + <glossentry id="protocol"><glossterm>protocol</glossterm> + <glossdef> + <para> + In Common Lisp, a <emphasis>protocol</emphasis> refers to a group + of logically-related functions (usually generic functions, since + protocols are often designed to be extensible). The Metaobject + Protocol (MOP) is a popular and sophisticated example. + </para> + </glossdef> + </glossentry> + </glossdiv> <glossdiv id="glossary-Q"><title>Q</title> Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Sat Dec 23 01:31:46 2006 @@ -14,6 +14,7 @@ <!ENTITY gfgpkg SYSTEM "gfg-tmp-pkg.xml">  <!ENTITY gfspkg SYSTEM "gfs-tmp-pkg.xml">  <!ENTITY gfwpkg SYSTEM "gfw-tmp-pkg.xml">  + <!ENTITY protocols SYSTEM "protocols.xml"> <!ENTITY misctopics SYSTEM "miscellaneous-topics.xml"> <!ENTITY imdataplugins SYSTEM "image-data-plugins.xml"> <!ENTITY glossary SYSTEM "glossary.xml"> @@ -33,6 +34,7 @@ &legal; &introduction; &api; + &protocols; &misctopics; &glossary; Modified: trunk/docs/manual/miscellaneous-topics.xml ============================================================================== --- trunk/docs/manual/miscellaneous-topics.xml (original) +++ trunk/docs/manual/miscellaneous-topics.xml Sat Dec 23 01:31:46 2006 @@ -1,7 +1,7 @@  <chapter id="misc-topics"> <title>Miscellaneous Topics</title> Added: trunk/docs/manual/protocols.xml ============================================================================== --- (empty file) +++ trunk/docs/manual/protocols.xml Sat Dec 23 01:31:46 2006 @@ -0,0 +1,16 @@ + +<chapter id="protocols"> + <title>Protocols</title> + + <para role="normal"> + This chapter's sections discuss the <glossterm linkend="protocol">protocols</glossterm> + representing major functional areas of Graphic-Forms. + </para> + + + +</chapter> Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sat Dec 23 01:31:46 2006 @@ -951,24 +951,24 @@ ;;; statusbar constants ;;; -(defconstant +sb-SETPARTS+ #x0404) ; (WM_USER+4) -(defconstant +sb-GETPARTS+ #x0406) ; (WM_USER+6) -(defconstant +sb-GETBORDERS+ #x0407) ; (WM_USER+7) -(defconstant +sb-SETMINHEIGHT+ #x0408) ; (WM_USER+8) -(defconstant +sb-SIMPLE+ #x0409) ; (WM_USER+9) -(defconstant +sb-GETRECT+ #x040A) ; (WM_USER+10) -(defconstant +sb-ISSIMPLE+ #x040E) ; (WM_USER+14) -(defconstant +sb-SETICON+ #x040F) ; (WM_USER+15) -(defconstant +sb-SETTIPTEXTA+ #x0410) ; (WM_USER+16) -(defconstant +sb-SETTIPTEXTW+ #x0411) ; (WM_USER+17) -(defconstant +sb-GETTIPTEXTA+ #x0412) ; (WM_USER+18) -(defconstant +sb-GETTIPTEXTW+ #x0413) ; (WM_USER+19) -(defconstant +sb-GETICON+ #x0414) ; (WM_USER+20) -(defconstant +sb-SETUNICODEFORMAT+ #x2005) ; CCM_SETUNICODEFORMAT -(defconstant +sb-GETUNICODEFORMAT+ #x2006) ; CCM_GETUNICODEFORMAT +(defconstant +sb-setparts+ #x0404) ; (WM_USER+4) +(defconstant +sb-getparts+ #x0406) ; (WM_USER+6) +(defconstant +sb-getborders+ #x0407) ; (WM_USER+7) +(defconstant +sb-setminheight+ #x0408) ; (WM_USER+8) +(defconstant +sb-simple+ #x0409) ; (WM_USER+9) +(defconstant +sb-getrect+ #x040A) ; (WM_USER+10) +(defconstant +sb-issimple+ #x040E) ; (WM_USER+14) +(defconstant +sb-seticon+ #x040F) ; (WM_USER+15) +(defconstant +sb-settiptexta+ #x0410) ; (WM_USER+16) +(defconstant +sb-settiptextw+ #x0411) ; (WM_USER+17) +(defconstant +sb-gettiptexta+ #x0412) ; (WM_USER+18) +(defconstant +sb-gettiptextw+ #x0413) ; (WM_USER+19) +(defconstant +sb-geticon+ #x0414) ; (WM_USER+20) +(defconstant +sb-setunicodeformat+ #x2005) ; CCM_SETUNICODEFORMAT +(defconstant +sb-getunicodeformat+ #x2006) ; CCM_GETUNICODEFORMAT -(defconstant +sbars-SIZEGRIP+ #x0100) -(defconstant +sbars-TOOLTIPS+ #x0800) +(defconstant +sbars-sizegrip+ #x0100) +(defconstant +sbars-tooltips+ #x0800) (defconstant +sbs-horz+ #x0000) (defconstant +sbs-vert+ #x0001)

1 0

[graphic-forms-cvs] r421 - in trunk: docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 23 Dec '06

23 Dec '06

Author: junrue Date: Fri Dec 22 22:19:32 2006 New Revision: 421 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: preparation for status-bar implementation Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Fri Dec 22 22:19:32 2006 @@ -1412,6 +1412,7 @@ One or more of the following optional styles: <enum> <argument name=":horizontal-scrollbar"/> + <argument name=":statusbar"/> <argument name=":vertical-scrollbar"/> </enum> </description> Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Dec 22 22:19:32 2006 @@ -922,6 +922,10 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000F0000) +;;; +;;; scrollbar constants +;;; + (defconstant +sb-horz+ 0) (defconstant +sb-vert+ 1) (defconstant +sb-ctl+ 2) @@ -943,6 +947,29 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +;;; +;;; statusbar constants +;;; + +(defconstant +sb-SETPARTS+ #x0404) ; (WM_USER+4) +(defconstant +sb-GETPARTS+ #x0406) ; (WM_USER+6) +(defconstant +sb-GETBORDERS+ #x0407) ; (WM_USER+7) +(defconstant +sb-SETMINHEIGHT+ #x0408) ; (WM_USER+8) +(defconstant +sb-SIMPLE+ #x0409) ; (WM_USER+9) +(defconstant +sb-GETRECT+ #x040A) ; (WM_USER+10) +(defconstant +sb-ISSIMPLE+ #x040E) ; (WM_USER+14) +(defconstant +sb-SETICON+ #x040F) ; (WM_USER+15) +(defconstant +sb-SETTIPTEXTA+ #x0410) ; (WM_USER+16) +(defconstant +sb-SETTIPTEXTW+ #x0411) ; (WM_USER+17) +(defconstant +sb-GETTIPTEXTA+ #x0412) ; (WM_USER+18) +(defconstant +sb-GETTIPTEXTW+ #x0413) ; (WM_USER+19) +(defconstant +sb-GETICON+ #x0414) ; (WM_USER+20) +(defconstant +sb-SETUNICODEFORMAT+ #x2005) ; CCM_SETUNICODEFORMAT +(defconstant +sb-GETUNICODEFORMAT+ #x2006) ; CCM_GETUNICODEFORMAT + +(defconstant +sbars-SIZEGRIP+ #x0100) +(defconstant +sbars-TOOLTIPS+ #x0800) + (defconstant +sbs-horz+ #x0000) (defconstant +sbs-vert+ #x0001) (defconstant +sbs-topalign+ #x0002) @@ -954,6 +981,12 @@ (defconstant +sbs-sizebox+ #x0008) (defconstant +sbs-sizegrip+ #x0010) +(defconstant +sbt-ownerdraw+ #x1000) +(defconstant +sbt-noborders+ #x0100) +(defconstant +sbt-popout+ #x0200) +(defconstant +sbt-rtlreading+ #x0400) +(defconstant +sbt-notabparsing+ #x0800) + (defconstant +sif-range+ #x0001) (defconstant +sif-page+ #x0002) (defconstant +sif-pos+ #x0004) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Dec 22 22:19:32 2006 @@ -187,10 +187,24 @@ (defctype dllversioninfo-pointer :pointer) +(defcstruct drawitemstruct + (ctltype UINT) + (ctlid UINT) + (itemid UINT) + (itemaction UINT) + (itemstate UINT) + (hwnd HANDLE) + (hdc HANDLE) + (itemleft LONG) + (itemtop LONG) + (itemright LONG) + (itembottom LONG) + (itemdata :pointer)) + (defcstruct drawtextparams - (cbsize UINT) - (tablength INT) - (leftmargin INT) + (cbsize UINT) + (tablength INT) + (leftmargin INT) (rightmargin INT) (lengthdrawn UINT))

1 0

[graphic-forms-cvs] r420 - trunk/docs/manual
by junrue＠common-lisp.net 21 Dec '06

21 Dec '06

Author: junrue Date: Thu Dec 21 00:00:01 2006 New Revision: 420 Modified: trunk/docs/manual/gfs-symbols.xml Log: documented null-handle-p Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Thu Dec 21 00:00:01 2006 @@ -228,6 +228,7 @@ <reftopic>gfs:handle</reftopic> <reftopic>gfs:disposed-error</reftopic> <reftopic>gfs:disposed-p</reftopic> + <reftopic>gfs:null-handle-p</reftopic> </seealso> </class> @@ -584,6 +585,30 @@ </description> </function> + <function name="null-handle-p"> + <syntax> + <arguments> + <argument name="handle"> + <description> + A <emphasis>native handle</emphasis> represented within + Graphic-Forms using the CFFI :pointer type. + </description> + </argument> + </arguments> + <return> + <refclhs>boolean</refclhs> + </return> + </syntax> + <description> + Returns T if <arg0/> is null (meaning that its foreign address is zero); + NIL otherwise. + </description> + <seealso> + <reftopic>gfs:handle</reftopic> + <reftopic>gfs:native-object</reftopic> + </seealso> + </function> + <function name="make-point"> <syntax> <arguments> @@ -1157,6 +1182,7 @@ <reftopic>gfs:dispose</reftopic> <reftopic>gfs:disposed-p</reftopic> <reftopic>gfs:disposed-error</reftopic> + <reftopic>gfs:null-handle-p</reftopic> </seealso> </slot-reader>

1 0

[graphic-forms-cvs] r419 - in trunk: . src/uitoolkit/system
by junrue＠common-lisp.net 21 Dec '06

21 Dec '06

Author: junrue Date: Wed Dec 20 23:31:33 2006 New Revision: 419 Modified: trunk/NEWS.txt trunk/README.txt trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/system/kernel32.lisp trunk/src/uitoolkit/system/metrics.lisp trunk/src/uitoolkit/system/native-object.lisp trunk/src/uitoolkit/system/shell32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-utils.lisp Log: implemented manual DLL loading and function pointer querying; fixed comctl32 and shell32 version querying; changed gfs:null-handle-p to an inlined function from a macro Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Wed Dec 20 23:31:33 2006 @@ -1,6 +1,9 @@ . Graphic-Forms has been ported to Allegro CL 8.0. +. GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll + and shell32.dll. + ============================================================================== Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Wed Dec 20 23:31:33 2006 @@ -17,7 +17,7 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - CFFI (cffi-060925 or later) + - CFFI (cffi-061208 or later) http://common-lisp.net/project/cffi/ - Closer to MOP Modified: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comctl32.lisp (original) +++ trunk/src/uitoolkit/system/comctl32.lisp Wed Dec 20 23:31:33 2006 @@ -38,10 +38,18 @@ (load-foreign-library "comctl32.dll") +;;; See this thread: +;;; +;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html +;;; +;;; for a discussion of why the following is commented out. +;;; +#| (defcfun ("DllGetVersion" comctl-dll-get-version) HRESULT (info :pointer)) +|# (defcfun ("InitCommonControlsEx" init-common-controls) Modified: trunk/src/uitoolkit/system/kernel32.lisp ============================================================================== --- trunk/src/uitoolkit/system/kernel32.lisp (original) +++ trunk/src/uitoolkit/system/kernel32.lisp Wed Dec 20 23:31:33 2006 @@ -39,11 +39,29 @@ (load-foreign-library "kernel32.dll") (defcfun + ("FreeLibrary" free-library) + BOOL + (hmodule HANDLE)) + +(defcfun ("GetLastError" get-last-error) DWORD) (defcfun ("GetModuleHandleA" get-module-handle) HANDLE - (module-name LPTR)) ; FIXME: ought to be LPTSTR but I can't see how to define - ; a null string pointer + (module-name LPTSTR)) + +(defcfun + ("GetProcAddress" get-proc-address) + :pointer + (hmodule HANDLE) + (proc-name LPTSTR)) + +(defcfun + ("LoadLibraryExA" load-library) + HANDLE + (file-name LPTSTR) + (hfile HANDLE) ; currently reserved and must be a NULL pointer + (flags DWORD)) + Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Wed Dec 20 23:31:33 2006 @@ -33,12 +33,21 @@ (in-package :graphic-forms.uitoolkit.system) -(defun obtain-dll-version-info (foreign-func) - (cffi:with-foreign-object (ptr 'dllversioninfo) - (cffi:with-foreign-slots ((size vermajor verminor buildnum) ptr dllversioninfo) - (setf size (cffi:foreign-type-size 'dllversioninfo)) - (funcall foreign-func ptr) - (list vermajor verminor buildnum)))) +(defun obtain-dll-version-info (dll-path) + (let ((hmodule (load-library-wrapper dll-path)) + (version (list 0 0 0))) + (unless (null-handle-p hmodule) + (unwind-protect + (let ((func-ptr (retrieve-function-pointer hmodule "DllGetVersion"))) + (unless (cffi:null-pointer-p func-ptr) + (cffi:with-foreign-object (info-ptr 'gfs::dllversioninfo) + (cffi:with-foreign-slots ((gfs::size gfs::vermajor gfs::verminor gfs::buildnum) + info-ptr gfs::dllversioninfo) + (setf gfs::size (cffi:foreign-type-size 'gfs::dllversioninfo)) + (cffi:foreign-funcall func-ptr gfs::dllversioninfo info-ptr gfs::hresult) + (setf version (list gfs::vermajor gfs::verminor gfs::buildnum)))))) + (gfs::free-library hmodule))) + version)) (defun obtain-system-metrics () "Query system metrics and return them via a hash table." @@ -118,7 +127,7 @@ ;; A list of integers describing the version of comctl32.dll. ;; (setf (gethash :comctl32-version table) - (obtain-dll-version-info #'comctl-dll-get-version)) + (obtain-dll-version-info "comctl32.dll")) ;; ;; :cursor-size ;; @@ -353,7 +362,7 @@ ;; A list of integers describing the version of comctl32.dll. ;; (setf (gethash :shell32-version table) - (obtain-dll-version-info #'shell-dll-get-version)) + (obtain-dll-version-info "shell32.dll")) ;; ;; :shutting-down ;; Modified: trunk/src/uitoolkit/system/native-object.lisp ============================================================================== --- trunk/src/uitoolkit/system/native-object.lisp (original) +++ trunk/src/uitoolkit/system/native-object.lisp Wed Dec 20 23:31:33 2006 @@ -36,5 +36,6 @@ (defmethod disposed-p ((obj native-object)) (null (handle obj))) -(defmacro null-handle-p (handle) - `(cffi:null-pointer-p ,handle)) +(declaim (inline null-handle-p)) +(defun null-handle-p (handle) + (cffi:null-pointer-p handle)) Modified: trunk/src/uitoolkit/system/shell32.lisp ============================================================================== --- trunk/src/uitoolkit/system/shell32.lisp (original) +++ trunk/src/uitoolkit/system/shell32.lisp Wed Dec 20 23:31:33 2006 @@ -38,7 +38,15 @@ (load-foreign-library "shell32.dll") +;;; See this thread: +;;; +;;; http://common-lisp.net/pipermail/cffi-devel/2006-December/000971.html +;;; +;;; for a discussion of why the following is commented out. +;;; +#| (defcfun ("DllGetVersion" shell-dll-get-version) HRESULT (info :pointer)) +|# Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Dec 20 23:31:33 2006 @@ -1687,6 +1687,14 @@ (defconstant +colormgmtcaps+ 121) ;;; +;;; LoadLibraryEx flags +;;; +(defconstant +dont-resolve-dll-references+ #x00000001) +(defconstant +load-library-as-datafile+ #x00000002) +(defconstant +load-with-altered-search-path+ #x00000008) +(defconstant +load-ignore-code-authz-level+ #x00000010) + +;;; ;;; Background modes (Get/SetBkMode) ;;; (defconstant +transparent+ 1) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Wed Dec 20 23:31:33 2006 @@ -163,6 +163,25 @@ (defun make-lparam (hi lo) (logior (ash (logand lo #xFFFF) 16) (logand hi #xFFFF))) +(defun load-library-wrapper (dll-path) + (let ((hmodule (cffi:null-pointer))) + (cffi:with-foreign-string (str-ptr dll-path) + (setf hmodule (load-library str-ptr (cffi:null-pointer) 0))) + (when (null-handle-p hmodule) + (warn 'toolkit-warning :detail (format nil "could not load ~s" dll-path))) + hmodule)) + +(defun retrieve-function-pointer (hmodule func-name) + (let ((func-ptr (cffi:null-pointer))) + (if (null-handle-p hmodule) + (error 'toolkit-error :detail "null module handle")) + (cffi:with-foreign-string (str-ptr func-name) + (setf func-ptr (gfs::get-proc-address hmodule str-ptr))) + (if (gfs:null-handle-p func-ptr) + (let ((detail (format nil "could not get function pointer for ~s" func-name))) + (warn 'gfs:toolkit-warning :detail detail))) + func-ptr)) + ;;; ;;; convenience macros ;;;

1 0

[graphic-forms-cvs] r418 - trunk/etc
by junrue＠common-lisp.net 18 Dec '06

18 Dec '06

Author: junrue Date: Mon Dec 18 00:59:57 2006 New Revision: 418 Modified: trunk/etc/lisp.exe.manifest Log: this manifest works correctly, at least with clisp Modified: trunk/etc/lisp.exe.manifest ============================================================================== --- trunk/etc/lisp.exe.manifest (original) +++ trunk/etc/lisp.exe.manifest Mon Dec 18 00:59:57 2006 @@ -1,10 +1,10 @@ <?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> - <assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/> - <description>GNU CLISP</description> - <dependency> - <dependentAssembly> - <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/> - </dependentAssembly> - </dependency> + <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/> + <description>GNU CLISP</description> + <dependency> + <dependentAssembly> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/> + </dependentAssembly> + </dependency> </assembly>

1 0

[graphic-forms-cvs] r417 - in trunk: . docs/manual src/uitoolkit/system
by junrue＠common-lisp.net 18 Dec '06

18 Dec '06

Author: junrue Date: Mon Dec 18 00:22:52 2006 New Revision: 417 Added: trunk/src/uitoolkit/system/shell32.lisp Modified: trunk/docs/manual/gfc-symbols.xml trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/legal.xml trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/comctl32.lisp trunk/src/uitoolkit/system/metrics.lisp trunk/src/uitoolkit/system/system-types.lisp Log: enhanced obtain-system-metrics to include version info for comctl32.dll and shell32.dll, but still need to track down why duplicate version info is returned Modified: trunk/docs/manual/gfc-symbols.xml ============================================================================== --- trunk/docs/manual/gfc-symbols.xml (original) +++ trunk/docs/manual/gfc-symbols.xml Mon Dec 18 00:22:52 2006 @@ -17,6 +17,51 @@  + <class name="listener-panel"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:panel</reftopic> + </inherits> + </hierarchy> + This class implements a text-based input/output component which + can serve as a REPL. Its size and location can be + maintained by its parent's layout manager; however, note that best + visual results are achieved when the panel is allowed to maintain + integral height and width. + </description> + <initargs> + <argument name=":callbacks"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":dispatcher"> + <description> + See <reftopic>gfw:event-source</reftopic>. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + <argument name=":parent"> + <description> + See <reftopic>gfw:panel</reftopic>. + </description> + </argument> + <argument name=":style"> + <description> + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + <reftopic>gfw:parent</reftopic> + </seealso> + </class> +   Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Dec 18 00:22:52 2006 @@ -370,6 +370,13 @@ button type. </description> </argument> + <argument name=":comctl32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + comctl32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":cursor-size"> <description> A <reftopic>gfs:size</reftopic> describing the dimensions of a cursor @@ -535,6 +542,13 @@ arrow bitmap. </description> </argument> + <argument name=":shell32-version"> + <description> + A <refclhs>list</refclhs> whose first element is an integer specifying + shell32.dll's major version number. The second element is the DLL's + minor version number, and the third element is the DLL's build number. + </description> + </argument> <argument name=":shutting-down"> <description> T if the current session is shutting down; NIL otherwise. Modified: trunk/docs/manual/legal.xml ============================================================================== --- trunk/docs/manual/legal.xml (original) +++ trunk/docs/manual/legal.xml Mon Dec 18 00:22:52 2006 @@ -1,12 +1,12 @@  <chapter id="legal"> <title>Legal Notices</title> <para> - Copyright © 2006, Jack D. Unrue <jdunrue at gmail dot com> + Copyright © 2006-2007, Jack D. Unrue <jdunrue at gmail dot com> </para> <para role="normal"> Redistribution and use in source and binary forms, with or without Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Dec 18 00:22:52 2006 @@ -67,8 +67,9 @@ (:file "system-types") (:file "datastructs") (:file "clib") - (:file "comdlg32") (:file "comctl32") + (:file "comdlg32") + (:file "shell32") (:file "gdi32") (:file "kernel32") (:file "user32") Modified: trunk/src/uitoolkit/system/comctl32.lisp ============================================================================== --- trunk/src/uitoolkit/system/comctl32.lisp (original) +++ trunk/src/uitoolkit/system/comctl32.lisp Mon Dec 18 00:22:52 2006 @@ -39,6 +39,11 @@ (load-foreign-library "comctl32.dll") (defcfun + ("DllGetVersion" comctl-dll-get-version) + HRESULT + (info :pointer)) + +(defcfun ("InitCommonControlsEx" init-common-controls) BOOL (init LPTR)) Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Mon Dec 18 00:22:52 2006 @@ -33,6 +33,13 @@ (in-package :graphic-forms.uitoolkit.system) +(defun obtain-dll-version-info (foreign-func) + (cffi:with-foreign-object (ptr 'dllversioninfo) + (cffi:with-foreign-slots ((size vermajor verminor buildnum) ptr dllversioninfo) + (setf size (cffi:foreign-type-size 'dllversioninfo)) + (funcall foreign-func ptr) + (list vermajor verminor buildnum)))) + (defun obtain-system-metrics () "Query system metrics and return them via a hash table." (let ((table (make-hash-table))) @@ -106,6 +113,13 @@ (make-size :width (get-system-metrics +sm-cxsmsize+) :height (get-system-metrics +sm-cysmsize+)))) ;; + ;; :comctl32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :comctl32-version table) + (obtain-dll-version-info #'comctl-dll-get-version)) + ;; ;; :cursor-size ;; ;; The size of the cursor image in pixels. @@ -334,6 +348,13 @@ (make-size :width (get-system-metrics +sm-cxhscroll+) :height (get-system-metrics +sm-cyvscroll+))) ;; + ;; :shell32-version + ;; + ;; A list of integers describing the version of comctl32.dll. + ;; + (setf (gethash :shell32-version table) + (obtain-dll-version-info #'shell-dll-get-version)) + ;; ;; :shutting-down ;; ;; T if the current session is shutting down; NIL otherwise. Added: trunk/src/uitoolkit/system/shell32.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/system/shell32.lisp Mon Dec 18 00:22:52 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; shell32.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.system) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-package :cffi)) + +(load-foreign-library "shell32.dll") + +(defcfun + ("DllGetVersion" shell-dll-get-version) + HRESULT + (info :pointer)) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Dec 18 00:22:52 2006 @@ -45,33 +45,33 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in gfs: package -(defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) +(defctype ATOM :unsigned-short) ; shadowed in gfs: package +(defctype BOOL :int) +(defctype BOOLEAN :char) ; shadowed in gfs: package +(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) -(defctype DWORD :unsigned-long) -(defctype HANDLE :pointer) -(defctype INT :int) -(defctype LANGID :short) -(defctype LONG :long) -(defctype LPARAM :long) -(defctype LPCSTR :pointer) -(defctype LPCTSTR :pointer) -(defctype LPFN :long) ; FIXME: not currently used; maybe should be :pointer instead -(defctype LPRECT :pointer) -(defctype LPSTR :pointer) -(defctype LPTR :pointer) -(defctype LPTSTR :pointer) -(defctype LPVOID :long) -(defctype LRESULT :unsigned-long) -(defctype SHORT :unsigned-short) -(defctype TCHAR :char) -(defctype UINT :unsigned-int) -(defctype ULONG :unsigned-long) -(defctype USHORT :unsigned-short) -(defctype WORD :short) -(defctype WPARAM :unsigned-int) +(defctype DWORD :unsigned-long) +(defctype HANDLE :pointer) +(defctype HRESULT :unsigned-int) +(defctype INT :int) +(defctype LANGID :short) +(defctype LONG :long) +(defctype LPARAM :long) +(defctype LPCSTR :pointer) +(defctype LPCTSTR :pointer) +(defctype LPRECT :pointer) +(defctype LPSTR :pointer) +(defctype LPTR :pointer) +(defctype LPTSTR :pointer) +(defctype LPVOID :long) +(defctype LRESULT :unsigned-long) +(defctype SHORT :unsigned-short) +(defctype TCHAR :char) +(defctype UINT :unsigned-int) +(defctype ULONG :unsigned-long) +(defctype USHORT :unsigned-short) +(defctype WORD :short) +(defctype WPARAM :unsigned-int) #+sbcl (sb-alien:define-alien-type enumchildproc @@ -178,6 +178,15 @@ (minsize INT) (maxsize INT)) +(defcstruct dllversioninfo + (size DWORD) + (vermajor DWORD) + (verminor DWORD) + (buildnum DWORD) + (platform DWORD)) + +(defctype dllversioninfo-pointer :pointer) + (defcstruct drawtextparams (cbsize UINT) (tablength INT) @@ -209,7 +218,7 @@ (defcstruct initcommoncontrolsex (size DWORD) - (icc DWORD)) + (icc DWORD)) (defcstruct logbrush (style UINT)

1 0

[graphic-forms-cvs] r416 - in trunk: . docs/manual src/demos/textedit src/demos/unblocked
by junrue＠common-lisp.net 17 Dec '06

17 Dec '06

Author: junrue Date: Sun Dec 17 00:59:28 2006 New Revision: 416 Added: trunk/docs/manual/gfc-symbols.xml Modified: trunk/README.txt trunk/docs/manual/Makefile trunk/docs/manual/api.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/graphic-forms.xsl trunk/docs/manual/introduction.xml trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp Log: bump up version string Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Dec 17 00:59:28 2006 @@ -1,6 +1,6 @@ -Graphic-Forms README for version 0.7.0 (1 December 2006) -Copyright (c) 2006, Jack D. Unrue +Graphic-Forms README for version 0.8.0 (xx xxxxxx 2007) +Copyright (c) 2006-2007, Jack D. Unrue Graphic-Forms is a user interface library implemented in Common Lisp focusing on the Windows(R) platform. Graphic-Forms is licensed under the terms of the Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Sun Dec 17 00:59:28 2006 @@ -2,19 +2,20 @@ # # Makefile # -# Copyright (c) 2006, Jack D. Unrue +# Copyright (c) 2006-2007, Jack D. Unrue # -VERSION = 0.7 +VERSION = 0.8 -CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml \ +CHM-DEPS = gfs-tmp-pkg.xml gfg-tmp-pkg.xml gfw-tmp-pkg.xml gfc-tmp-pkg.xml \ constants.xml api.xml \ catalog.xml glossary.xml graphic-forms.xml image-data-plugins.xml \ introduction.xml legal.xml miscellaneous-topics.xml COMMON-DEPS = gf-data.xsl gf-package.xsl clhs-table.xml win32-api-table.xml TMP-XML = gfs-tmp-pkg.xml gfs-tmp-syms.xml gfg-tmp-pkg.xml gfg-tmp-syms.xml \ - gfw-tmp-pkg.xml gfw-tmp-syms.xml tmp.xml + gfw-tmp-pkg.xml gfw-tmp-syms.xml gfc-tmp-pkg.xml gfc-tmp-syms.xml \ + tmp.xml XSLT-PROC = xsltproc --nonet @@ -24,6 +25,12 @@ -hhc htmlhelp.hhp; exit 0 # muffle Error Ignored msg due to hhc exit value 1 find . $ -name "*~" -o -name "*.html" -o -name "*.hhk" -o -name "*.hhc" -o -name "*.hhp" $ -exec rm {} \; +gfc-tmp-syms.xml: gfc-symbols.xml $(COMMON-DEPS) + $(XSLT-PROC) --output $@ gf-data.xsl gfc-symbols.xml + +gfc-tmp-pkg.xml: gfc-tmp-syms.xml gfc-symbols.xml $(COMMON-DEPS) + $(XSLT-PROC) --stringparam symbol-file gfc-tmp-syms.xml --output $@ gf-package.xsl gfc-symbols.xml + gfs-tmp-syms.xml: gfs-symbols.xml $(COMMON-DEPS) $(XSLT-PROC) --output $@ gf-data.xsl gfs-symbols.xml Modified: trunk/docs/manual/api.xml ============================================================================== --- trunk/docs/manual/api.xml (original) +++ trunk/docs/manual/api.xml Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@  <chapter id="api"> <title>API Reference</title> @@ -11,6 +11,7 @@ </para> &constants; + &gfcpkg; &gfgpkg; &gfspkg; &gfwpkg; Added: trunk/docs/manual/gfc-symbols.xml ============================================================================== --- (empty file) +++ trunk/docs/manual/gfc-symbols.xml Sun Dec 17 00:59:28 2006 @@ -0,0 +1,28 @@ +<?xml version="1.0"?> + + +<package name="gfc" fullname="graphic-forms.uitoolkit.custom"> + + <description> + The symbols in this package correspond to custom components built on top + of the rest of the library which don't necessarily have an immediate + native peer. + </description> + +  + +  + +  + +  + +  + +  + +</package> Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Sun Dec 17 00:59:28 2006 @@ -2,7 +2,7 @@  <!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook XML V4.2//EN" "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd" [ @@ -10,6 +10,7 @@ <!ENTITY introduction SYSTEM "introduction.xml"> <!ENTITY api SYSTEM "api.xml"> <!ENTITY constants SYSTEM "constants.xml"> + <!ENTITY gfcpkg SYSTEM "gfc-tmp-pkg.xml">  <!ENTITY gfgpkg SYSTEM "gfg-tmp-pkg.xml">  <!ENTITY gfspkg SYSTEM "gfs-tmp-pkg.xml">  <!ENTITY gfwpkg SYSTEM "gfw-tmp-pkg.xml">  Modified: trunk/docs/manual/graphic-forms.xsl ============================================================================== --- trunk/docs/manual/graphic-forms.xsl (original) +++ trunk/docs/manual/graphic-forms.xsl Sun Dec 17 00:59:28 2006 @@ -2,7 +2,7 @@  <xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform" version="1.0"> @@ -31,7 +31,7 @@ --> <xsl:template name="user.footer.content"> <div class="footer"> - Copyright © 2006, Jack D. Unrue + Copyright © 2006-2007, Jack D. Unrue </div> </xsl:template> Modified: trunk/docs/manual/introduction.xml ============================================================================== --- trunk/docs/manual/introduction.xml (original) +++ trunk/docs/manual/introduction.xml Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@  <chapter id="introduction"> <title>Introduction</title> @@ -46,6 +46,7 @@ <title>Prerequisites</title> <bridgehead renderas="sect2">Supported Common Lisp Implementations</bridgehead> <itemizedlist mark="bullet" spacing="compact"> + <listitem>Allegro CL 8.0</listitem> <listitem>CLISP 2.40 or later</listitem> <listitem>LispWorks 4.4.6</listitem> <listitem> @@ -80,7 +81,7 @@ <listitem> <ulink url="http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf"/> <para role="normal"> - Note that ASDF is bundled with SBCL. + Note that ASDF is bundled with Allegro CL and SBCL. </para> </listitem> </varlistentry> Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Dec 17 00:59:28 2006 @@ -3,7 +3,7 @@ ;;;; ;;;; graphic-forms-tests.asd ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -56,7 +56,7 @@ (defsystem graphic-forms-tests :description "Graphic-Forms UI Toolkit Tests" - :version "0.7.0" + :version "0.8.0" :author "Jack D. Unrue" :licence "BSD" :components Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Dec 17 00:59:28 2006 @@ -3,7 +3,7 @@ ;;;; ;;;; graphic-forms-uitoolkit.asd ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -41,7 +41,7 @@ (defsystem graphic-forms-uitoolkit :description "Graphic-Forms UI Toolkit" - :version "0.7.0" + :version "0.8.0" :author "Jack D. Unrue" :licence "BSD" :depends-on ("cffi" "lw-compat" "closer-mop" "macro-utilities" "binary-data") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@ ;;;; ;;;; textedit-window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -159,7 +159,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.7"))) + (about-demo *textedit-win* image-path "About TextEdit" "TextEdit version 0.8"))) (defun textedit-startup () (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Dec 17 00:59:28 2006 @@ -1,7 +1,7 @@ ;;;; ;;;; unblocked-window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -87,7 +87,7 @@ (declare (ignore disp item)) (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) (image-path (merge-pathnames "about.bmp"))) - (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.7"))) + (about-demo *unblocked-win* image-path "About UnBlocked" "UnBlocked version 0.8"))) (defun unblocked-startup () (let ((menubar (gfw:defmenu ((:item "&File"

1 0