Newer
Older
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; Frame protocol:
;; adopt-frame
;; enable-frame
;; generate-panes
;; layout-frame
;; make-application-frame
(defclass frame-manager ()
((port :reader port :initarg :port)))
(defclass application-frame ()
((port :reader port :initarg :port)
(graft :reader graft :initarg :graft)
(frame-manager :reader frame-manager :initarg :frame-manager)
(panes :initarg :panes :accessor frame-panes)
(top-level-sheet :accessor frame-top-level-sheet :initform nil)
(shell :accessor frame-shell)
(state :initform :disowned :accessor frame-state
:type (member :disowned :disabled :enabled :shrunk))
(command-table :initarg :command-table
:initform (find-command-table 'user-command-table)
:accessor frame-command-table)
(top-level :initarg :top-level :accessor frame-top-level)
(current-layout :initarg :default-layout :reader frame-current-layout)
(all-panes :initform nil)
(pane-constructors :initarg :pane-constructors)
)
(:default-initargs
:top-level 'default-frame-top-level
:frame-manager (find-frame-manager)
:port (find-port)
:graft (find-graft)))
(defmethod frame-name ((frame application-frame))
(format nil "~A" (type-of frame)))
(defmethod frame-pretty-name ((frame application-frame))
(frame-name frame))
(defvar *frame-managers* nil)
(defun find-frame-manager (&rest options)
(let ((port (apply #'find-port options)))
(second (or (assoc port *frame-managers*)
(car
(push (list port (make-frame-manager port))
*frame-managers*))))))
(defmethod make-frame-manager (port)
(make-instance 'frame-manager :port port))
(defmethod initialize-instance :after ((frame application-frame) &rest
x &key frame-manager)
(adopt-frame frame-manager frame))
(defmethod adopt-frame ((framem frame-manager) (frame application-frame))
(generate-panes frame framem))
(defmethod generate-panes ((frame application-frame) (framem
frame-manager))
(setf (frame-panes frame) nil))
(defmacro define-application-frame (name superclasses slots &rest options)
(unless superclasses (setq superclasses '(application-frame)))
(let ((pane (second (assoc :pane options)))
(panes (cdr (assoc :panes options)))
(layout (cdr (assoc :layout options)))
(command-definer (second (or (assoc :command-definer options)
'(t t))))
(command-table (second (or (assoc :command-table options)
'(t t))))
(top-level (assoc :top-level options)))
(when (and pane panes)
(error "Cannot use :pane and :panes together"))
(when (or (and panes (null layout))
(and layout (null panes)))
(error ":layout and :panes must be used together"))
(cond ((null command-table))
((symbolp command-table)
(setq command-table (list command-table))))
(when (eq (car command-table) t)
(setq command-table (list* name (rest command-table))))
`(progn
(defclass ,name
,superclasses
,slots
(:default-initargs
,@(and layout `(:default-layout ',(car (car layout))))
,@(and top-level `(:top-level ',(second top-level)))
,@(and panes `(:pane-constructors
,(compute-pane-constructor-code panes)))
,@(and command-table
`(:command-table (clim-internals::find-command-table ',(car command-table))))))
,@(when command-definer
(compute-command-definer-code name command-table))
(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
(multiple-value-bind (command-name command-options)
(decode-name-and-options name-and-options command-table-name)
`(define-command (,command-name :command-table ,command-table-name ,@command-options)
,arguments
,@body)))
(defun compute-command-definer-code (name command-table)
(let ((command-definer (fintern "~A~A~A" `define- name '-command)))
`((defmacro ,command-definer (command-name arguments &body body)
`(define-frame-command ,',(first command-table)
,command-name ,arguments ,@body)))))
(defun compute-generate-panes-code (name code panes layouts)
(if panes
(compute-complex-generate-panes-code name panes layouts)
(compute-simple-generate-panes-code name code)))
(defun compute-simple-generate-panes-code (name code)
(and code
(let ((f (gensym))
(fm (gensym)))
`((defmethod generate-panes ((,f ,name) (,fm frame-manager))
(let ((*application-frame* ,f))
(setf (frame-panes ,f)
(frame-wrapper
,f ,fm
(with-look-and-feel-realization
(,fm ,f)
,code)))))))))
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
(defun compute-complex-generate-panes-code (name panes layouts)
(let ((f (gensym))
(fm (gensym)))
`((defmethod generate-panes ((,f ,name) (,fm frame-manager))
(symbol-macrolet
,(mapcar #'(lambda (pane-spec)
(destructuring-bind
(name code) pane-spec
`(,name (find-or-make-pane-named ,f
',name))))
panes)
(let ((*application-frame* ,f))
(setf (frame-panes ,f)
(frame-wrapper
,f ,fm
(with-look-and-feel-realization
(,fm ,f)
(ecase (frame-current-layout ,f)
,@(mapcar #'(lambda (layout-spec)
(destructuring-bind
(name panes) layout-spec
`(,name ,panes)))
layouts)))))))))))
(defun find-or-make-pane-named (frame name)
(second (or (assoc name (slot-value frame 'all-panes))
(car (push
(list name
(funcall (second (assoc name (slot-value frame 'pane-constructors)))
frame
(frame-manager frame)))
(slot-value frame 'all-panes))))))
(defun compute-pane-constructor-code (panes)
`(list ,@(mapcar #'(lambda (pane-spec)
(destructuring-bind
(name code) pane-spec
`(list ',name
#'(lambda (frame framem)
(with-look-and-feel-realization
(framem frame)
,code)))))
panes)))
(defmacro with-look-and-feel-realization ((realizer frame) &rest forms)
`(macrolet ((silica::realize-pane (&rest foo)
`(realize-pane-internal ,',realizer ,',frame ,@foo)))
,@forms))
(defmethod enable-frame ((frame application-frame))
(ecase (frame-state frame)
(:enabled)
((:disabled :disowned)
(let ((old (frame-state frame)))
(setf (frame-state frame) :enabled)
;; IF this is a new frame then if the user specified a width
;; then we should be using that
;; IF the frame already exists then we probably should be using
;; the top level sheet size
(multiple-value-call
#'layout-frame
frame
(ecase old
(:disowned (values))
(:disabled
(bounding-rectangle-size
(frame-top-level-sheet frame)))))
(note-frame-enabled (frame-manager frame) frame)))))
(defmethod disable-frame ((frame application-frame))
(ecase (frame-state frame)
((:enabled :shrunk)
(setf (frame-state frame) :disabled)
(note-frame-disabled (frame-manager frame) frame))))
(defmethod layout-frame ((frame application-frame) &optional width height)
(when (frame-panes frame)
(unless (and width height)
(let ((sr (compose-space (frame-panes frame))))
(setq width (silica::space-req-width sr)
height (silica::space-req-height sr))))
(allocate-space (frame-panes frame) width height)
;; This is quite likely not going to work
(when (frame-top-level-sheet frame)
(silica::resize-sheet* (frame-top-level-sheet frame)
width height))))
(defun make-application-frame (class &rest options &key enable &allow-other-keys)
(with-rem-keywords (options options '(:enable))
(let ((frame (apply #'make-instance class options)))
(when enable (enable-frame frame))
frame)))
(defmethod note-frame-enabled ((framem frame-manager) frame)
(declare (ignore frame)))
(defmethod note-frame-disabled (framem frame)
(declare (ignore frame)))
(defmethod run-frame-top-level :around ((frame application-frame))
(with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame))
(let ((*application-frame* frame))
(call-next-method))))
(defmethod run-frame-top-level ((frame application-frame))
(unwind-protect
(progn
(let ((tl (frame-top-level frame)))
(if (atom tl)
(funcall tl frame)
(apply (car tl) frame (cdr tl)))))
(disable-frame frame)))
(defun command-enabled-p (command frame) t)
(defmethod default-frame-top-level (frame
&key command-parser command-unparser partial-command-parser
(prompt "Command: "))
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
(loop
(catch 'layout-changed
(let* ((*standard-output* (or (frame-standard-output frame) *standard-output*))
(*query-io* (or (frame-query-io frame) *query-io*))
(interactor (find-frame-pane-of-type frame 'interactor-pane))
(*standard-input* (or interactor *standard-output*))
(*command-parser*
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-only-command-parser)))
(*command-unparser*
(or command-unparser
#'command-line-command-unparser))
(*partial-command-parser*
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-only-read-remaining-arguments-for-partial-command))))
(unless (typep *standard-input* 'excl::bidirectional-terminal-stream)
(assert (port *standard-input*)))
(unless (typep *standard-output* 'excl::bidirectional-terminal-stream)
(assert (port *standard-output*)))
(unless (typep *query-io* 'excl::bidirectional-terminal-stream)
(assert (port *query-io*)))
(loop
(clim-utils::with-simple-abort-restart ("Abort Command")
(redisplay-frame-panes frame)
(when interactor
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(funcall prompt *standard-input* frame)))
(let ((command (read-frame-command frame :stream *standard-input*)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(when command
(execute-frame-command frame command)))))))))
(defmethod redisplay-frame-panes (frame &key force-p)
(map-over-sheets #'(lambda (sheet)
(when (typep sheet 'basic-clim-interactor)
(redisplay-frame-pane frame sheet :force-p
force-p)))
(frame-top-level-sheet frame)))
(defun redisplay-frame-pane (frame pane &key force-p)
(when (pane-display-function pane)
(let* ((ird (slot-value pane 'incremental-redisplay-p))
(history
(and ird
(output-recording-stream-output-record pane)))
(record (and history
(> (output-record-count history) 0)
(output-record-element history 0))))
(cond ((and ird (or force-p (null record)))
(when force-p
(window-clear pane))
(updating-output (pane)
(invoke-pane-redisplay-function frame pane)))
(ird
(redisplay record pane))
(t
(invoke-pane-redisplay-function frame pane))))))
(defun invoke-pane-redisplay-function (frame pane)
(let ((fn (pane-display-function pane)))
(if (atom fn)
(funcall fn frame pane)
(apply (car fn) frame pane (cdr fn)))))
(defun execute-frame-command (frame command)
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
(defun frame-find-innermost-applicable-presentation (frame
input-context
history-window px py)
(find-innermost-applicable-presentation
input-context history-window px py))
(defmethod frame-maintain-presentation-histories (frame) nil)
(defvar *click-outside-menu-handler* nil)
(defmethod frame-input-context-button-press-handler
(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*))
#+excl
(when (and *click-outside-menu-handler*
(output-recording-stream-p window)
(not
(region-contains-point*-p
(output-recording-stream-output-record 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.
(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))
*null-presentation*)
input-context
button-press-event)))
(defun find-frame-pane-of-type (frame type)
(map-over-sheets
#'(lambda (sheet)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defun map-over-sheets (fn sheet)
(funcall fn sheet)
(when (typep sheet 'silica::sheet-parent-mixin)
(dolist (child (sheet-children sheet))
(map-over-sheets fn child))))
(defmethod frame-standard-output (frame)
(find-frame-pane-of-type frame 'application-pane))
(defmethod frame-standard-input (frame)
(find-frame-pane-of-type frame 'interactor-pane))
(defmethod frame-query-io (frame)
(or (frame-standard-input frame)
(frame-standard-output frame)))
;; frame-query-io
;; frame-pointer-documentation
(defmethod read-frame-command ((frame 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))
(defmethod frame-exit ((frame application-frame))
(invoke-restart 'frame-exit))
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
(defmethod (setf frame-current-layout) (nv (frame application-frame))
(unless (eq (frame-current-layout frame) nv)
(setf (slot-value frame 'current-layout) nv)
;; Top level sheet should loose all its child annd then we should
(dolist (name-and-pane (slot-value frame 'all-panes))
(let ((sheet (second name-and-pane)))
(when (silica::sheet-parent sheet)
(silica::disown-child (silica::sheet-parent sheet) sheet))))
(dolist (child (sheet-children (frame-top-level-sheet frame)))
(silica::disown-child (frame-top-level-sheet frame) child))
;; Now we want to give it some new ones
(generate-panes frame (frame-manager frame))
(adopt-child (frame-top-level-sheet frame) (frame-panes frame))
(silica::clear-space-req-caches-in-tree (frame-panes frame))
(multiple-value-call #'layout-frame
frame
(bounding-rectangle-size
(frame-top-level-sheet frame)))
(print 'throwing excl:*initial-terminal-io*)
(throw 'layout-changed nil)))