-
Notifications
You must be signed in to change notification settings - Fork 0
/
eclipse.lisp
283 lines (263 loc) · 12.2 KB
/
eclipse.lisp
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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: eclipse.lisp,v 1.31 2010-04-23 14:36:49 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
;;; contact : hatchond@yahoo.fr
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA
(in-package :ECLIPSE-INTERNALS)
(defun load-config-file (pathname)
(load pathname))
;;; Initializations and Main.
;; ICE & SM.
(defun sm-init (sm-conn dpy)
"Sets the xsmp properties that are required by the protocols."
(declare (type (or null string) dpy))
(let ((id (format nil "--sm-client-id=~a" (sm-lib:sm-client-id sm-conn)))
(display (when dpy (format nil "--display=~a" dpy))))
(ice-lib:post-request :set-properties sm-conn
:properties
(list (sm-lib:make-property
:name sm-lib:+program+
:type sm-lib:+ARRAY8+
:values (sm-lib:strings->array8s "eclipse"))
(sm-lib:make-property
:name sm-lib:+user-id+
:type sm-lib:+array8+
:values (sm-lib:strings->array8s (get-username)))
(sm-lib:make-property
:name sm-lib:+restart-style-hint+
:type sm-lib:+card8+
;; RestartImmediately
:values (list (sm-lib:make-array8 1 :initial-element 2)))
(sm-lib:make-property
:name sm-lib:+process-id+
:type sm-lib:+array8+
:values (sm-lib:strings->array8s (format nil "~a" (getpid))))
(sm-lib:make-property
:name sm-lib:+current-directory+
:type sm-lib:+array8+
:values (sm-lib:strings->array8s (user-homedir)))
(sm-lib:make-property
:name sm-lib:+clone-command+
:type sm-lib:+list-of-array8+
:values (if display
(sm-lib:strings->array8s "eclipse" display)
(sm-lib:strings->array8s "eclipse")))
(sm-lib:make-property
:name sm-lib:+restart-command+
:type sm-lib:+list-of-array8+
:values (if display
(sm-lib:strings->array8s "eclipse" display id)
(sm-lib:strings->array8s "eclipse" id)))
;; Only for Gnome Session Manager
(sm-lib:make-property
:name "_GSM_Priority"
:type sm-lib:+card8+
:values (list (sm-lib:make-array8 1 :initial-element 20)))))))
(defun connect-to-session-manager (dpy-name &optional previous-id)
"Try to connect us to the session manager. If connected set xsmp
properties and returns the sm-connection instance."
(unless previous-id
(setf previous-id (getenv "DESKTOP_AUTOSTART_ID"))
;; unset $DESKTOP_AUTOSTART_ID in order to avoid
;; child processes to use the same client id.
(setf (getenv "DESKTOP_AUTOSTART_ID") ""))
(handler-case
(let ((sm-conn (sm-lib:open-sm-connection :previous-id previous-id)))
(sm-init sm-conn dpy-name)
sm-conn)
(error (condition) (format *error-output* "~&~A~&" condition))))
(defun handle-session-manager-request (sm-conn root-widget)
"Handles xsmp requests. If a DIE request is received then invoke
close-sm-connection and propagate the exit-eclipse condition."
(handler-case
(ice-lib:request-case (sm-conn :timeout 0)
(sm-lib:save-yourself ()
(ice-lib:post-request :save-yourself-done sm-conn :success-p t)
t)
(sm-lib:die () (close-sm-connection root-widget :exit-p t) nil)
(t t))
(exit-eclipse (condition) (signal condition))
(error (condition)
#+:cmu (debug::backtrace)
#+:sbcl (sb-debug::backtrace)
#+:clisp (system::print-backtrace)
(format *error-output* "~&~A~&" condition))))
(defun initialize-manager (display root-window)
;; ICCCM section 2.8
(setf +xa-wm+ (format nil "WM_S~A" (xlib:display-display display)))
(xlib:intern-atom display +xa-wm+)
(let ((managing-since)
(old-wm (xlib:selection-owner display +xa-wm+))
(manager (xlib:create-window :parent root-window
:override-redirect :on
:width 1 :height 1
:x 0 :y 0)))
(declare (type xlib:window manager))
(declare (type (or null xlib:window) old-wm))
(when old-wm
(setf (xlib:window-event-mask old-wm) '(:structure-notify)))
;; Get a valid timestamp.
(with-event-mask (manager '(:property-change))
(xlib:change-property manager :wm_name '(0) :string 8)
(xlib:event-case (display :force-output-p t :discard-p t)
(:property-notify (window time)
(when (xlib:window-equal window manager) (setf managing-since time)))
(t nil)))
;; Ask for selection ownership, and wait for the old owner destruction.
(setf (xlib:selection-owner display +xa-wm+ managing-since) manager)
(when old-wm
(xlib:event-case (display :force-output-p t :discard-p t :timeout 10)
(:destroy-notify (window) (xlib:window-equal window old-wm))
(t nil)))
;; Are we the selection owner after all ?
(let ((owner (xlib:selection-owner display +xa-wm+)))
(declare (type (or null xlib:window) owner))
(unless (and owner (xlib:window-equal manager owner))
(error "ICCCM Error: failed to aquire selection ownership~%")))
;; Check if a non ICCCM complient window manager is not running.
(handler-case
(progn
(setf (xlib:window-event-mask root-window) +root-event-mask+)
(xlib:display-finish-output display))
(error () (error "Redirect error: another WM is running~%")))
;; Notify all the other X clients of the new manager.
(xlib:send-event root-window :client-message '(:structure-notify)
:window root-window
:type :MANAGER
:format 32
:data (list managing-since
(xlib:find-atom display +xa-wm+)
(xlib:window-id manager)))
(setf (xlib:window-event-mask manager) '(:property-change))
(make-instance 'standard-property-holder :window manager)))
(defun init-gnome-compliance (display window manager)
(gnome:intern-gnome-atom display)
(netwm:intern-atoms display)
(let ((first-desknum (current-vscreen window))
(nb-vs (number-of-virtual-screens window))
(srcw (screen-width)) (srch (screen-height)))
(xlib:with-server-grabbed (display)
(delete-properties window +netwm-protocol+)
(unless (< -1 first-desknum nb-vs) (setf first-desknum 0))
(setf (gnome:win-protocols window) +gnome-protocols+
(gnome:win-supporting-wm-check manager) manager
(gnome:win-supporting-wm-check window) manager
(gnome:win-workspace-count window) nb-vs
(gnome:win-workspace window) first-desknum)
(setf (netwm:net-supported window) +netwm-protocol+
(netwm:net-supporting-wm-check window) manager
(netwm:net-supporting-wm-check manager) manager
(netwm:net-wm-name manager) "eclipse"
(netwm:net-number-of-desktops window) nb-vs
(netwm:net-current-desktop window) first-desknum
(netwm:net-desktop-viewport window) (make-viewport-property nb-vs)
(netwm:net-desktop-geometry window) (list srcw srch)
(netwm:net-workarea window) (make-list nb-vs
:initial-element
(manager-commons:make-geometry-hint
:x 0 :y 0 :width srcw :height srch))
))))
(defun initialize (display-specification sm-client-id)
(multiple-value-bind (display screen)
(open-clx-display display-specification)
(let* ((colormap (xlib:screen-default-colormap screen))
(root-window (xlib:screen-root screen))
(manager (initialize-manager display root-window))
(menu-font (xlib:open-font display "fixed")))
(setf *display* display)
;; Specific for X display
(setf (xlib:display-error-handler display) #'default-handler
(xlib:display-after-function display) #'xlib:display-force-output)
(setf *root* (make-instance 'root :window root-window :manager manager)
*root-window* root-window
(root-default-cursor *root*) (get-x-cursor display :xc_left_ptr)
(root-sm-conn *root*) (connect-to-session-manager
display-specification sm-client-id))
;; init all gnome properties on root.
(init-gnome-compliance display root-window (widget-window manager))
(ppm:initialize colormap)
;; Eclipse globals vars.
(setf *black* (xlib:screen-black-pixel screen)
*white* (xlib:screen-white-pixel screen)
*background1* (xlib:alloc-color colormap *menu-color*)
*background2* (xlib:alloc-color colormap *menu-hilighted-color*)
*cursor-2* (get-x-cursor display :xc_fleur)
*gctxt* (xlib:create-gcontext :drawable root-window :font menu-font)
*max-char-width* (xlib:max-char-width menu-font)
*gcontext* (xlib:create-gcontext
:drawable root-window
:foreground *white* :background *black*
:fill-style :solid :line-style :solid
:line-width 1 :exposures :OFF))
;; load personal configuration file, or the default one.
(labels ((load-if (f) (and (file-exists-p f) (load-config-file f))))
(or (load-if (home-subdirectory cl-user::*eclipse-initfile*))
(load-if (eclipse-path "eclipserc"))
(error "Unable to read a configuration file.~%")))
(setf (xlib:window-cursor root-window) (root-default-cursor *root*))
(setf (slot-value *root* 'gcontext) *gcontext*)
(unless (xlib:gcontext-font *gcontext*)
(setf (font-name) +default-font-name+))
(unless (root-decoration-theme *root*)
(setf (decoration-theme) "microGUI")))))
(defun eclipse (&key display sm-client-id die-on-init-error activate-log)
"Starts the Eclipse window manager.
- :display (or null string): if given it is expected it respects the
standard X DISPLAY specification: hostname:displaynumber.screennumber
(for more about the display string format see the X manual page).
If NIL then the DISPLAY environment variable will be used.
- :sm-client-id (or null string): if Eclipse is restarted from a previous
session, should contain the previous client-id of that previous session.
If :sm-client-id is specified, but is determined to be invalid by the
session manager, we will re-register the client with a sm-client-id set
to NIL. If the client is first joining the session :sm-client-id can be
NIL (default) or the empty string.
- :die-on-init-error (boolean): indicates if Eclipse should prevent
from debugger or not during initialisation phase.
- :activate-log (boolean): indicates if errors should be logged.
If T then errors will be logged in a file named: eclipse-yyyy-mm-dd.log
If neither the DISPLAY environment variable is defined nor the :display
argument is defined then Eclipse will not be able to starts."
(declare (type (or null string) display sm-client-id))
(declare (type boolean activate-log die-on-init-error))
(when *display*
(xlib:close-display *display*)
(setf *display* nil))
(if die-on-init-error
(handler-case (initialize display sm-client-id)
(error (condition)
(format *error-output* "~A~%" condition)
(quit)))
(initialize display sm-client-id))
(when activate-log
(init-log-file))
;; This is for releasing any previous pointer grab.
(ignore-errors
(grab-root-pointer)
(xlib:display-finish-output *display*))
(xlib:ungrab-pointer *display*)
;; Create a socket connection to communicate with the window manager.
;; Works only for CMUCL -x86- (unless you compile this mp package).
#+:mp (progn
(setf mp::*idle-process* mp::*initial-process*)
(mp::start-lisp-connection-listener :port 6789 :password "clara"))
(unwind-protect
(handler-case (eclipse-internal-loop)
(end-of-file (c) (handle-end-of-file-condition c)))
(ignore-errors (xlib:close-display *display*))
(format t "Eclipse exited. Bye.~%")
(quit)))