;;; -*- Mode:COMMON-LISP; Package:X11; Base:10.; Fonts:(MEDFNB 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 ;;; MS 2151 ;;; ;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved. ;;; Change history: ;;; ;;; Date Author Description ;;; ------------------------------------------------------------------------------------- ;;; 11/23/88 LGO Optimize get-atom-id ;;; 111*/108*/88 LGO 1Add optional create-p parameter to get-atom-id (used by query-font)* ;;; 110*/118*/88 LGO 1Allow 4get-property *with zero length.* ;;; 9/122*/88 LGO 1Save wm_name property in state structure for debugging* ;;; 9/12/88 LGO 1Use floor instead of / to avoid rationals in get-property and change-property* ;;; 9/019*/88 LGO 1Remove redundent *alphabetic-case-affects-string-comparison1 binding from *get-atom-id ;;; 9/09/88 LGO Use ucoded assq instead of member* in get-atom-name ;;; 9/09/88 LGO Use ucoded equal instead of string= in get-atom-id ;;; 9/08/88 LGO1/DAN* 1Make get-property work properly* ;;; 9/08/88 LGO 1Fix 4change-property* to only swap bytes when needed* ;;; 9/08/88 LGO Rewrite ELEMENTS-TO-LIST to generate cdr-coded lists ;;; 5/3/88 DAN Fixed CHANGE-PROPERTY to correctly byte-swap for formats 16 & 32. ;;; Replaced CASE with SELECT in CHANGE-PROPERTY. ;;; 4/27/88 DAN Moved code for GET-ATOM-NAME-1 into GET-ATOM-NAME request. ;;; Fixed ROTATE-PROPERTIES to generate PROPERTY-NOTIFY events in the ;;; correct order. ;;; 4/13/88 DAN Added *DEFINED-ATOMS* structure to hold all defined atoms. ;;; Redefined STORE-ATOM and GET-ATOM to use access *DEFINED-ATOMS*. ;;; Moved STORE-ATOM and GET-ATOM from SERVER-DEFS file. ;;; Changed GET-ATOM to GET-ATOM-ID and added GET-ATOM-NAME. ;;; Added CLEAR-NON-PREDEFINED-ATOMS to be called by server shutdown. ;;; 3/31/88 TWE Fixed GET-ATOM-NAME to form the reply properly. ;;; 1/27/88 DAN Included all the ATOM and PROPERTY Request functions. ;;; 12/15/87 TWE Moved requests from the REQUESTS file. ;1;;ATOMS* ;1;;Would it be better to create a new package and use FIND-SYMBOL, INTERN, etc?* ;(DEFPARAMETER *defined-atoms* nil ; "2This is an association list to hold all defined atoms. The elements should consist of (*atom value)2 pairs.*") (DEFUN store-atom (ATOM value) "2Stores ATOM-VALUE pair in (*global-state.atoms *globals*)2.*" (PUSHNEW (LIST atom value) (global-state.atoms *globals*))) (DEFUN get-atom-id (ATOM &optional create-p) "2Get the ID for ATOM*" (LET ((atoms (global-state.atoms *globals*))) (or #+comment ;1; This is s l o w* (CAAR (MEMBER atom atoms :key 'CADR :test #'equal)) ;1; this is MUCH faster* (dolist (entry atoms nil) (when (equal atom (second entry)) (return (first entry)))) (and create-p (let ((id (make-atom-id))) (store-atom id (string-append atom)) id))))) (DEFUN get-atom-name (id) "2Get the name of ATOM with id ID*" (LET ((atoms (global-state.atoms *globals*))) (second (assoc id atoms :test #'eq)))) (DEFUN SETUP-PREDEFINED-ATOMS () (SETF (global-state.atoms *globals*) nil) (LOOP FOR (ATOM ID) ON PREDEFINED-ATOM-LIST BY #'CDDR DO (STORE-ATOM ID (SYMBOL-NAME ATOM)))) (DEFPARAMETER 4*last-atom-id* *(1- predefined-atom-length) "2The value of the last defined atom*") (DEFUN clear-non-predefined-atoms () "2Delete all non-predefined atoms. This is called when the server shuts down.*" (LET* ((atoms (global-state.atoms *globals*)) (non-predef-length (- (LENGTH atoms) (1- predefined-atom-length)))) (SETF (global-state.atoms *globals*) (NTHCDR non-predef-length atoms)) (SETQ 4*last-atom-id** (1- predefined-atom-length)))) (DEFUN 4make-atom-id *() (incf *last-atom-id*)) (defreq Intern-Atom ((only-if-exists BOOL) (nbytes CARD16) (:byte nbytes)) (intern-atom only-if-exists nbytes bytes byte-offset state)) (DEFUN 4Intern-Atom *(only-if-exists nbytes bytes byte-offset state) "2Returns the atom for the given name. If only-if-exists is False, then* 2the atom is created if it does not exist.*" (LET* ((name (BYTES-TO-STRING BYTES NBYTES byte-OFFSET)) (ATOM (GET-ATOM-ID name))) (WHEN (AND (EQL only-if-exists FALSE) (NULL atom)) (store-atom (SETQ atom (make-atom-id)) (string-append name))) ;1; get our own copy of the name string* (format-reply (state) :long (OR atom universal-none)))) (defreq Get-Atom-Name ((atom ATOM)) (LET* ((NAME (GET-ATOM-NAME ATOM)) (LENGTH (LENGTH NAME))) ;; Output the header part of the reply. (FORMAT-REPLY (STATE) :WORD LENGTH) (SERVER-PUSH STATE) ;; Output the string and the pad bytes. (SERVER-STRING-OUT STATE NAME LENGTH) (SERVER-REPLY-PAD LENGTH STATE) (SERVER-PUSH STATE))) ;;;(DEFUN GET-ATOM-NAME-1 (ATOM STATE) ;;; "2Returns the name for the given atom.*" ;;; (LET* ((NAME (GET-ATOM-NAME ATOM)) ;;; (LENGTH (LENGTH NAME))) ;;; ;; Output the header part of the reply. ;;; (FORMAT-REPLY (STATE) :WORD LENGTH) ;;; (SERVER-PUSH STATE) ;;; ;; Output the string and the pad bytes. ;;; (SERVER-STRING-OUT STATE NAME LENGTH) ;;; (SERVER-REPLY-PAD LENGTH STATE) ;;; (SERVER-PUSH STATE))) ;1;;PROPERTIES* (defstruct (4Property* (:CONC-NAME "3PROPERTY*.") (:print-function print-property)) name type format data) (defreq List-Properties ((window WINDOW)) (list-properties state window)) (DEFUN 4list-properties* (STATE window) "2Returns the atoms of properties currently defined on the window.*" (LET* ((property-list (window.properties window)) (atom-list (LOOP for prop in property-list collecting (property.name prop))) LONG-COUNT output-buffer-length) ;; Count up the length of the additional data. (setq long-count (length atom-list)) (FORMAT-REPLY (STATE LONG-COUNT) :WORD (LENGTH atom-list)) (SERVER-PUSH STATE) (setq output-buffer-length (LOOP WITH OUTPUT-INDEX = 0 FOR atom IN atom-LIST DO (PROGN (setq output-index (SIMPLE-REPLY (STATE output-index) :LONG atom))) finally (return output-index))) (SERVER-STRING-OUT STATE (RESPONSE.BYTES (STATE.RESPONSE STATE)) output-buffer-length) (SERVER-PUSH STATE))) (defreq Delete-Property ((window WINDOW) (property ATOM)) (delete-property window property)) (DEFUN 4delete-property *(window atom) "2Deletes the property from the specified window if the property exists.* 2Generates a PropertyNotify event on the window unless the property does* 2not exist.*" (LET* ((property-list (window.properties window)) (prop-exists? (MEMBER atom property-list :key #'property.name ))) (WHEN prop-exists? (SETF (window.properties window) (DELETE atom property-list :key #'property.name)) 1 *;1generate PropertyNotify event!! *(Property-Notify-Event window atom (get-time-in-millis) Property-Deleted) ))) (defreq 4Get-Property *((DELETE BOOL) (window WINDOW) (property ATOM) (TYPE (ONEOF ATOM)) (loffset CARD32) (llength CARD32) (:byte)) (get-property state delete window property type loffset llength)) (DEFUN 4get-property *(state delete? window property type offset length) "2If type Any is specified, returns the property from the specified window regardless of its type. If a type is specified, returns the property only if its type equals the specified type. If delete is True and a property is returned, the property is also deleted from the window and a PropertyNotify event is generated on the window.*" (block bad-length-error (LET* ((property-list (window.properties window)) (prop (CAR (MEMBER property property-list :key #'property.name))) (ignore-delete t) (reply-type UNIVERSAL-NONE) (reply-format 0) (bytes-after 0) (success? t) index lenth reply-length reply-nitems n) (COND (prop ;1if the property exists* (cond ((OR (EQ type (property.type prop)) (EQL type Any-Property-Type)) (SETQ n (* (LENGTH (property.data prop)) (CASE (property.format prop) (8 1) (16 2) (32 4)))) (SETQ index (* 4 offset)) (IF (>= (- n index) 0) (SETQ lenth (MIN (- n index) (* 4 length))) (return-from bad-length-error (bad-value offset))) (setq reply-length (ceiling lenth 4)) (SETQ bytes-after (- n (+ index lenth))) (setq reply-nitems (floor lenth (CASE (property.format prop) (8 1) (16 2) (32 4)))) (SETQ reply-type (property.type prop) reply-format (property.format prop) ignore-delete nil)) (t ;1types don't match so send back property info but not data.* (SETQ reply-type (property.type prop) reply-format (property.format prop) reply-length 0 reply-nitems 0 ;1;return the property length in bytes regardless of the format* bytes-after (LENGTH (property.data prop)) success? nil)))) (t ;1property doesn't exist* (SETQ reply-type universal-none reply-format 0 bytes-after 0 reply-nitems 0 reply-length 0 success? nil))) ;1;Send out the reply* (FORMAT-REPLY (STATE reply-length) :byte reply-format :long reply-type :long bytes-after :long reply-nitems) (when success? ;; Go through a loop, converting the byte index to a unit index ;; accessing data elements via the nth function and then using ;; a simple-reply depending upon the reply-format. (SETQ index 0) (LOOP for data-index from 0 below reply-nitems do (SETQ index (case reply-format (8 (simple-reply (state index) :byte (nth data-index (property.data prop)))) (16 (simple-reply (state index) :word (nth data-index (property.data prop)))) (32 (simple-reply (state index) :long (nth data-index (property.data prop))))))) (SERVER-STRING-OUT STATE (RESPONSE.BYTES (STATE.RESPONSE STATE)) INDEX) (SERVER-REPLY-PAD INDEX STATE) (SERVER-PUSH STATE) ;1;Delete the property?* (UNLESS ignore-delete (IF (AND (= delete? true) (= 0 bytes-after)) (delete-property window property))))))) (defreq Change-Property ((mode (CARD8 Property-Replace Property-Prepend Property-Append)) (window WINDOW) (property ATOM) (type ATOM) (format (CARD8 8 16 32)) (nunits CARD32) ;; We need word because if we don't have it then we can't ;; get at the word array. (:byte)) (change-property state mode window property type format nunits byte-OFFSET)) (DEFUN 4change-property *(state mode window property type format number-data-elements byte-offset) "2Alters the property for the specified window. The type is uninterpreted by the server. The format specifies whether the data should be viewed as a list of 8-bit, 16-bit, or 32-bit quantities, so that the server can correctly byte-swap as necessary. If mode is Replace, the previous property value is discarded. If the mode is Prepend or Append, then the type and format must match the existing property value; if the property is undefined, it is treated as * 2defined with the correct type and format with zero-length data. For Prepend, the data is tacked on to the beginning of the existing data, and for Append it is tacked on to the end of the existing data. Generates a PropertyNotify event on the window. The lifetime of a property is not tied to the storing client. Properties remain until explicitly deleted, or the window is destroyed, or until server reset.*" (LET* ((data-list (CASE format (8 (state.bytes state)) ; (16 ; (state.words state)) ; (32 ; (state.longs state)))) (16 (when (state.swap-p state) (LET ((BYTES (state.bytes state)) (offset byte-offset)) (LOOP FOR OFFSET FROM OFFSET BY 2 for index from 0 below number-data-elements DO (ROTATEF (AREF BYTES OFFSET) (AREF BYTES (+ OFFSET 1)))))) (state.words state)) (32 (when (state.swap-p state) (LET ((BYTES (state.bytes state)) (offset byte-offset)) (LOOP FOR OFFSET FROM OFFSET BY 4 for index from 0 below number-data-elements DO (PROGN (ROTATEF (AREF BYTES (+ OFFSET 1)) (AREF BYTES (+ OFFSET 2))) (ROTATEF (AREF BYTES OFFSET) (AREF BYTES (+ OFFSET 3))))))) (state.longs state)))) (property-list (window.properties window)) (prop (CAR (MEMBER property property-list :key #'property.name))) (data (ELEMENTS-TO-LIST data-list number-data-elements (floor byte-OFFSET (CASE FORMAT (8 1) (16 2) (32 4)))))) (COND (prop ;1if the property already exists* (SELECTOR mode eql (Property-Replace (SETF (property.type prop) type) (SETF (property.format prop) format) (SETF (property.data prop) data)) (Property-Append (IF (AND (EQ (property.type prop) type) (EQ (property.format prop) format)) (SETF (property.data prop) (APPEND (property.data prop) data)))) (Property-prepend (IF (AND (EQ (property.type prop) type) (EQ (property.format prop) format)) (SETF (property.data prop) (APPEND data (property.data prop))))))) (t ;1property doesn't exist so add it* (LET ((new-prop (make-property :name property :type type :format format :data data))) (SETF (window.properties window) (PUSH new-prop property-list)))) ) ;1;Generate a PropertyNotify event* (Property-Notify-Event window property (get-time-in-millis) Property-New-Value) ;1; DEBUG HACK* ;1; In order to identify client connections for debugging, Save the value* ;1; of the wm-name properties a connection sets in the state structure.* (when (= property predefined-atom-wm-name) (pushnew (string-append (bytes-to-string data-list number-data-elements byte-offset)) (state.plist state) :test #'string-equal) (setf (state.description state) (format nil "~{~a~^, ~}" (state.plist state))) (setf (si:process-name si:current-process) ;1; change process name for peek* (string-append "X Server " (state.description state)))) )) (defreq Rotate-Properties ((window WINDOW) (num-props INT16) (delta INT16) (:long)) (rotate-properties window longs num-props delta long-offset)) (DEFUN 4Rotate-Properties *(window properties numprops delta long-offset) "2Rotate the properties by delta places around the virtual ring of property names. A positive delta rotates right, a negative delta rotates left.*" (LET* ((props (elements-to-list properties numprops long-offset)) (win-props (window.properties window)) (p-length (LENGTH props)) wprop prop-indxs) (SETQ prop-indxs (LOOP for i from 0 below p-length for prop = (NTH i props) ;1;Check to see if any atoms occur more than once* do (LOOP for j from (1+ i) below p-length when (EQL prop (NTH j props)) do (bad-match)) ;1;Make sure there is a property with that name defined for the window* when (SETQ wprop (CAR (MEMBER prop win-props :key #'property.name))) collect (POSITION wprop win-props) into indxs else do (bad-match) finally (RETURN indxs))) ;1;If the rotation is a complete 360 degrees, then moving the properties around and* ;1;generating PropertyNotify events should be skipped. * (UNLESS (OR (<= numprops 0) (= 0 (MOD (ABS delta) numprops))) (LOOP for i from 0 below numprops for prop = (NTH (MOD (+ i delta) numprops) props) ;(NTH i props) for windx = (NTH i prop-indxs) for wprop = (property.name (NTH windx win-props)) do (PROGN 1 *;1;Generate a PropertyNotify event for each property whose value* ;1;is changed in the order in which they appear in the request.* (Property-Notify-Event window wprop (get-time-in-millis) Property-New-Value) (SETF (property.name (NTH windx win-props)) prop) ))) ; (SETF (window.properties window) win-props) )) (DEFUN 4ELEMENTS-TO-LIST* (data number-of-elements DATA-OFFSET) "2Convert data into a list.*" (let ((list (make-list number-of-elements))) (LOOP FOR INDEX upfrom data-offset for cons on list do (setf (car cons) (aref data index))) list)) ;1;;EVENTS* (DEFUN 4Property-Notify*-Event4 *(window property time property-state) "2Generate a PropertyNotify event. Property-state can have the values: Property-New-Value or Property-Deleted.*" (DECLARE (type window window) (type atom property) (type integer time) (type property-type property-state)) (LET ((event (make-event-property :type Property-Notify-Event :window window :atom property :time time :state property-state))) (deliver-events window event 1 nil)))