scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- added root-drop 

- added thread names
This commit is contained in:
frese 2003-04-01 13:17:22 +00:00
parent 0e78046101
commit b909da1e5f
4 changed files with 59 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/move-wm-resizer.scm
View File

@ -215,9 +215,3 @@
(if (null? matches)
'none
(car (car matches)))))))
(define (point-in-rectangle? r x y)
(and (>= x (rectangle:x r))
(>= y (rectangle:y r))
(< x (+ (rectangle:x r) (rectangle:width r)))
(< y (+ (rectangle:y r) (rectangle:height r)))))

21
src/move-wm.scm
View File

@ -1,6 +1,6 @@
(define-options-spec move-wm-options-spec
(titlebar-colors colors '("#aaaaaa" "#eeeeee" "#777777" "black"))
(titlebar-colors-active colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
(titlebar-colors-focused colors '("#666699" "#aaaacc" "#333366" "#eeeeee"))
(titlebar-height int 18)
(titlebar-style symbol 'flat)
(font font "-*-helvetica-medium-r-normal-*-12-*-*-*-*-*-*-*")
@ -52,7 +52,7 @@
(dpy (wm:dpy wm))
(window (client:window client))
(state (if (window-contains-focus? dpy window)
'active
'focused
'normal))
(titlebar (car (client:data client)))
(name (client-name (wm:dpy wm) client)))
@ -90,9 +90,18 @@
(lambda (msg)
(case (car msg)
((drop)
;; TODO: check if outside...
;; check if outside...
(let ((window-x (second msg))
(window-y (third msg))
(root-x (fourth msg))
(root-y (fifth msg)))
(let ((r (root-rectangle dpy (wm:window wm))))
(if (point-in-rectangle? r root-x root-y)
(move-window dpy (client:client-window client)
(second msg) (third msg)))
window-x window-y)
(send (wm:out-channel wm)
(list 'root-drop (client:window client)
root-x root-y))))))
((kill-client)
(let ((time (second msg)))
(delete-window dpy (client:window client) time)))))))
@ -112,9 +121,9 @@
(list (cons 'normal-colors
(get-option options 'titlebar-colors))
(cons 'active-colors
(get-option options'titlebar-colors-active))
(get-option options'titlebar-colors-focused))
(cons 'focused-colors
(get-option options 'titlebar-colors-active))
(get-option options 'titlebar-colors-focused))
(cons 'border-style
(get-option options 'titlebar-style))))))

11
src/titlebar.scm
View File

@ -30,6 +30,7 @@
)
(mdisplay "creating titlebar " window "\n")
(spawn*
(list "titlebar " window)
(lambda (release)
(call-with-event-channel
dpy window (event-mask exposure structure-notify)
@ -43,7 +44,8 @@
(lambda (xevent)
(cond
((expose-event? xevent)
(if (= 0 (expose-event-count xevent))
(if (and (= 0 (expose-event-count xevent))
(window-exists? dpy window))
(draw-titlebar tb options gc)))
((destroy-window-event? xevent)
(exit)))))
@ -52,14 +54,15 @@
(case (car msg)
((title)
(set-titlebar:title! tb (cdr msg))
(invalidate-window dpy window))
(draw-titlebar tb options gc))
((state)
(set-titlebar:state! tb (cdr msg))
(invalidate-window dpy window)))))
(draw-titlebar tb options gc)))))
)
(loop))))))
(free-gc dpy gc)
(free-options options)))
;; colormap might to exists anymore...
(free-options options #t)))
tb))
(define (destroy-titlebar tb)

41
src/utils.scm
View File

@ -29,11 +29,20 @@
(define (sync-point-wait sp)
(placeholder-value sp))
(define (spawn* fun)
(define (spawn* id . fun)
(let ((id (if (null? fun) "unnamed" id))
(fun (if (null? fun) id (car fun))))
(let ((sp (make-sync-point)))
(spawn (lambda ()
(fun (lambda () (sync-point-release sp)))))
(sync-point-wait sp)))
(with-handler
(lambda (condition punt)
(mdisplay "condition in " id ":\n " condition "\n")
(punt))
(lambda ()
(fun (lambda () (sync-point-release sp)))
(mdisplay "thread " id " returned\n")
))))
(sync-point-wait sp))))
(define (with-lock lock thunk)
(obtain-lock lock)
@ -76,7 +85,7 @@
(type (assq/false name (options:type-alist options))))
(cond
((eq? (option-type font) type)
(unload-font (options:dpy options) value))
(free-font (options:dpy options) value))
((eq? (option-type color) type)
(free-colors (options:dpy options) (options:colormap options)
(list value) 0))
@ -338,9 +347,6 @@
(define (maximize-window dpy window . maybe-parent)
(let ((r (apply maximal-rect/hints dpy window maybe-parent)))
(mdisplay "maximize-window: " window " "
(rectangle:x r) " " (rectangle:y r) " "
(rectangle:width r) " " (rectangle:height r) "\n")
(move-resize-window dpy window (rectangle:x r) (rectangle:y r)
(rectangle:width r) (rectangle:height r))))
@ -462,3 +468,24 @@
;; result ********************************************************
(cons width height)))
(define (point-in-rectangle? r x y)
(and (>= x (rectangle:x r))
(>= y (rectangle:y r))
(< x (+ (rectangle:x r) (rectangle:width r)))
(< y (+ (rectangle:y r) (rectangle:height r)))))
(define (window-level dpy win)
(length (window-path dpy win)))
(define (with-prevent-events dpy window event-mask thunk)
(let* ((before (window-attribute:your-event-mask
(get-window-attributes dpy window)))
(new (enum-set-intersection before
(enum-set-negation event-mask))))
(dynamic-wind
(lambda ()
(display-select-input dpy window new))
thunk
(lambda ()
(display-select-input dpy window before)))))