Newer
Older
(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)
(stream-replay stream region)
(force-output stream))
(defmethod read-frame-command ((frame standard-application-frame)
&key (stream *query-io*) ;frame-query-io?
;; should the rest of the *command-parser*
;; etc. variables be passed as keywords or bound?
)
(read-command (frame-command-table frame) :stream stream))
#+++ignore ;--- install this?
(defmethod execute-frame-command :around ((frame standard-application-frame) command)
(let ((top-level-process (slot-value frame 'top-level-process)))
(if (and top-level-process
(eq top-level-process (current-process)))
;; If we're in the process for the frame, just execute the command
(call-next-method)
;; Otherwise arrange to run the command in the frame's process
(execute-command-in-frame frame command))))
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command)))
(defmethod command-enabled (command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(or *assume-all-commands-enabled*
(and (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-enabled (frame-manager frame) frame command-name)))))
#+CLIM-1-compatibility
(progn
(define-compatibility-function (command-enabled-p command-enabled)
(command-name frame)
(command-enabled command-name frame))
(define-compatibility-function (enable-command (setf command-enabled))
(command-name frame)
(setf (command-enabled command-name frame) t))
(define-compatibility-function (disable-command (setf command-enabled))
(setf (command-enabled command-name frame) nil))
) ;#+CLIM-1-compatibility
;;--- There is the compiler bug with (eval-when (compile load eval) ...)
;;--- DEFMETHOD with a CALL-NEXT-METHOD. See to incorporate this patch.
(eval-when (#-Allegro compile load eval)
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
(define-condition synchronous-command-event ()
((command :initarg :command :reader synchronous-command-event-command))
(:report (lambda (condition stream)
(format stream "Command event condition signalled for ~S"
(synchronous-command-event-command condition)))))
) ;eval-when
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
(let* ((command (queue-pop (frame-command-queue frame))))
(or command
(handler-bind ((synchronous-command-event
#'(lambda (c)
(return-from read-frame-command
(synchronous-command-event-command c)))))
(call-next-method)))))
;; Actually this should be treated as a command event
(defclass presentation-event (event)
((value :initarg :value :reader presentation-event-value)
(sheet :initarg :sheet :reader event-sheet)
(frame :initarg :frame :reader event-frame)
(presentation-type :initarg :presentation-type :reader event-presentation-type)))
(defmethod handle-event (sheet (event presentation-event))
(process-command-event sheet event))
(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)
(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+))
(progn
(when (and *input-buffer-empty*
(eq *application-frame* (event-frame event)))
(signal 'synchronous-command-event
:command command))
;; Perhaps if this results directly from a user action then either
;; we should do it right away, ie. loose the input buffer or beep if
;; it has to be deffered,
(queue-frame-command (event-frame event) (presentation-event-value event))))))
(defun queue-frame-command (frame command)
(queue-push (frame-command-queue frame) command))
(defmethod execute-command-in-frame ((frame standard-application-frame) command)
(distribute-event
(port frame)
(allocate-event 'presentation-event
:frame frame
:sheet (frame-top-level-sheet frame)
:value command)))
;;; 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))
(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*))
(when (and *click-outside-menu-handler*
(output-recording-stream-p window)
(funcall *click-outside-menu-handler*))
(when highlighted-presentation
;; Unhighlight on the way out.
;; But only unhighlight the window that the click is from.
(unhighlight-highlighted-presentation window nil))
(throw-highlighted-presentation
(or (and (output-recording-stream-p window)
(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)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defmethod frame-standard-output ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane)))
(defmethod frame-standard-input ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame)))
(defmethod frame-error-output ((frame standard-application-frame))
(frame-standard-output frame))
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
;;--- 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))))
(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))
(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))
(defvar *pointer-documentation-interval*
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame) presentation input-context window x y stream)
(frame-manager-display-pointer-documentation
(frame-manager frame) frame presentation input-context window x y stream))
(defmethod frame-manager-display-pointer-documentation
((framem standard-frame-manager)
frame presentation input-context window x y stream)
(when stream
;; The documentation should never say anything if we're not over a presentation
(when (null presentation)
;; 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))
(setq *last-pointer-documentation-time* time))
(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)))))))
(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)
(let* ((*print-length* 3)
(*print-level* 2)
(*print-circle* nil)
(*print-array* nil)
(*print-readably* nil)
(*print-pretty* nil))
(flet ((document-translator (translator presentation context-type
button-name separator)
;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
(let ((bit #o20)
(shift-name '("h-" "s-" "m-" "c-" "sh-")))
(unless (zerop (logand bit modifier-state))
(write-string (car shift-name) stream))
(pop shift-name)
(setq bit (the fixnum (ash bit -1)))))
(write-string button-name stream)
(document-presentation-translator translator presentation context-type
frame nil window x y
:stream stream
:documentation-type :pointer)
(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...
(let ((button-name (cond ((and (eq left middle)
(eq left right))
(document-translator left left-presentation left-context
button-name (if (or middle right) "; " "."))))
(document-translator middle middle-presentation middle-context
button-name (if right "; " "."))))
(document-translator right right-presentation right-context
"R: " "."))
;; 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 (or (null ,button-translator)
(> (presentation-translator-priority ,translator)
(presentation-translator-priority ,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-context ,context-type)))))
(do ((presentation presentation
(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)))))))
(values left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)))