;;; -*- Mode: COMMON-LISP; Package: TV; Base: 10; Fonts: MEDFNT, HL12B, HL12BI; -*- ;;;=============================================================================== ;;; RESTRICTED RIGHTS LEGEND ;;; Use, duplication, or disclosure by the Government is subject to restrictions ;;; as set forth in subdivision (b)(3)(ii) of the Rights in Technical Data and ;;; Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED, P.O. BOX 2909 AUSTIN, TEXAS 78769 ;;; Copyright (C) 1988, Texas Instruments Incorporated. All rights reserved. ;;;=============================================================================== ;;; ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 09/26/88 LGO Created (defvar *x11-peek-events* nil) (defvar *x11-peek-properties* nil) (defvar *x11-peek-unmapped* t) (DEFCOMMAND 4peek-x11-hierarchy-cmd* () '(:DESCRIPTION "3Display the hierarchy of *X11 3window inferiors*" :NAMES ("X11 Server") :KEYS (#\x)) (DECLARE (SPECIAL ucl-peek-menu peek-pane mode-pane)) (LET ((menu-item (DOLIST (item ucl-peek-menu) (WHEN (EQ SELF (THIRD item)) (RETURN item))))) (SEND mode-pane :SET-HIGHLIGHTED-ITEMS (LIST menu-item)) (SEND peek-pane :SET-LABEL "X113 *Server") (SEND peek-pane :SET-DISPLAY-ITEM (peek-x11-hierarchy NIL)))) (pushnew '4peek-x11-hierarchy-cmd* 4PEEK-MODES*) (BUILD-COMMAND-TABLE 'peek-mode-cmd-table 'peek-frame peek-modes :INIT-OPTIONS '(:NAME "3Peek modes*")) (BUILD-MENU 'ucl-peek-menu 'peek-frame :default-item-options '(:font fonts:cptfont) :item-list-order peek-modes) ;1;;-----------------------------------------------------------------------------* (DEFUN 4PEEK-X11-HIERARCHY* (IGNORE) (list () (peek-x11-device (x11:lookup-pointer-device)) (peek-x11-device (x11:lookup-keyboard-device)) (scroll-parse-item " ") (SCROLL-PARSE-ITEM "States") (SCROLL-MAINTAIN-LIST #'(LAMBDA () (x11:global-state.states x11:*globals*)) #'(LAMBDA (state) (LIST () (SCROLL-PARSE-ITEM `(:MOUSE (NIL :EVAL (PEEK-X11-state-MENU ',state) :DOCUMENTATION "3Menu of useful things to do to this *state3.*") :string ,(FORMAT NIL "~s" state)) (format nil ", Request# ~d" (x11:state.sequence-id state)) )))) (SCROLL-PARSE-ITEM "") (scroll-parse-item "Windows " `(:mouse (nil :eval (setq *x11-peek-events* (not *x11-peek-events* )) :documentation "Toggle window event display") :symeval *x11-peek-events* nil ("~:[Display Events~;Don't display events~]")) " " `(:mouse (nil :eval (setq *x11-peek-properties* (not *x11-peek-properties* )) :documentation "Toggle window property display") :symeval *x11-peek-properties* nil ("~:[Display Properties~;Don't display properties~]")) " " `(:mouse (nil :eval (setq *x11-peek-unmapped* (not *x11-peek-unmapped* )) :documentation "Toggle window unmapped-window display") :symeval *x11-peek-unmapped* nil ("~:[Display unmapped windows~;Don't display unmapped windows~]"))) (SCROLL-MAINTAIN-LIST #'(LAMBDA () (loop for root in x11:*window-roots* for window = (x11:find-object root) when root collect window)) #'(LAMBDA (window) (LIST () (peek-x11-window-display window 0) (PEEK-X11-INFERIORS window 2) (SCROLL-PARSE-ITEM "")))))) (DEFUN 4PEEK-X11-INFERIORS* (WINDOW INDENT) (SCROLL-MAINTAIN-LIST #'(lambda () (loop for child being the x11:xwindow-children x11:of window when (or *x11-peek-unmapped* (x11:window.mapped-p child)) collect child)) #'(LAMBDA (window) (LIST () (peek-x11-window-display window indent) (PEEK-X11-INFERIORS window (+ INDENT 4)))))) (defun peek-x11-window-display (window indent) (SCROLL-PARSE-ITEM (FORMAT NIL "3~V@t*" INDENT) `(:MOUSE (NIL :EVAL (PEEK-X11-window-MENU ',window) :DOCUMENTATION "3Menu of useful things to do to this window.*") :STRING ,(FORMAT NIL "~s" window)))) (defun peek-x11-window-display (window indent) (flet ((item (value) `(:function identity (,value) nil nil)) (mask-format (event-mask) (let ((client (x11:other-client.client event-mask)) (mask (x11:other-client.mask event-mask))) (if (eq (x11:window.client window) client) (format nil "Event-Mask ~a" (if (numberp mask) (x11:make-event-keys mask) mask)) (format nil "Client ~s~%~7@tEvent-Mask ~a" client (if (numberp mask) (x11:make-event-keys mask) mask)))))) (SCROLL-PARSE-ITEM (FORMAT NIL "3~V@t*" INDENT) `(:MOUSE (NIL :EVAL (PEEK-X11-window-MENU ',window) :DOCUMENTATION "3Menu of useful things to do to this window.*") :STRING ,(FORMAT NIL "ID #x~x (~d)" (x11:window.id window) (x11:window.id window))) " at (" (item (x11:WINDOW.ABSOLUTE-X-CORNER window)) "," (item (x11:WINDOW.ABSOLUTE-Y-CORNER window)) ") " (item (x11:WINDOW.WIDTH window)) " by " (item (x11:WINDOW.HEIGHT window)) ", " `(:function ,#'(lambda (mapped-p stack) (cond ((not mapped-p) "UnMapped") ((null stack) "Covered") ((eq stack t) "Complete") ((null (cdr stack)) "Edge-Occluded") (t "Occluded"))) (,(x11:window.mapped-p window) ,(x11:window.occlusion-stack window)) nil nil) `(:function ,#'(lambda (properties) (let ((name (find x11:predefined-atom-wm-name properties :key #'x11:property.name))) (if name (format nil ", Name: ~s" (coerce (x11:property.data name) 'string)) ""))) (,(x11:window.properties window)) nil nil) `(:function ,#'(lambda (properties) (if (or (not *x11-peek-properties*) (null properties)) "" (format nil "~%3~V@t*~~{~a~^~%~}~" (+ indent 6) properties))) (,(x11:window.properties window)) nil nil) `(:function ,#'(lambda (event-masks) (if (or (not *x11-peek-events*) (null event-masks)) "" (format nil "~%3~V@t*~~{~a~^~%~}~" (+ indent 6) (mapcar #'mask-format event-masks)))) (,(x11:window.event-masks window)) nil nil) `(:function ,#'(lambda (window) (if (x11:is-parent window (x11:SPRITE.WINDOW x11:SPRITE)) " Has Pointer" "")) (,window) nil nil)))) (defun describe-grab (grab type) (if (or (null grab) (numberp grab)) "" (format nil "~%~8@t~a by ~s, Window #x~x" type (x11:grab-record.client grab) (x11:window.id (x11:grab-record.window grab))))) (defun peek-x11-device (device) (scroll-parse-item `(:MOUSE (NIL :EVAL (PEEK-X11-device-MENU ',device) :DOCUMENTATION "3Menu of useful things to do to this *device3.*") :string ,x11:(case (device.device-proc tv:device) (pointer-initialization-internal "Pointer ") (keyboard-initialization-internal "Keyboard") (otherwise "unknown-type"))) " " `(:function ,#'(lambda (inited) (if (eq inited t) "" " Uninitialized")) (,(x11:device.inited device))) `(:function ,#'(lambda (state) (string (aref #( NOT-GRABBED THAWED ;; Not a real state. THAWED-BOTH FREEZE-NEXT-EVENT FREEZE-BOTH-NEXT-EVENT ;; Any state >= has device frozen. FROZEN FROZEN-WITH-EVENT) state))) (,(x11:sync.state (x11:device.sync device)))) `(:function describe-grab (,(x11:device.grab device) " Grabbed")) `(:function describe-grab (,(x11:device.passive-grab device) " Passive-Grabbed")) `(:function describe-grab (,(x11:device.auto-release-grab device) " Auto-Release-Grabbed")) )) (DEFUN 4PEEK-X11-*window-4MENU* (&REST ARGS) (APPLY #'PROCESS-RUN-FUNCTION "3Peek Window Menu*" SELF :PEEK-X11-window-MENU ARGS)) (DEFMETHOD 4(BASIC-PEEK :PEEK-X11-*window-4MENU*) (window &REST IGNORE) "2Menu for interesting operations on windows in a peek display*" (let ((CHOICE (W:MENU-CHOOSE `(("3Describe*" :VALUE DESCRIBE :DOCUMENTATION "3Describe the window.*") ("3Inspect*" :VALUE INSPECT :DOCUMENTATION "3Inspect the window.*") ("Break-Set=" :value break-set= :DOCUMENTATION "Break with = set to the window.") ,@(and (x11:window.backing-store window) `(("Display" :value display :documentation "Display the Backing Store for this window")))) :label (princ-to-string window) :scrolling-p nil)) (*TERMINAL-IO* TYPEOUT-WINDOW)) (case choice (nil nil) ((INSPECT DESCRIBE) (SEND SELF :FORCE-KBD-INPUT `(,CHOICE ,window))) (display (send self :force-kbd-input (format nil "~c(x11:show-pixmap (x11:find-object ~d))" #\break (x11:window.id window))) #+comment (tv:show-bit-array (x11:pixmap.array (x11:window.backing-store window)) :window typeout-window)) (otherwise (funcall choice self window))))) (DEFUN 4PEEK-X11-*state-4MENU* (&REST ARGS) (APPLY #'PROCESS-RUN-FUNCTION "3Peek *State3 Menu*" SELF :PEEK-X11-state-MENU ARGS)) (DEFMETHOD 4(BASIC-PEEK :PEEK-X11-*state-4MENU*) (state &REST IGNORE &AUX CHOICE) "2Menu for interesting operations on states in a peek display*" (SETQ CHOICE (W:MENU-CHOOSE '(("3Describe*" :VALUE DESCRIBE :DOCUMENTATION "3Describe the state.*") ("3Inspect*" :VALUE INSPECT :DOCUMENTATION "3Inspect the state.*") ("Break-Set=" :value break-set= :DOCUMENTATION "Break with = set to the state.") ("Debug" :value debug :documentation "Debug the process associated with this state.")) :label (princ-to-string state) :scrolling-p nil)) (case choice (nil nil) ((inspect describe) (LET ((*TERMINAL-IO* TYPEOUT-WINDOW)) (SEND SELF :FORCE-KBD-INPUT `(,CHOICE ,state)))) (debug (LET ((*TERMINAL-IO* TYPEOUT-WINDOW)) (SEND SELF :FORCE-KBD-INPUT `(eh ,(x11:state.process state))))) (otherwise (LET ((*TERMINAL-IO* TYPEOUT-WINDOW)) (funcall choice self state))))) (DEFUN 4PEEK-X11-*device-4MENU* (&REST ARGS) (APPLY #'PROCESS-RUN-FUNCTION "3Peek *Device3 Menu*" SELF :PEEK-X11-device-MENU ARGS)) (DEFMETHOD 4(BASIC-PEEK :PEEK-X11-*device-4MENU*) (device &REST IGNORE &AUX CHOICE) "2Menu for interesting operations on devices in a peek display*" (SETQ CHOICE (W:MENU-CHOOSE '(("3Describe*" :VALUE DESCRIBE :DOCUMENTATION "3Describe the device.*") ("3Inspect*" :VALUE INSPECT :DOCUMENTATION "3Inspect the device.*") ("Break-Set=" :value break-set= :DOCUMENTATION "Break with = set to the device.")) :label (princ-to-string device) :scrolling-p nil)) (case choice (nil nil) ((inspect describe) (LET ((*TERMINAL-IO* TYPEOUT-WINDOW)) (SEND SELF :FORCE-KBD-INPUT `(,CHOICE ,device)))) (otherwise (LET ((*TERMINAL-IO* TYPEOUT-WINDOW)) (funcall choice self device))))) (defun break-set= (peek thing) (declare (special =)) (setq = thing) (send peek :force-kbd-input #\break))