[graphic-forms-cvs] r260 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Wed Sep 13 23:44:06 2006
New Revision: 260

Modified:
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
added some missing scrollbar-related methods to window

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Wed Sep 13 23:44:06 2006
@@ -192,7 +192,7 @@
 (defgeneric header-visible-p (self)
   (:documentation "Returns T if the object's header is visible; nil otherwise."))
 
-(defgeneric horizontal-scrollbar (self)
+(defgeneric horizontal-scrollbar-p (self)
   (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise."))
 
 (defgeneric iconify (self flag)
@@ -432,7 +432,7 @@
 (defgeneric update-native-style (self flags)
   (:documentation "Modifies self's native style flags and refreshes self's visual appearance."))
 
-(defgeneric vertical-scrollbar (self)
+(defgeneric vertical-scrollbar-p (self)
   (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise."))
 
 (defgeneric visible-item-count (self)

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Wed Sep 13 23:44:06 2006
@@ -206,9 +206,21 @@
   (if flag
     (redraw self)))
 
+(defmethod enable-scrollbars :before ((self widget) horizontal vertical)
+  (declare (ignore horizontal vertical))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod enabled-p ((self widget))
   (/= (gfs::is-window-enabled (gfs:handle self)) 0))
 
+(defmethod horizontal-scrollbar-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod horizontal-scrollbar-p ((self widget))
+  nil)
+
 (defmethod image :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
@@ -430,6 +442,13 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
+(defmethod vertical-scrollbar-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod vertical-scrollbar-p ((self widget))
+  nil)
+
 (defmethod visible-p :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Wed Sep 13 23:44:06 2006
@@ -193,12 +193,22 @@
     (let ((sz (client-size self)))
       (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
 
-(defmethod event-resize ((d event-dispatcher) (self window) size type)
+(defmethod event-resize ((disp event-dispatcher) (self window) size type)
   (declare (ignore 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)))))
 
+(defmethod enable-scrollbars ((self window) horizontal vertical)
+  (let ((bits (get-native-style self)))
+    (if horizontal
+      (setf bits (logior bits gfs::+ws-hscroll+))
+      (setf bits (logand bits (lognot gfs::+ws-hscroll+))))
+    (if vertical
+      (setf bits (logior bits gfs::+ws-vscroll+))
+      (setf bits (logand bits (lognot gfs::+ws-vscroll+))))
+    (update-native-style self bits)))
+
 (defmethod focus-p :before ((self window))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
@@ -214,6 +224,9 @@
 (defmethod give-focus ((self window))
   (gfs::set-focus (gfs:handle self)))
 
+(defmethod horizontal-scrollbar-p ((self top-level))
+  (test-native-style self gfs::+ws-hscroll+))
+
 (defmethod image ((self window))
   (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0))
         (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0))
@@ -334,6 +347,9 @@
                                                                   gfs::+swp-nozorder+)))
   flags)
 
+(defmethod vertical-scrollbar-p ((self top-level))
+  (test-native-style self gfs::+ws-vscroll+))
+
 (defmethod window->display :before ((self window))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))