Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
eclipse
eclipse
Commits
276e0cd8
Commit
276e0cd8
authored
Apr 25, 2008
by
Iban Hatchondo
Browse files
Fix: hacking around *root-window* ...
parent
3d01339b
Changes
7
Hide whitespace changes
Inline
Side-by-side
eclipse.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: eclipse.lisp,v 1.2
5
200
6
/0
1/14 15:40:55
ihatchondo Exp $
;;; $Id: eclipse.lisp,v 1.2
6
200
7
/0
5/08 22:33:17
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2002 Iban HATCHONDO
...
...
@@ -129,7 +129,7 @@
(
let
((
first-desknum
(
current-vscreen
window
))
(
nb-vs
(
number-of-virtual-screens
window
))
(
srcw
(
screen-width
))
(
srch
(
screen-height
)))
(
xlib:with-server-grabbed
(
*
display
*
)
(
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+
...
...
@@ -166,7 +166,7 @@
(
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-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.
...
...
@@ -177,7 +177,7 @@
*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
)
*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
...
...
global.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: global.lisp,v 1.
29
200
5
/0
3/01 22:41:31
ihatchondo Exp $
;;; $Id: global.lisp,v 1.
30
200
8
/0
4/23 09:54:46
ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
...
...
@@ -119,17 +119,20 @@
(
defsetf
decoration-theme
(
&key
free-old-theme-p
)
(
name
)
"Sets the theme that must be used for window decoration. This theme will
be used for all existing applications as well as futur one."
`
(
with-slots
(
decoration-theme
)
*root*
(
let
((
theme
(
load-theme
*root-window*
,
name
)))
(
when
decoration-theme
(
loop
with
old-name
=
(
theme-name
decoration-theme
)
for
val
being
each
hash-value
in
*widget-table*
when
(
and
(
application-p
val
)
(
application-master
val
))
do
(
with-slots
(
window
master
)
val
`
(
set-decoration-theme
,
name
,
free-old-theme-p
))
(
defun
set-decoration-theme
(
name
free-old-theme-p
)
(
with-slots
(
decoration-theme
window
)
*root*
(
let
((
theme
(
load-theme
window
name
)))
(
when
decoration-theme
(
loop
with
old-name
=
(
theme-name
decoration-theme
)
for
val
being
each
hash-value
in
*widget-table*
when
(
and
(
application-p
val
)
(
application-master
val
))
do
(
with-slots
(
window
master
)
val
(
setf
(
decoration-frame-style
master
)
(
find-decoration-frame-style
theme
window
)))
finally
(
and
,
free-old-theme-p
(
free-theme
old-name
))))
(
setf
decoration-theme
theme
))))
finally
(
and
free-old-theme-p
(
free-theme
old-name
))))
(
setf
decoration-theme
theme
))))
(
defsetf
maximize-modifier
()
(
modifier-key
)
"Sets the modifier to use to activate window maximization second behavior."
...
...
input.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.4
7
200
7
/0
5/07 13:22:50
ihatchondo Exp $
;;; $Id: input.lisp,v 1.4
8
200
8
/0
4/23 09:54:46
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -90,7 +90,8 @@
(
when
(
or
(
decoration-p
widget
)
(
application-p
(
lookup-widget
window
)))
(
if
(
eq
*focus-type*
:on-click
)
(
give-focus-to-next-widget-in-desktop
)
(
multiple-value-bind
(
x
y
s
child
)
(
xlib:query-pointer
*root-window*
)
(
multiple-value-bind
(
x
y
s
child
)
(
xlib:query-pointer
(
xlib:drawable-root
window
))
(
declare
(
ignore
x
y
s
))
(
let
((
e
(
make-event
:enter-notify
:kind
:nonlinear
:mode
:normal
)))
(
event-process
e
(
or
(
lookup-widget
child
)
*root*
))))))))
...
...
@@ -316,7 +317,7 @@
(
with-slots
(
master
window
)
application
(
unless
(
eql
(
event-mode
event
)
:grab
)
(
when
master
(
dispatch-repaint
master
:focus
t
))
(
setf
(
netwm:net-active-window
*
root
-
window
*
)
window
)
(
setf
(
netwm:net-active-window
(
xlib:drawable-
root
window
)
)
window
)
(
xlib:delete-property
(
widget-window
(
root-property-holder
*root*
))
:_net_active_window
))))
...
...
misc.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.4
0
200
7/11/02 09:33:08
ihatchondo Exp $
;;; $Id: misc.lisp,v 1.4
1
200
8/04/23 09:54:46
ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
...
...
@@ -91,14 +91,16 @@
(
defsetf
wm-state
(
window
&key
(
icon-id
0
))
(
state
)
"Sets the wm_state property of a window. Note that its _net_wm_state property
will be updated accordingly to the value given for the wm_state."
(
let
((
net-wm-state
(
gensym
)))
`
(
let
((
,
net-wm-state
(
netwm:net-wm-state
,
window
)))
(
if
(
or
(
=
,
state
3
)
(
=
,
state
0
))
(
pushnew
:_net_wm_state_hidden
,
net-wm-state
)
(
setf
,
net-wm-state
(
delete
:_net_wm_state_hidden
,
net-wm-state
)))
(
setf
(
netwm:net-wm-state
,
window
)
,
net-wm-state
)
(
xlib:change-property
,
window
:WM_STATE
(
list
,
state
,
icon-id
)
(
with-gensym
(
_window
_state
_net-wm-state
)
`
(
let*
((
,
_window
,
window
)
(
,
_state
,
state
)
(
,
_net-wm-state
(
netwm:net-wm-state
,
_window
)))
(
if
(
or
(
=
,
_state
3
)
(
=
,
_state
0
))
(
pushnew
:_net_wm_state_hidden
,
_net-wm-state
)
(
setf
,
_net-wm-state
(
delete
:_net_wm_state_hidden
,
_net-wm-state
)))
(
setf
(
netwm:net-wm-state
,
_window
)
,
_net-wm-state
)
(
xlib:change-property
,
_window
:WM_STATE
(
list
,
_state
,
icon-id
)
:WM_STATE
32
))))
...
...
@@ -107,12 +109,12 @@
between _net_wm_desktop_names and _win_workspace_names respectively."
(
or
(
netwm:net-desktop-names
window
)
(
gnome:win-workspace-names
window
)))
(
defsetf
workspace-names
()
(
names
)
(
defsetf
workspace-names
(
window
)
(
names
)
"Sets both the _win_workspace_names and the _net_wm_desktop_names properties
to the given list of name."
`
(
when
,
names
(
setf
(
netwm:net-desktop-names
*root-
window
*
)
,
names
(
gnome:win-workspace-names
*root-
window
*
)
,
names
)))
(
setf
(
netwm:net-desktop-names
,
window
)
,
names
(
gnome:win-workspace-names
,
window
)
,
names
)))
(
defun
wm-name
(
window
)
"Returns the name of the window according to the first property that is set
...
...
move-resize.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: move-resize.lisp,v 1.1
7
200
4
/0
8/20 21:51:08
ihatchondo Exp $
;;; $Id: move-resize.lisp,v 1.1
8
200
5
/0
1/17 09:30:40
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -31,9 +31,9 @@
(
when
*geometry-info-box*
(
xlib:unmap-window
(
widget-window
*geometry-info-box*
))))
(
defun
initialize-geometry-info-box
()
(
defun
initialize-geometry-info-box
(
parent-window
)
(
unless
*geometry-info-box*
(
setf
*geometry-info-box*
(
create-message-box
nil
:parent
*roo
t-window
*
)))
(
setf
*geometry-info-box*
(
create-message-box
nil
:parent
paren
t-window
)))
(
with-slots
(
window
)
*geometry-info-box*
(
xlib:map-window
window
)
(
setf
(
xlib:window-priority
window
)
:above
)))
...
...
@@ -59,9 +59,9 @@
(
defparameter
*clone*
nil
)
(
defun
initialize-clone
()
(
defun
initialize-clone
(
parent-window
)
(
let
((
win
(
xlib:create-window
:parent
*roo
t-window
*
:x
0
:y
0
:width
100
:height
100
)))
:parent
paren
t-window
:x
0
:y
0
:width
100
:height
100
)))
(
setf
*clone*
(
make-decoration
win
(
create-application
win
nil
)))))
(
defun
update-*clone*
(
x
y
w
h
decoration-frame-style
&optional
wm-hints
)
...
...
@@ -96,13 +96,13 @@
(
with-slots
(
resize-status
move-status
current-active-widget
window
)
root
(
with-slots
((
widget-window
window
)
gcontext
active-p
)
widget
(
when
(
and
active-p
(
not
(
or
resize-status
move-status
)))
(
or
*clone*
(
initialize-clone
))
(
or
*clone*
(
initialize-clone
window
))
(
update-clone
widget
)
(
grab-root-pointer
)
(
setf
(
slot-value
root
status
)
t
current-active-widget
widget
)
(
when
verbose-p
(
initialize-geometry-info-box
)
(
initialize-geometry-info-box
window
)
(
multiple-value-bind
(
x
y
w
h
)
(
window-geometry
widget-window
)
(
if
(
and
(
eq
status
'resize-status
)
(
decoration-p
widget
))
(
multiple-value-bind
(
a
b
c
d
iw
ih
bw
bh
)
...
...
@@ -255,7 +255,8 @@
;; called when button-release on root and root-resize-status is not nil.
(
with-slots
(
window
gcontext
)
master
(
when
(
and
(
decoration-active-p
master
)
(
eql
mode
:box
))
(
draw-window-grid
(
widget-window
*clone*
)
gcontext
*root-window*
)
(
draw-window-grid
(
widget-window
*clone*
)
gcontext
(
xlib:drawable-root
window
))
(
multiple-value-bind
(
x
y
w
h
)
(
window-geometry
(
widget-window
*clone*
))
(
setf
(
window-position
window
)
(
values
x
y
)
...
...
@@ -296,9 +297,10 @@
(
update-edges-geometry
master
)
(
resize-from
master
))
(
with-slots
(
window
gcontext
)
*clone*
(
draw-window-grid
window
gcontext
*root-window*
)
(
resize-internal
*clone*
event
verbose-p
)
(
draw-window-grid
window
gcontext
*root-window*
))))
(
let
((
root-window
(
xlib:drawable-root
window
)))
(
draw-window-grid
window
gcontext
root-window
)
(
resize-internal
*clone*
event
verbose-p
)
(
draw-window-grid
window
gcontext
root-window
)))))
;;;; Move.
...
...
@@ -403,10 +405,11 @@
(
when
verbose-p
(
display-coordinates
new-x
new-y
))
(
if
(
and
(
or
(
decoration-p
widget
)
(
application-p
widget
))
(
eql
mode
:box
))
(
with-slots
(
window
)
*clone*
(
draw-window-grid
window
gcontext
*root-window*
)
(
setf
(
window-position
window
)
(
values
new-x
new-y
))
(
draw-window-grid
window
gcontext
*root-window*
))
(
with-slots
(
window
)
*clone*
(
let
((
root-window
(
xlib:drawable-root
window
)))
(
draw-window-grid
window
gcontext
root-window
)
(
setf
(
window-position
window
)
(
values
new-x
new-y
))
(
draw-window-grid
window
gcontext
root-window
)))
(
setf
(
window-position
window
)
(
values
new-x
new-y
)))))))
(
defun
finish-move
(
widget
&optional
verbose-p
mode
)
...
...
@@ -414,7 +417,7 @@
(
with-slots
((
widget-window
window
)
active-p
)
widget
(
when
(
eql
mode
:box
)
(
with-slots
(
window
gcontext
)
*clone*
(
draw-window-grid
window
gcontext
*
root
-
window
*
)
(
draw-window-grid
window
gcontext
(
xlib:drawable-
root
window
)
)
(
setf
(
window-position
widget-window
)
(
window-position
window
))))
(
setf
active-p
nil
)
(
when
verbose-p
(
undraw-geometry-info-box
)))
...
...
widgets.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.5
3
2008/04/2
4
08:
2
4:4
5
ihatchondo Exp $
;;; $Id: widgets.lisp,v 1.5
4
2008/04/2
5
08:4
2
:4
4
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -400,7 +400,7 @@
(
setf
(
netwm:net-wm-state
window
)
prop
))
(
if
(
eq
mode
:on
)
;; put in fullscreen mode.
(
with-event-mask
(
*
root
-
window
*
)
(
with-event-mask
(
(
xlib:drawable-
root
window
)
)
(
multiple-value-bind
(
x
y
w
h
)
(
window-geometry
window
)
(
when
master
(
with-slots
(
children
(
master-win
window
)
frame-style
)
master
...
...
@@ -414,7 +414,7 @@
(
configure-window
window
:x
x
:y
y
:width
w
:height
h
))
(
focus-widget
application
0
))
;; revert: restore precedent geometry and decoration style.
(
with-event-mask
(
*
root
-
window
*
)
(
with-event-mask
(
(
xlib:drawable-
root
window
)
)
(
setf
(
drawable-sizes
window
)
(
geometry-sizes
fgeometry
))
(
unless
(
window-not-decorable-p
window
)
(
setf
(
decoration-frame-style
master
)
...
...
@@ -440,7 +440,7 @@
(
with-slots
(
master
window
)
application
(
when
(
shaded-p
application
)
(
shade
application
))
(
setf
(
window-desktop-num
window
)
new-screen-number
)
(
with-event-mask
(
*
root
-
window
*
)
(
with-event-mask
(
(
xlib:drawable-
root
window
)
)
(
let
((
master-window
(
when
master
(
widget-window
master
))))
(
funcall
operation
(
or
master-window
window
))
(
when
master-window
...
...
@@ -457,10 +457,11 @@
"Removes all decoration of this application widget and reparent it to root."
(
with-slots
(
window
master
icon
)
application
(
if
master
(
multiple-value-bind
(
x
y
)
(
xlib:translate-coordinates
window
0
0
*root-window*
)
(
xlib:reparent-window
window
*root-window*
x
y
)
(
event-process
(
make-event
:destroy-notify
)
master
))
(
let
((
root-window
(
xlib:drawable-root
window
)))
(
multiple-value-bind
(
x
y
)
(
xlib:translate-coordinates
window
0
0
root-window
)
(
xlib:reparent-window
window
root-window
x
y
)
(
event-process
(
make-event
:destroy-notify
)
master
)))
(
event-process
(
make-event
:destroy-notify
:window
window
)
*root*
))
(
when
state
(
setf
(
wm-state
window
)
state
)
...
...
@@ -823,7 +824,7 @@
(
setf
bkgrd
pix
))))
(
setf
icon
(
create-button
'icon
:event-mask
'
(
:pointer-motion-hint
.
#.
+std-button-mask+
)
:parent
*
root
-
window
*
:master
master
:parent
(
xlib:drawable-
root
window
)
:master
master
:x
0
:y
0
:width
width
:height
height
:item
(
unless
bkgrd
(
wm-icon-name
window
))
:background
(
or
bkgrd
bg-color
)))
...
...
wm.lisp
View file @
276e0cd8
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.5
3
2008/04/2
3
0
9:54
:4
6
ihatchondo Exp $
;;; $Id: wm.lisp,v 1.5
4
2008/04/2
5
0
8:42
:4
5
ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
...
...
@@ -362,16 +362,16 @@
(
setf
(
drawable-sizes
window
)
(
values
(
max
1
(
-
width
hm
))
(
max
1
(
-
height
vm
))))))))
(
defun
initial-coordinates
(
app-
window
frame-style
)
(
defun
initial-coordinates
(
window
frame-style
)
"Returns as multiple values the decoration initial coordinates."
(
let
((
hint
(
ignore-errors
(
xlib:wm-normal-hints
app-
window
))))
(
let
((
hint
(
ignore-errors
(
xlib:wm-normal-hints
window
))))
(
with-slots
(
top-margin
left-margin
vmargin
hmargin
)
frame-style
(
flet
((
default-coordinates
()
(
let*
((
n
(
or
(
window-desktop-num
app-
window
)
0
))
(
let*
((
n
(
or
(
window-desktop-num
window
)
0
))
(
k
(
if
(
=
+any-desktop+
n
)
0
(
*
4
n
)))
(
areas
(
netwm:net-workarea
*
root
-
window
*
))
(
areas
(
netwm:net-workarea
(
xlib:drawable-
root
window
)
))
(
ax
(
aref
areas
k
))
(
ay
(
aref
areas
(
1+
k
))))
(
multiple-value-bind
(
x
y
)
(
window-position
app-
window
)
(
multiple-value-bind
(
x
y
)
(
window-position
window
)
(
values
(
max
ax
(
-
x
left-margin
))
(
max
ay
(
-
y
top-margin
)))))))
(
if
(
and
hint
(
xlib:wm-size-hints-user-specified-position-p
hint
))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment