/[eclipse]/eclipse/lib/manager-commons.lisp
ViewVC logotype

Contents of /eclipse/lib/manager-commons.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Tue Nov 17 20:51:56 2009 UTC (4 years, 5 months ago) by ihatchondo
Branch: MAIN
CVS Tags: HEAD
Changes since 1.8: +18 -15 lines
Fix: xlib:window-equal is the predicate when removing a window from a list window
1 ;;; -*- Mode: Lisp; Package: MANAGER-COMMONS -*-
2 ;;; $Id: manager-commons.lisp,v 1.9 2009/11/17 20:51:56 ihatchondo Exp $
3 ;;;
4 ;;; This is the CLX support for the managing with gnome.
5 ;;;
6 ;;; Copyright (C) 2002 Iban HATCHONDO
7 ;;; contact : hatchond@yahoo.fr
8 ;;;
9 ;;; This program is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU General Public License
11 ;;; as published by the Free Software Foundation.
12 ;;;
13 ;;; This program is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with this program; if not, write to the Free Software
20 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
21 ;;;
22 ;;; This package implements :
23 ;;; some functions that the gnome-manager and exwm-manager use.
24
25 (common-lisp:in-package :common-lisp-user)
26
27 (defpackage manager-commons
28 (:use common-lisp)
29 (:import-from :xlib #:get-property #:change-property)
30 (:size 50)
31 (:export
32 #:geometry-hint #:make-geometry-hint
33 #:geometry-hint-x #:geometry-hint-y
34 #:geometry-hint-width #:geometry-hint-height
35
36 #:encode-mask #:decode-mask
37 #:encode-strings #:decode-strings
38
39 #:utf8->strings
40 #:string->utf8
41
42 #:get-geometry-hint #:set-geometry-hint
43 #:get-atoms-property #:set-atoms-property
44 #:get-window-property #:define-window-list-property-accessor
45 #:get-text-property #:set-simple-text-property #:set-multiple-text-property
46 )
47 (:documentation ""))
48
49 (in-package :MANAGER-COMMONS)
50
51 (declaim (optimize (speed 3)
52 (safety 1)
53 (debug 1)
54 (compilation-speed 0)))
55
56 (declaim (inline get-atoms-property
57 get-window-property))
58
59 (deftype card-32 () '(unsigned-byte 32))
60 (deftype card-16 () '(unsigned-byte 16))
61 (deftype card-8 () '(unsigned-byte 8))
62 (deftype int-16 () '(signed-byte 16))
63
64 (defstruct geometry-hint
65 (x 0 :type int-16)
66 (y 0 :type int-16)
67 (width 0 :type card-16)
68 (height 0 :type card-16))
69
70 (defmacro aref8 (array index)
71 `(the (unsigned-byte 8) (aref ,array ,index)))
72
73 (defun get-geometry-hint (window property-atom)
74 (let ((prop (get-property window property-atom)))
75 (make-geometry-hint
76 :x (first prop)
77 :y (second prop)
78 :width (third prop)
79 :height (fourth prop))))
80
81 (defun set-geometry-hint (window hint property-atom)
82 (change-property window property-atom
83 (list (geometry-hint-x hint)
84 (geometry-hint-y hint)
85 (geometry-hint-width hint)
86 (geometry-hint-height hint))
87 :CARDINAL
88 32))
89
90 (defun get-atoms-property (window property-atom atom-list-p)
91 "Returns a list of atom-name (if atom-list-p is t) otherwise returns
92 a list of atom-id."
93 (get-property window property-atom
94 :transform (when atom-list-p
95 (lambda (id)
96 (xlib:atom-name (xlib:drawable-display window) id)))))
97
98 (defun get-window-property (window property-atom window-list-p)
99 "Returns a list of window (if window-list-p is t) otherwise returns
100 a list of window-id."
101 (get-property window property-atom
102 :transform (when window-list-p
103 (lambda (id)
104 (declare (type xlib:card29 id))
105 (unless (zerop id)
106 (xlib::lookup-window
107 (xlib:drawable-display window) id))))))
108
109 (defun utf8->strings (data)
110 "Converts a vector of (unsigned-byte 8) that represents utf8 string(s) into
111 into a list of strings."
112 (declare (type simple-vector data))
113 (loop with aux = nil
114 with length of-type card-16 = (1- (array-dimension data 0))
115 for i of-type (unsigned-byte 24) from 0 to length
116 for c of-type card-8 = 0 do
117 (unless (zerop (aref8 data i))
118 (if (logbitp 7 (aref8 data i))
119 (if (= #x40 (logand (aref8 data i) #x7c))
120 (when (logbitp 7 (aref8 data (1+ i)))
121 (setf c (logior (ash (logand (aref8 data i) #x3) 6)
122 (logand (aref8 data (incf i)) #x3F))))
123 (loop do (incf i)
124 while (and (logbitp 7 (aref8 data i))
125 (logbitp 6 (aref8 data i)))
126 finally (decf i) (setf c 35))) ; #\#
127 (setf c (aref8 data i))))
128 unless (= c 0) do (push c aux) end
129 if (and aux (or (= c 0) (= i length)))
130 collect (map 'string #'xlib:card8->char (reverse aux))
131 and do (setf aux nil)))
132
133 (defun string->utf8 (string &key (null-terminated t))
134 "Returns a null terminated list, or not, containing the utf8 encoding
135 of the given string."
136 (declare (type string string))
137 (loop with aux = (map 'vector #'xlib:char->card8 string)
138 for car of-type (unsigned-byte 8) across (the simple-vector aux)
139 if (< car #x80) collect car into v
140 else collect (logior #xC0 (ash car -6)) into v
141 and collect (logior #x80 (logand #xBF car)) into v end
142 finally (return (if null-terminated (concatenate 'list v '(0)) v))))
143
144 (defun encode-mask (key-vector key-list key-type)
145 "Converts a keyword list mask into its integer value mask.
146 - KEY-VECTOR is a vector containg bit-position keywords. The position of
147 the keyword in the vector indicates its bit position in the resulting mask
148 - KEY-LIST is either a mask or a list of KEY-TYPE.
149 Returns NIL when KEY-LIST is not a list or mask."
150 (declare (type (simple-array keyword (*)) key-vector))
151 (declare (type (or card-16 list) key-list))
152 (typecase key-list
153 (card-16 key-list)
154 (list (loop with mask of-type card-16 = 0
155 for key in key-list
156 for bit = (position key key-vector :test #'eq)
157 if bit do (setf mask (logior mask (the card-16 (ash 1 bit))))
158 else do (xlib::x-type-error key key-type)
159 finally (return mask)))))
160
161 (defun decode-mask (key-vector mask)
162 "Converts an integer value mask into its keyword list mask.
163 KEY-VECTOR is a vector containg bit-position keywords."
164 (declare (type (simple-array keyword (*)) key-vector))
165 (declare (type (or card-16 null) mask))
166 (when mask
167 (loop for bit of-type card-16 from 0 below (length key-vector)
168 when (logbitp bit mask) collect (aref key-vector bit))))
169
170 (defun encode-strings (&rest strings)
171 "Converts a list of string into a vector of ISO Latin-1 characters, otherwise
172 said (unsigned-byte 8). Each string are ended with the null character."
173 (loop for string in strings
174 for car = (map '(vector card-8) #'xlib:char->card8 (string string))
175 collect (concatenate '(vector card-8) car #(0)) into vector
176 finally (return (apply #'concatenate '(vector card-8) vector))))
177
178 (defun decode-strings (chars)
179 "Converts a vector of ISO Latin-1 characters, - e.g: (unsigned-byte 8) -,
180 into a list of strings. If the vector contains more than one string then
181 string are null terminated."
182 (declare (type simple-vector chars))
183 (loop with name = nil
184 with length of-type card-16 = (1- (array-dimension chars 0))
185 for char of-type card-8 across (the simple-vector chars)
186 for i of-type card-16 from 0
187 unless (= 0 char) do (push char name) end
188 when (and name (or (= 0 char) (= i length)))
189 collect (prog1 (map 'string #'xlib:card8->char (reverse name))
190 (setf name nil))))
191
192 (defun get-text-property (window property-atom)
193 "Returns the value of the property associated with `property-atom' as a
194 list of string."
195 (multiple-value-bind (data type format)
196 (get-property window property-atom :result-type 'vector)
197 (declare (type (member 8 16 32) format))
198 (when (and (= format 8) data) ;; is that true ??
199 (case type
200 (:string (decode-strings data))
201 (:utf8_string (utf8->strings data))))))
202
203 (defun set-simple-text-property (window string type property-atom)
204 "Sets a string text property designates by `property-atom'."
205 (change-property window property-atom
206 (case type
207 (:string (encode-strings string))
208 (:utf8_string (string->utf8 string :null-terminated nil)))
209 type
210 8))
211
212 (defun set-multiple-text-property (window strings type mode property-atom)
213 "Sets a multiple string text property designates by `property-atom'.
214 - STRINGS a simpla string or a list of string.
215 - TYPE is one of :string :utf8_string
216 - MODE is one of :replace :remove :append.
217 :replace : replace the value of the property by the given strings.
218 :remove : removes the given strings from the property.
219 :append : append the given strings to the property."
220 (let ((text-prop (get-text-property window property-atom)))
221 (unless (eq mode :replace)
222 (when (eq mode :remove)
223 (rotatef strings text-prop)
224 (setf mode :replace))
225 (setf strings (nset-difference strings text-prop :test #'string=))))
226 (when strings
227 (change-property window property-atom
228 (case type
229 (:string (apply #'encode-strings strings))
230 (:utf8_string
231 (apply #'concatenate 'list (mapcar #'string->utf8 strings))))
232 type
233 8
234 :mode mode)))
235
236 (defun set-atoms-property (window atoms property-atom &key (mode :replace))
237 "Sets the property designates by `property-atom'. ATOMS is a list of atom-id
238 or a list of keyword atom-names."
239 (change-property window property-atom atoms :ATOM 32
240 :mode mode
241 :transform (unless (integerp (car atoms))
242 (lambda (atom-key)
243 (xlib:find-atom (xlib:drawable-display window) atom-key)))))
244
245 (defmacro define-window-list-property-accessor
246 ((name) &key property-atom (data-type :window)
247 reader-documentation writer-documentation)
248 "Generates window list based properties accessors:
249 - `name' [ function ] window &key window-list
250 returns the value of the property named `property-atom' as a list of
251 window if window-list is T, otherwise as a list of window-id.
252 - (setf `name') (window &key window-id) (window-designator)
253 to sets the property value.
254
255 :reader-documentation (string): the reader function documentation string.
256 :writer-documentation (string): the setf function documentation string."
257 (let ((reader (intern (with-standard-io-syntax (format nil "~A" name))))
258 (seter (intern (with-standard-io-syntax (format nil "SET-~A" name)))))
259 `(progn
260 (defun ,reader (window &key window-list)
261 ,@(when reader-documentation `(,reader-documentation))
262 (get-window-property window ,property-atom window-list))
263
264 (defun ,seter (window value &key (mode :replace) window-id)
265 (unless (null value)
266 (change-property window ',property-atom
267 (cond ((eq mode :remove)
268 (let ((prop (,reader window :window-list (not window-id)))
269 (test (if window-id #'eql #'xlib:window-equal)))
270 (remove value prop :test test)))
271 ((listp value) value)
272 (t (list value)))
273 ',data-type 32
274 :mode (if (eq mode :remove) :replace mode)
275 :transform (unless window-id #'xlib:window-id))))
276
277 (defsetf ,reader (window &key (mode :replace) window-id) (value)
278 ,@(when writer-documentation `(,writer-documentation))
279 `(,',seter ,window ,value :mode ,mode :window-id ,window-id)))))

  ViewVC Help
Powered by ViewVC 1.1.5