Index: dialog.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/dialog.lisp,v retrieving revision 1.29 diff -u -r1.29 dialog.lisp --- dialog.lisp 1 Feb 2008 00:22:04 -0000 1.29 +++ dialog.lisp 7 May 2008 21:57:53 -0000 @@ -109,7 +109,7 @@ when conditions will be signalled from calls to ACCEPT."))) (defmethod stream-default-view ((stream accepting-values-stream)) - +textual-dialog-view+) + (frame-manager-dialog-view (frame-manager *application-frame*))) (define-condition av-exit (condition) ()) @@ -181,6 +181,13 @@ ,true-form ,return-form)))))) +(defgeneric finally-finalize-query-record (record) + (:documentation "Clean up output record after the final run of an + accepting-values body")) + +(defmethod finally-finalize-query-record (record) + nil) + (defun invoke-accepting-values (stream body &key own-window exit-boxes @@ -241,13 +248,17 @@ (setf (last-pass *accepting-values-stream*) t) (redisplay arecord stream))) (dolist (query (queries *accepting-values-stream*)) - (finalize (editing-stream (record query)) nil)) + (finally-finalize-query-record (record query))) (erase-output-record arecord stream) (setf (stream-cursor-position stream) (values cx cy))))))) (defgeneric display-exit-boxes (frame stream view)) +;;; Hack for now +(defmethod display-exit-boxes (frame stream (view gadget-dialog-view)) + (display-exit-boxes frame stream +textual-dialog-view+)) + (defmethod display-exit-boxes (frame stream (view textual-dialog-view)) (declare (ignore frame)) (updating-output (stream :unique-id 'buttons :cache-value t) @@ -423,6 +434,9 @@ :documentation "A copy of the stream buffer before accept is called. Used to determine if any editing has been done by user"))) +(defmethod finally-finalize-query-record ((record av-text-record)) + (finalize (editing-stream record) nil)) + (defparameter *no-default-cache-value* (cons nil nil)) ;;; Hack until more views / dialog gadgets are defined. @@ -430,18 +444,33 @@ (define-default-presentation-method accept-present-default (type stream (view text-field-view) default default-supplied-p present-p query-identifier) - (if (width view) - (multiple-value-bind (cx cy) - (stream-cursor-position stream) - (declare (ignore cy)) - (letf (((stream-text-margin stream) (+ cx (width view)))) - (funcall-presentation-generic-function accept-present-default - type - stream - +textual-dialog-view+ - default default-supplied-p - present-p - query-identifier))))) + (multiple-value-bind (cx cy) + (stream-cursor-position stream) + (declare (ignore cy)) + (letf (((stream-text-margin stream) (+ cx (or (width view) 0)))) + (funcall-presentation-generic-function accept-present-default + type + stream + +textual-dialog-view+ + default default-supplied-p + present-p + query-identifier)))) + +(define-presentation-method accept ((type string) stream (view text-field-view) + &key (default nil defaultp) + (default-type type)) + (apply-presentation-generic-function + accept + (nconc (list type stream +textual-view+ :default-type default-type) + (if defaultp (list :default default))))) + +(define-default-presentation-method accept + (type stream (view gadget-dialog-view) + &key (default nil defaultp) (default-type type)) + (apply-presentation-generic-function + accept + (nconc (list type stream +textual-view+ :default-type default-type) + (if defaultp (list :default default))))) (define-default-presentation-method accept-present-default (type stream (view textual-dialog-view) default default-supplied-p Index: package.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v retrieving revision 1.69 diff -u -r1.69 package.lisp --- package.lisp 1 May 2008 06:48:23 -0000 1.69 +++ package.lisp 7 May 2008 21:57:54 -0000 @@ -385,6 +385,7 @@ #:+background-ink+ ;constant #:+black+ ;constant #:+blue+ ;constant + #:+check-box-view+ ;constant #:+control-key+ ;constant #:+cyan+ ;constant #:+everywhere+ ;constant @@ -397,19 +398,27 @@ #:+green+ ;constant #:+hyper-key+ ;constant #:+identity-transformation+ ;constant + #:+list-pane-view+ ;constant #:+magenta+ ;constant #:+meta-key+ ;constant #:+nowhere+ ;constant + #:+option-pane-view+ ;constant #:+pointer-documentation-view+ ;constant #:+pointer-left-button+ ;constant #:+pointer-middle-button+ ;constant #:+pointer-right-button+ ;constant + #:+push-button-view+ ;constant #:+red+ ;constant + #:+radio-box-view+ ;constant #:+shift-key+ ;constant + #:+slider-view+ ;constant #:+super-key+ ;constant + #:+text-editor-view+ ;constant + #:+text-field-view+ ;constant #:+textual-dialog-view+ ;constant #:+textual-menu-view+ ;constant #:+textual-view+ ;constant + #:+toggle-button-view+ ;constant #:+transparent-ink+ ;constant #:+white+ ;constant #:+yellow+ ;constant @@ -496,6 +505,7 @@ #:check-box-current-selection ;generic function #:check-box-pane ;class #:check-box-selections ;generic function + #:check-box-view ;class #:child-containing-position ;generic function #:children-overlapping-rectangle* ;generic function #:children-overlapping-region ;generic function @@ -868,6 +878,7 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class + #:list-pane-view ;class #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1034,6 +1045,7 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class + #:option-pane-view ;class #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1158,6 +1170,7 @@ #:push-button ;class #:push-button-pane ;class #:push-button-show-as-default ;generic function + #:push-button-view ;class #:queue-event ;generic function #:queue-repaint ;generic function #:queue-rescan ;generic function @@ -1165,6 +1178,7 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function + #:radio-box-view ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1303,6 +1317,7 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class + #:slider-view ;class #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1454,8 +1469,10 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class + #:text-editor-view ;class #:text-field ;class #:text-field-pane ;class + #:text-field-view ;class #:text-size ;generic function #:text-style ;protocol class #:text-style-ascent ;generic function @@ -1478,6 +1495,7 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class + #:toggle-button-view ;class #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function Index: protocol-classes.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/protocol-classes.lisp,v retrieving revision 1.4 diff -u -r1.4 protocol-classes.lisp --- protocol-classes.lisp 29 Oct 2006 12:56:13 -0000 1.4 +++ protocol-classes.lisp 7 May 2008 21:57:55 -0000 @@ -191,7 +191,9 @@ ((port :initarg :port :reader frame-manager-port) (frames :initform nil - :reader frame-manager-frames))) + :reader frame-manager-frames) + (dialog-view :initform +textual-dialog-view+ + :accessor frame-manager-dialog-view))) ;;; 30.3 Basic Gadget Classes ;;; XXX Slots definitions should be banished. Index: views.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/views.lisp,v retrieving revision 1.8 diff -u -r1.8 views.lisp --- views.lisp 12 Jan 2008 11:04:05 -0000 1.8 +++ views.lisp 7 May 2008 21:57:55 -0000 @@ -31,7 +31,7 @@ ()) (defclass gadget-view (view) - ()) + ((gadget-initargs :initform nil :reader view-gadget-initargs))) (defclass gadget-menu-view (gadget-view) ()) @@ -91,6 +91,8 @@ (defparameter +radio-box-view+ (make-instance 'radio-box-view)) +(defparameter +check-box-view+ (make-instance 'check-box-view)) + (defparameter +slider-view+ (make-instance 'slider-view)) (defparameter +text-field-view+ (make-instance 'text-field-view)) @@ -105,3 +107,6 @@ (declare (ignore stream)) +textual-view+) +(defmethod initialize-instance :after ((view gadget-view) &rest initargs + &key &allow-other-keys) + (setf (slot-value view 'gadget-initargs) initargs)) \ No newline at end of file