Newer
Older
;; Sizes an application frame based on the size of the contents of the
(defun size-frame-from-contents (stream
&key width height
(right-margin 10) (bottom-margin 10)
(size-setter #'window-set-inside-size))
(with-slots (output-record) stream
(with-bounding-rectangle* (left top right bottom) output-record
(let* ((graft (or (graft stream)
(find-graft))) ;--- is this right?
(gw (bounding-rectangle-width (sheet-region graft)))
(gh (bounding-rectangle-height (sheet-region graft)))
;;--- Does this need to account for the size of window decorations?
(width (min gw (+ (or width (- right left)) right-margin)))
(height (min gh (+ (or height (- bottom top)) bottom-margin))))
;; The size-setter will typically resize the entire frame
(funcall size-setter stream width height)
(window-set-viewport-position stream left top)))))
;; Moves the sheet to the specified position, taking care not to move
;; it outside of the graft. It's safest to use this on a top-level sheet.
(defun position-sheet-carefully (sheet x y)
(multiple-value-bind (width height) (bounding-rectangle-size sheet)
(multiple-value-bind (graft-width graft-height)
(bounding-rectangle-size (or (graft sheet) (find-graft)))
(top y)
(right (+ left width))
(bottom (+ top height)))
(when (> right graft-width)
(setq left (- graft-width width)))
(when (> bottom graft-height)
(setq top (- graft-height height)))
(port-move-frame (port sheet) (pane-frame sheet)
(max 0 left) (max 0 top))))))
(defmethod port-move-frame ((port basic-port) frame x y)
(move-sheet (frame-top-level-sheet frame) x y))
;; Moves the sheet to be near where the pointer is. It's safest to use this
;; on a top-level sheet.
(defun position-sheet-near-pointer (sheet &optional x y)
(unless (and x y)
(multiple-value-setq (x y)
(pointer-position (port-pointer (port sheet)))))
(defun display-title (frame stream &key max-width max-height)
(declare (ignore max-width max-height))
(with-slots (display-string) stream
(let ((title display-string))
(when (and (stringp title)
(not (string-equal title (frame-pretty-name frame))))
;; On some hosts this will update the title bar
(setf (frame-pretty-name frame) title))
(window-inside-size stream)
(draw-text* stream (or title (frame-pretty-name frame))
(/ width 2) (/ height 2)
:align-x :center :align-y :center)))))
(defun title-capitalize (string)
(let ((new-string (substitute #\Space #\- string)))
(when (eq new-string string)
(setq new-string (copy-seq new-string)))
(nstring-capitalize new-string)))
&key command-table max-width max-height &allow-other-keys)
(ignore max-width max-height))
(eq command-table t))
(apply #'display-command-menu-1 stream command-table keys)
(apply #'display-command-table-menu command-table stream keys))))
;; Split out to avoid consing unnecessary closure environments.
(defun display-command-menu-1 (stream command-table &rest keys)
(declare (dynamic-extent keys))
(updating-output (stream :unique-id stream
:cache-value (slot-value command-table 'menu-tick))
(apply #'display-command-table-menu command-table stream keys)))
(defmethod find-pane-named ((frame standard-application-frame) pane-name &optional (errorp t))
(with-slots (all-panes) frame
(cond ((second (assoc pane-name all-panes)))
(errorp (error "There is no pane named ~S in frame ~S" pane-name frame)))))
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
(with-slots (all-panes) frame
(let ((pane (assoc pane-name all-panes)))
(when pane
(map-over-sheets #'(lambda (sheet)
(when (typep sheet 'clim-stream-pane)
(return-from get-frame-pane sheet)))
(second pane)))
(error "There is no CLIM stream pane named ~S in frame ~S" pane-name frame)))))
#+ignore
(defmethod pane-name ((pane basic-pane))
(let ((frame (pane-frame pane)))
(and frame
(dolist (name-and-pane (slot-value frame 'all-panes))
(destructuring-bind (name apane) name-and-pane
(when (sheet-ancestor-p pane apane)
(return name)))))))
(defmethod frame-current-panes ((frame standard-application-frame))
(let ((panes nil)
(top (frame-panes frame)))
(when (panep sheet)
(push sheet panes)))
top))
(defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p)
;; First display all the :accept-values panes, then display the rest.
;; We do this to ensure that all side-effects from :accept-values panes
;; have taken place.
#+moved ;; pr Aug97
(when *frame-layout-changing-p* (setq force-p t))
(when (typep sheet 'accept-values-pane)
(redisplay-frame-pane frame sheet :force-p force-p)))
(frame-top-level-sheet frame))
(when (and (typep sheet 'clim-stream-pane)
(not (typep sheet 'accept-values-pane)))
(redisplay-frame-pane frame sheet :force-p force-p)))
(frame-top-level-sheet frame))
;; Once we've redisplayed everything, the layout is done changing
(setq *frame-layout-changing-p* nil))
(defmethod redisplay-frame-pane ((frame standard-application-frame) pane &key force-p)
(ir (slot-value pane 'incremental-redisplay-p))
(redisplay-p (if (listp ir) (first ir) ir))
(check-overlapping (or (atom ir) ;default is T
(getf (rest ir) :check-overlapping
t)))
needs-display
clear)
(with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
(with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
#-moved ;; pr Aug97
(when *frame-layout-changing-p*
(setq force-p t))
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
(unless *sizing-application-frame*
(unless (member pane (slot-value frame 'initialized-panes))
(setq force-p t)
(push pane (slot-value frame 'initialized-panes))))
(return
(cond (display-function
(cond
;; display function with incremental redisplay
(redisplay-p
(let ((redisplay-record
(let ((history (stream-output-history pane)))
(when history
#+compulsive-redisplay
(when (> (output-record-count history :fastp t) 1)
(cerror "Clear the output history and proceed"
"There is more than one element in this redisplay pane")
(window-clear pane))
(unless (zerop (output-record-count history :fastp t))
(output-record-element history 0))))))
(cond ((or (null redisplay-record) force-p)
(when force-p
(window-clear pane))
(invoke-pane-redisplay-function frame pane))
(t
(redisplay redisplay-record pane
:check-overlapping check-overlapping)))))
;; display function without incremental redisplay
((or force-p (progn (multiple-value-setq (needs-display clear)
(pane-needs-redisplay pane))
needs-display))
(when (or force-p clear)
(window-clear pane))
(invoke-pane-display-function frame pane)))
(force-output pane))
;; no display function
(force-p
;; If refilling from scratch, give the application a chance
;; to draw stuff
(frame-replay frame pane))
;; Otherwise do nothing, the bits will still be on display
;; and will be refreshed properly if there's a damage event.
)))))))
(defun invoke-pane-redisplay-function (frame pane &rest args)
(declare (dynamic-extent args))
(updating-output (pane)
(apply #'invoke-pane-display-function frame pane args)))
(defun invoke-pane-display-function (frame pane &rest args)
(declare (dynamic-extent args))
(let* ((df (pane-display-function pane))
(display-args (if (listp df) (rest df) nil))
(display-function (if (listp df) (first df) df)))
;; Cons as little as possible...
(cond ((and (null args) (null display-args))
(funcall display-function frame pane))
((null display-args)
(apply display-function frame pane args))
((null args)
(apply display-function frame pane display-args))
(t
(apply display-function frame pane (append args display-args))))))
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
(when (null region)
(setq region (or (pane-viewport-region stream) (sheet-region stream))))
(defmethod read-frame-command ((frame standard-application-frame)
&key (stream *standard-input*) ;--- FRAME-STANDARD-INPUT?
;; should the rest of the *command-parser*
;; etc. variables be passed as keywords or bound?
)
(defmacro with-menu-disabled (frame &body body)
#-mswindows (declare (ignore frame))
#-mswindows `(progn ,@body)
`(unwind-protect
(progn
(disable-all-menu-items ,frame)
,@body)
(re-enable-menu-items ,frame)))
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command))
#+ignore ;; from jeff on 4/8/99
(with-menu-disabled frame
(apply (command-name command) (command-arguments command))))
(defmethod execute-frame-command :around ((frame standard-application-frame)
command)
activity)
(if (or (and top-level-process
(eq top-level-process (current-process)))
(and (typep frame 'activity-frame)
(setq activity (frame-activity frame))
(eq (slot-value activity 'top-level-process)
(current-process))))
;; If we're in the process for the frame, just execute the command
;; Or the process for the frames activity
(call-next-method)
;; Otherwise arrange to run the command in the frame's process
(execute-command-in-frame frame command :queuep t))))
cer
committed
(defmethod command-defined-p ((frame standard-application-frame) command)
(or (not (symbolp command))
(fboundp command)))
(defmethod command-enabled (command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(or *assume-all-commands-enabled*
(and (command-defined-p frame command-name)
(not (member command-name disabled-commands))
(command-accessible-in-command-table-p
command-name (frame-command-table frame))))))
(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(cond (enabled
(setf disabled-commands (delete command-name disabled-commands))
(note-command-enabled (frame-manager frame) frame command-name))
(t
(push command-name disabled-commands)
(note-command-disabled (frame-manager frame) frame command-name)))))
((command :initarg :command :reader synchronous-command-event-command)
(echo :initarg :echo :reader synchronous-command-event-echo-p))
(format stream "Command event condition signalled for ~S"
(synchronous-command-event-command condition)))))
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
(initialize-for-command-reader (frame-manager frame) frame)
(flet ((maybe-echo-command (command)
(let ((ptype `(command :command-table ,(frame-command-table frame))))
(when (eq *command-parser* #'command-line-command-parser)
(present command ptype :stream *standard-input*
:allow-sensitive-inferiors nil))
(when (frame-maintain-presentation-histories frame)
(push-history-element (presentation-type-history ptype)
(make-presentation-history-element
:object command :type ptype))))))
(let* ((command-and-options (queue-pop (frame-command-queue frame))))
(if command-and-options
(destructuring-bind (command &key echo) command-and-options
(when echo (maybe-echo-command command))
command)
(handler-bind ((synchronous-command-event
#'(lambda (c)
(let ((command (synchronous-command-event-command c)))
(when (synchronous-command-event-echo-p c)
(maybe-echo-command command))
(return-from read-frame-command command)))))
(let ((*reading-frame-command* t))
(call-next-method)))))))
(defmethod initialize-for-command-reader ((frame-manager t) (frame t)) nil)
((value :initarg :value :reader presentation-event-value)
(sheet :initarg :sheet :reader event-sheet)
(frame :initarg :frame :reader event-frame)
(queuep :initarg :queuep :initform nil)
(echo :initarg :echo :initform t :reader presentation-event-echo-p)
(presentation-type :initarg :presentation-type :reader event-presentation-type))
(defmethod handle-event (sheet (event presentation-event))
(process-command-event sheet event))
;;;#+(or aclpc acl86win32)
;;;(eval-when (compile load eval)
;;; ;;mm: 11Jan95 - this is defined later in ???
;;; (unless (ignore-errors (find-class 'activity-frame))
;;; (defclass activity-frame () ())))
(defun process-command-event (sheet event)
;;--- This code is as bad as I feel.
(let ((command (presentation-event-value event)))
(if (partial-command-p command)
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
(throw-highlighted-presentation
(make-instance 'standard-presentation
:object command
:type (event-presentation-type event))
*input-context*
(allocate-event 'pointer-button-press-event
:sheet sheet
:x 0 :y 0
:modifier-state 0
:button +pointer-left-button+))
(let ((frame (event-frame event))
(activity nil))
(when (and *input-buffer-empty*
(or (eq *application-frame* frame)
(and (typep frame 'activity-frame)
(eq (frame-activity frame) *activity*)
(setq activity *activity*))))
(signal 'synchronous-command-event
:echo (presentation-event-echo-p event)
:command command))
;; Perhaps if this results directly from a user action then either
;; we should do it right away, ie. lose the input buffer or beep if
;; it has to be deferred,
(if (slot-value event 'queuep)
(queue-frame-command (if activity (activity-active-frame activity) frame)
(presentation-event-value event)
(presentation-event-echo-p event))
(beep sheet))))))
(defun command-callback (function &rest arguments)
(cons #'(lambda (widget &rest args) (apply #'command-callback-1 function widget args)) arguments))
(defun command-callback-1 (function sheet &rest arguments)
(let ((frame (pane-frame sheet)))
(process-command-event
sheet
(make-instance 'presentation-event
:frame frame
:value (list* function sheet arguments)
:presentation-type `(command :command-table ,(frame-command-table frame))))))
(defun queue-frame-command (frame command &optional (echo t))
(queue-push (frame-command-queue frame) (list command :echo echo)))
(defmethod execute-command-in-frame
((frame standard-application-frame) command &rest initargs)
(apply #'allocate-event 'presentation-event
:frame frame
:sheet (frame-top-level-sheet frame)
:value command
initargs)))
(defun make-command-timer (frame command
&key (delay 0) interval
(command-table (frame-command-table frame)))
(declare (ignore timer))
(execute-command-in-frame
frame command
:echo nil
:queuep t
:presentation-type `(command :command-table ,command-table))))
:function #'queue-command-event
:delay delay :interval interval)))
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE. Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
((frame standard-application-frame) input-context stream x y &key event)
(find-innermost-applicable-presentation
input-context stream x y
:frame frame
:modifier-state (window-modifier-state stream) :event event))
((frame standard-application-frame) stream button-press-event)
(declare (ignore stream))
(let* ((window (event-sheet button-press-event))
(x (pointer-event-x button-press-event))
(y (pointer-event-y button-press-event))
(highlighted-presentation (highlighted-presentation window nil))
(input-context *input-context*))
(output-recording-stream-p window)
(not (region-contains-position-p (stream-output-history window) x y)))
(funcall *click-outside-menu-handler*))
(when highlighted-presentation
;; Unhighlight on the way out.
;; But only unhighlight the window that the click is from.
(throw-highlighted-presentation
(frame-find-innermost-applicable-presentation
frame input-context window x y
:event button-press-event))
*null-presentation*)
input-context
button-press-event)))
(defun find-frame-pane-of-type (frame type)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(if (not (member '*standard-output* (slot-value frame
'non-frame-stream-names)))
(or
(find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane))
nil))
(if (not (member '*standard-input* (slot-value frame
'non-frame-stream-names)))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame))))
(if (not (member '*query-io* (slot-value frame
'non-frame-stream-names)))
(or (frame-standard-input frame)
(frame-standard-output frame))
nil))
(if (not (member '*error-output* (slot-value frame
'non-frame-stream-names)))
(frame-standard-output frame)
nil))
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
(if (not (member '*pointer-documentation-output*
(slot-value frame 'non-frame-stream-names)))
(find-frame-pane-of-type frame 'pointer-documentation-pane)
nil))
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories. Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(defmethod notify-user (frame message &rest options)
(declare (dynamic-extent options))
(when frame
(setf (getf options :frame) frame))
(apply #'frame-manager-notify-user
(if frame (frame-manager frame) (find-frame-manager)) message options))
(defmethod select-file (frame &rest options)
(declare (dynamic-extent options))
(when frame
(setf (getf options :frame) frame))
(apply #'frame-manager-select-file
(if frame (frame-manager frame) (find-frame-manager)) options))
#-makes-things-fail 0
#+makes-things-fail
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(setq *pointer-documentation-interval* 0)
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame)
presentation input-context window x y stream)
(let ((frame-manager (frame-manager frame)))
#+(or aclpc acl86win32)
(unless frame-manager
(setq frame (pane-frame window))
(setq frame-manager (or (frame-manager frame)(find-frame-manager))))
(frame-manager-display-pointer-documentation
frame-manager frame presentation input-context window x y stream)))
(defmethod frame-manager-pointer-documentation-stream
((framem standard-frame-manager) frame stream)
(defmethod frame-manager-display-pointer-documentation
((framem standard-frame-manager)
frame presentation input-context window x y stream)
(let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
(when presentation
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(force-output stream)))))))
(defmethod frame-manager-display-pointer-documentation :around
((framem standard-frame-manager)
frame presentation input-context window x y stream)
(declare (ignore x y input-context))
(when (frame-manager-pointer-documentation-stream framem frame stream)
;; The documentation should never say anything if we're not over a presentation
(frame-manager-display-pointer-documentation-string
framem frame stream nil))
;; Cheap test to not do this work too often
(let ((old-modifier-state *last-pointer-documentation-modifier-state*)
(modifier-state (window-modifier-state window))
(last-time *last-pointer-documentation-time*)
(time (get-internal-real-time)))
(setq *last-pointer-documentation-modifier-state* modifier-state)
(when (and (< time (+ last-time *pointer-documentation-interval*))
(= modifier-state old-modifier-state))
(defmethod frame-manager-display-pointer-documentation-string
((framem standard-frame-manager) frame stream string)
(let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
(when stream
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when string
(write-string string stream))))))))
(defmethod frame-pointer-button-documentation
((frame standard-application-frame) button)
(case button
(:left "L")
(:middle "M")
(:right "R")))
(defmethod frame-modifier-key-documentation
((frame standard-application-frame) modifier)
(case modifier
(:shift "sh")
(:control "c")
(:meta "m")
(:super "s")
(:hyper "h")
(:double "dbl")))
(defun frame-document-highlighted-presentation-1
(frame presentation input-context window x y stream)
(let ((modifier-state (window-modifier-state window)))
(multiple-value-bind (left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)
(find-applicable-translators-for-documentation presentation
input-context
frame window x y
modifier-state)
(*print-level* 2)
(*print-circle* nil)
(*print-array* nil)
(*print-readably* nil)
(*print-pretty* nil))
(flet ((document-translator (translator presentation context-type
button-names separator)
;; Assumes 6 modifier keys and the reverse ordering of
(let ((bit #b100000)
(shift-name '(:double :hyper :super :meta :control
:shift)))
(declare (type fixnum bit))
(repeat 6 ;length of shift-name
(unless (zerop (logand bit modifier-state))
(write-string
(frame-modifier-key-documentation frame
stream)
(write-string "-" stream))
(pop shift-name)
(setq bit (the fixnum (ash bit -1)))))
(write-string
(frame-pointer-button-documentation frame (car
button-names))
stream)
(dolist (button-name (cdr button-names))
(write-string "," stream)
(write-string
(frame-pointer-button-documentation frame button-name)
stream))
(write-string ": " stream)
(document-presentation-translator translator presentation
context-type
frame nil window x y
:stream stream
(write-string separator stream)))
(declare (dynamic-extent #'document-translator))
;;--- The button names should be hard-wired in. Consider 1-button
;;--- Macs and 2-button PCs...
(when left
(let ((button-name (cond ((and (eq left middle)
(eq left right))
(setq middle nil
right nil)
'(:left :middle :right))
((eq left middle)
(setq middle nil)
'(:left :middle))
(t '(:left)))))
(document-translator left left-presentation left-context
button-name (if (or middle right) "; "
"."))))
(when middle
(let ((button-name (cond ((eq middle right)
(setq right nil)
(list :middle :right))
(t '(:middle)))))
(document-translator middle middle-presentation middle-context
button-name (if right "; " "."))))
(when right
(document-translator right right-presentation right-context
'(:right) "."))
;; Return non-NIL if any pointer documentation was produced
(or left middle right))))))
;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
(presentation input-context frame window x y modifier-state)
;; Assume a maximum of three pointer buttons
(let ((left nil) (left-presentation nil) (left-context nil)
(middle nil) (middle-presentation nil) (middle-context nil)
(right nil) (right-presentation nil) (right-context nil))
(macrolet ((match (translator presentation context-type button)
(let* ((symbol (symbol-name button))
(button-translator (intern symbol))
(button-presentation (fintern "~A-~A" symbol 'presentation))
(button-context (fintern "~A-~A" symbol 'context)))
`(when (and (null ,button-translator)
(button-and-modifier-state-matches-gesture-name-p
(button-index ,button) modifier-state
(presentation-translator-gesture-name ,translator)))
(setq ,button-translator ,translator
,button-presentation ,presentation
,button-context ,context-type)))))
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
(parent-presentation-with-shared-box presentation window)))
((null presentation))
(let ((from-type (presentation-type presentation)))
(dolist (context input-context)
(let ((context-type (pop context))) ;input-context-type = first
(let ((translators (find-presentation-translators
from-type context-type (frame-command-table frame))))
(when translators
(dolist (translator translators)
(when (test-presentation-translator translator
presentation context-type
frame window x y
:modifier-state modifier-state)
(match translator presentation context-type :left)
(match translator presentation context-type :middle)
(match translator presentation context-type :right)))))
(when (and (or left middle right)
*presentation-menu-translator*
(test-presentation-translator *presentation-menu-translator*
presentation context-type
frame window x y
:modifier-state modifier-state))
(match *presentation-menu-translator* presentation context-type :left)
(match *presentation-menu-translator* presentation context-type :middle)
(match *presentation-menu-translator* presentation context-type :right)))))))
middle middle-presentation middle-context
right right-presentation right-context)))