1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
|
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10 -*-
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 149149
;;; AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Created 3/03/88 by LGO
(in-package "XLIB")
(export '(window-documentation
change-window-documentation))
(defun change-window-documentation (window string &key (mode :replace) format
state select font translate)
;; STRING will be displayed using FONT when the mouse is over WINDOW
;; and (zerop (logand SELECT (logxor STATE current-state)))
;; TRANSLATE defaults to #'xlib:translate-default
;; FORMAT defaults to STRING when no keywords are specified,
;; otherwise it defaults to 8.
(declare (type window window)
(type string string)
(type (member :replace :prepend :append) mode)
(type (member 8 16 string) format)
(type modifier-mask state select)
(type (or null font) font)
(type (or null translation-function) translate))
(unless format
(setq format (if (and (eq mode :replace) (zerop state) (zerop select)
(null font) (null translate))
:string 8)))
(ecase format
(:string
(change-property window :wm_documentation (string string) :string 8 :transform #'char->card8))
(8 (change-window-documentation8 window string mode state select font translate))
(16 (change-window-documentation16 window string mode state select font translate))))
(defun change-window-documentation8 (window string mode state select font translate)
(declare (type window window)
(type string string)
(type (member :replace :prepend :append) mode)
(type modifier-mask state select)
(type (or null font) font)
(type (or null translation-function) translate))
(let* ((display (window-display window))
(src-start 0)
(src-end (length string))
(length (- src-end src-start))
(property (intern-atom display :wm_documentation))
(type property)
(state (encode-state-mask state))
(select (encode-state-mask (or select state))))
(with-buffer-request (display *x-changeproperty* :length length)
((data (member :replace :prepend :append)) mode)
(window window)
(resource-id property type)
(card8 8)
(card32 length)
(card8 0) ;; Flag to indicate state/select pair
(card8 (ldb (byte 8 8) state) (ldb (byte 8 0) state))
(card8 (ldb (byte 8 8) select) (ldb (byte 8 0) select))
(progn
(do* ((boffset (index+ buffer-boffset 29))
(src-chunk 0)
(dst-chunk 0)
(offset 0)
(stop-p nil))
((or stop-p (zerop length))
(card32-put 20 (index- boffset buffer-boffset 24)) ;; Set property length
(length-put 2 (index-ash (index- (lround boffset) buffer-boffset) -2)) ;; Set request length
(setf (buffer-boffset display) (lround boffset)))
(declare (type array-index src-chunk dst-chunk offset)
(type boolean stop-p))
(setq src-chunk (index-min length *max-string-size*))
(multiple-value-bind (new-start new-font)
(funcall (or translate #'translate-default)
string src-start (index+ src-start src-chunk)
font buffer-bbuf (index+ boffset 2))
(setq dst-chunk (index- new-start src-start)
length (index- length dst-chunk)
src-start new-start)
(when (index-plusp dst-chunk)
(setf (aref buffer-bbuf boffset) dst-chunk)
(setf (aref buffer-bbuf (index+ boffset 1)) offset)
(incf boffset (index+ dst-chunk 2)))
(setq offset 0)
(cond ((null new-font)
;; Don't stop if translate copied whole chunk
(unless (index= src-chunk dst-chunk)
(setq stop-p t)))
((integerp new-font) (setq offset new-font))
((type? new-font 'font)
(setq font new-font)
(let ((font-id (font-id font))
(buffer-boffset boffset))
(declare (type resource-id font-id)
(type array-index buffer-boffset))
(card8-put 0 #xff)
(card8-put 1 (ldb (byte 8 24) font-id))
(card8-put 2 (ldb (byte 8 16) font-id))
(card8-put 3 (ldb (byte 8 8) font-id))
(card8-put 4 (ldb (byte 8 0) font-id)))
(index-incf boffset 5)))
))))))
;;;-----------------------------------------------------------------------------
(defun window-documentation (window)
(xlib:get-property window :wm_documentation :type :string
:result-type 'string :transform #'xlib::card8->char))
(defsetf window-documentation (window &optional (format 8)) (doc)
;; DOC is a string or list with the following elements:
;; :STATE xlib:modifier-mask - Strings following will use this state with zero select
;; :SELECT xlib:modifier-mask - Strings following will use this select
;; :FONT (or font stringable)- Use this font for all following strings
;; :translate xlib:translation-function - Use this translation function for all following strings
;; string - String to use with current state and select
;; Example: (:state (:button-1) :select (:button-1) "Foo" :state (:button-2) "Bar")
;; This will cause "Foo" to be displayed when button-1 and any other modifier is down in window.
;; "Bar" will be displayed when button-2 and ONLY button-2 is down in window.
`(xlib::set-window-documentation ,window ,doc ,format))
(defun set-window-documentation (window doc format)
(declare (type (or string list) doc)
(type (member 8 16) format))
(if (stringp doc)
(change-property window :wm_documentation (string doc) :string 8 :transform #'char->card8)
(let ((mode :replace))
(dolist (args doc)
(apply 'change-window-documentation window (car args)
:format format :mode mode (cdr args))
(setq mode :append))))
doc)
;; Implement this someday...
(defun change-window-documentation16 (window string mode state select font translate)
(declare (ignore window string mode state select font translate))
(error "change-window-documentation16 not implemented yet"))
|