diff options
author | Geert Bevin <gbevin@gentoo.org> | 2002-02-17 16:15:06 +0000 |
---|---|---|
committer | Geert Bevin <gbevin@gentoo.org> | 2002-02-17 16:15:06 +0000 |
commit | ab58242ca931971058d0a9a90f4966cae8601d8c (patch) | |
tree | 0819e1460ccb5fec394b2d25904494dacf3cc729 /x11-wm/sawfish-merlin | |
parent | typeo (diff) | |
download | gentoo-2-ab58242ca931971058d0a9a90f4966cae8601d8c.tar.gz gentoo-2-ab58242ca931971058d0a9a90f4966cae8601d8c.tar.bz2 gentoo-2-ab58242ca931971058d0a9a90f4966cae8601d8c.zip |
Initial release of the sawfish extensions for sawfish.
Diffstat (limited to 'x11-wm/sawfish-merlin')
22 files changed, 7172 insertions, 0 deletions
diff --git a/x11-wm/sawfish-merlin/ChangeLog b/x11-wm/sawfish-merlin/ChangeLog new file mode 100644 index 000000000000..82780c7351bf --- /dev/null +++ b/x11-wm/sawfish-merlin/ChangeLog @@ -0,0 +1,12 @@ +# ChangeLog for x11-wm/sawfish +# Copyright 2002 Gentoo Technologies, Inc.; Distributed under the GPL +# $Header: /var/cvsroot/gentoo-x86/x11-wm/sawfish-merlin/ChangeLog,v 1.1 2002/02/17 16:15:06 gbevin Exp $ + +*sawfish-merlin-1.0.1 (17 Feb 2002) + + 17 Feb 2002; G.Bevin <gbevin@gentoo.org> : + + Seperate package to install the sawfish merlin patches. The required config + files for every user have been installed to /etc/skel. Already existing + users should copy .sawfishrc and .sawfish from /etc/skel to their home + directory before being able to use these merlin extensions. diff --git a/x11-wm/sawfish-merlin/files/digest-sawfish-1.0.1 b/x11-wm/sawfish-merlin/files/digest-sawfish-1.0.1 new file mode 100644 index 000000000000..d96f5e8b0fc8 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/digest-sawfish-1.0.1 @@ -0,0 +1 @@ +MD5 b1587ea76cca08ec951f2536c17a307e sawfish-1.0.1.tar.gz 1327104 diff --git a/x11-wm/sawfish-merlin/files/digest-sawfish-merlin-1.0.1 b/x11-wm/sawfish-merlin/files/digest-sawfish-merlin-1.0.1 new file mode 100644 index 000000000000..3592e2b26ab4 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/digest-sawfish-merlin-1.0.1 @@ -0,0 +1 @@ +MD5 b1587ea76cca08ec951f2536c17a307e sawfish-1.0.1.tar.gz 1326727 diff --git a/x11-wm/sawfish-merlin/files/gdm_session b/x11-wm/sawfish-merlin/files/gdm_session new file mode 100644 index 000000000000..f11cd44b35c5 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/gdm_session @@ -0,0 +1,3 @@ +#!/bin/sh --login +exec sawfish + diff --git a/x11-wm/sawfish-merlin/files/sawfish/custom b/x11-wm/sawfish-merlin/files/sawfish/custom new file mode 100644 index 000000000000..a8dc890f49ec --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/custom @@ -0,0 +1,38 @@ +;; sawfish user customization -- do not edit by hand! +;; sawfish version 1.0.1, written Thu Jan 24 07:31:15 2002 + +(custom-set-typed-variable (quote match-window-profile) (quote ((((WM_CLASS . "^Sawlet/")) (avoid . t) (place-mode . sawlet) (depth . -16) (never-focus . t) (frame-type . none) (sticky . t) (sticky-viewport . t) (window-list-skip . t)) (((WM_CLASS . "^xmms/XMMS_Player$")) (avoid . t) (depth . 16) (sticky . t) (sticky-viewport . t)) (((WM_CLASS . "^Wine/wineManaged$")) (focus-mode . click)) (((WM_CLASS . "^GQmpeg/gqmpeg$")) (avoid . t) (ignore-program-position . t) (position 80 . 8) (depth . -16) (never-focus . t) (focus-click-through . t) (frame-type . none) (ignored . t) (sticky . t) (sticky-viewport . t) (cycle-skip . t) (window-list-skip . t) (ignore-stacking-requests . t)) (((WM_NAME . "^gkrellm$")) (avoid . t) (position 0 . 0) (depth . 16) (never-focus . t) (frame-type . none) (ignored . t) (sticky . t) (sticky-viewport . t) (cycle-skip . t) (window-list-skip . t)) (((WM_CLASS . "^Sawlet/clock$")) (avoid . t) (never-focus . t) (frame-type . none) (ignored . t) (cycle-skip . t) (window-list-skip . t) (skip-tasklist . t)) (((WM_CLASS . "^Sawlet/fishbowl$")) (avoid . t) (place-mode . none) (position 9 . 1) (depth . -16) (frame-type . none) (ignored . t) (sticky . t) (sticky-viewport . t) (cycle-skip . t) (window-list-skip . t) (skip-tasklist . t)) (((WM_CLASS . "^Sawlet/iconbox$")) (avoid . t) (never-focus . t) (frame-type . none) (ignored . t) (cycle-skip . t) (window-list-skip . t) (skip-tasklist . t)) (((WM_CLASS . "^Sawlet/pager$")) (avoid . t) (never-focus . t) (frame-type . none) (ignored . t) (cycle-skip . t) (window-list-skip . t) (skip-tasklist . t)))) (quote match-window) (quote sawfish.wm.ext.match-window)) +(custom-set-typed-variable (quote merlin.sawlet:fishbowl:enabled) (quote ()) (quote boolean)) +(custom-set-typed-variable (quote merlin.sawlet:fishbowl:shrinkage) (quote (0 . 0)) (quote (pair (number 0 8) (number 0 8)))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:enabled) (quote t) (quote boolean)) +(custom-set-typed-variable (quote merlin.sawlet:fishbowl:border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:fishbowl:spacing) (quote 1) (quote (number 0 8))) +(custom-set-typed-variable (quote merlin.sawlet:clock:enabled) (quote ()) (quote boolean)) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:fixed-height) (quote ()) (quote boolean)) +(custom-set-typed-variable (quote merlin.sawlet:pager:divisor) (quote (16 . 16)) (quote (pair (labelled "Horizontal:" (number 2 100)) (labelled "Vertical:" (number 2 100))))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:background) (quote "#d362d362d362") (quote color)) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:icon-color) (quote ("#000000000000" . "#b850ae13d47a")) (quote (pair (labelled "Foreground:" color) (labelled "Background:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:icon-border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:focused-icon-color) (quote ("#000000000000" . "#eb83f3319998")) (quote (pair (labelled "Foreground:" color) (labelled "Background:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:focused-icon-border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:viewport-background) (quote "#ffffffffffff") (quote color)) +(custom-set-typed-variable (quote merlin.sawlet:pager:win-color) (quote ("#000000000000" . "#b828aef2d362")) (quote (pair (labelled "Foreground:" color) (labelled "Background:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:win-border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:focused-win-color) (quote ("#000000000000" . "#ec43f26a9898")) (quote (pair (labelled "Foreground:" color) (labelled "Background:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:focused-win-border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:background) (quote "#d554d554d554") (quote color)) +(custom-set-typed-variable (quote merlin.sawlet:pager:viewport-border) (quote (1 . "#0000007d0129")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:iconbox:border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:pager:border) (quote (1 . "#000000000000")) (quote (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)))) +(custom-set-typed-variable (quote merlin.sawlet:default-placement:direction) (quote east) (quote (choice north east south west))) +(custom-set-typed-variable (quote merlin.sawlet:default-placement:origin) (quote south-west) (quote (choice north-west north-east south-east south-west))) +(custom-set-typed-variable (quote merlin.sawlet:clock:orientation) (quote horizontal) (quote (choice vertical horizontal))) +(custom-set-typed-variable (quote ugly-move-resize-vertical) (quote 0) (quote number)) +(custom-set-typed-variable (quote ugly-move-resize-horizontal) (quote 5) (quote number)) +(custom-set-typed-variable (quote ugly-move-resize-relative) (quote screen) (quote symbol)) +(custom-set-typed-variable (quote move-show-position) (quote t) (quote boolean)) +(custom-set-typed-variable (quote move-resize-raise-window) (quote t) (quote boolean)) +(custom-set-typed-variable (quote focus-mode) (quote enter-only) (quote symbol)) +(custom-set-typed-variable (quote tooltips-show-doc-strings) (quote ()) (quote boolean)) +(custom-set-typed-variable (quote warp-to-selected-windows) (quote ()) (quote boolean)) +(custom-set-typed-variable (quote cycle-warp-pointer) (quote ()) (quote boolean)) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/clock.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/clock.jl new file mode 100644 index 000000000000..034b89e28ae4 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/clock.jl @@ -0,0 +1,197 @@ +;; merlin/clock.jl -- a bad clock + +;; version -0.2 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv clock.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. + +;; You're probably best off unpacking the entire merlin.tgz archive. + +;; Then add to your .sawfishrc: +;; (require 'merlin.clock) +;; (defclock clock) + +;; Then restart sawfish. A clock should appear in the top left corner +;; of your screen. + +;; Go to Customize->Matched Windows->Sawlet/clock->Edit... +;; - Here you can specify a position for the window, border type, etc. +;; Also go to Customize->Sawlets->Clock +;; - Here you can customize the behaviour of the clock. + +;; You can create multiple clocks and can configure them programatically +;; at creation if you want.. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; one has to ask... why? + +;;;; + +(define-structure merlin.clock + (export + defclock) + + (open + rep + rep.regexp + rep.system + rep.io.timers + sawfish.wm.custom + sawfish.wm.fonts + sawfish.wm.images + sawfish.wm.misc + sawfish.wm.ext.tooltips + sawfish.wm.util.x + merlin.sawlet) + + ;; + + (define (dimensions clock) + (let ((dim (drawable-dimensions clock))) + (if (eq 'vertical (sawlet-config clock 'orientation)) + (cons (cdr dim) (car dim)) dim))) + + (define (drawable-dimensions clock) ; TODO: need XTextExtents... + (cons (sawlet-config clock 'breadth) + (+ (font-ascent (sawlet-config clock 'font)) 3))) ;; descent + + (define format-matches ; TODO: ignore %%evil + `(("%(c|Ec|r|s|S|OS|T|X|EX|\\+)" . 1) + ("%(M|OM|R)" . 60) + ("%(H|OH|I|OI|k|l)" . 3600))) + + (define (clock-granularity clock) + (let + ((format (sawlet-config clock 'format)) + (cache (sawlet-get clock 'granularity))) + (cdr (or (and (equal (car cache) format) cache) + (sawlet-put clock 'granularity + (cons + format + (catch 'out + (mapc (lambda (match) + (when (string-match (car match) format) + (throw 'out (cdr match)))) format-matches) + 86400))))))) + + (define (start clock) + (sawlet-put clock 'drawable + (x-create-pixmap (drawable-dimensions clock)) + x-destroy-drawable) + (timeout clock)) + + (define (stop clock) + (sawlet-put clock 'timer nil delete-timer) + (sawlet-put clock 'drawable nil x-destroy-drawable) + (sawlet-put clock 'image nil)) + + (define (expose-handler clock event) + (let + ((image (sawlet-get clock 'image)) + (window (sawlet-get clock 'window))) + (and image (x-draw-image image window (cons 0 0))))) + + (define (button-press-handler clock event)) + + (define (enter-notify-handler clock event) + (let ((tooltips-enabled t)) + (display-tooltip-after-delay (current-time-string) + (sawlet-frame clock)))) + + (define (timeout clock) + (let* + ((window (sawlet-get clock 'window)) + (drawable (sawlet-get clock 'drawable)) + (gc (sawlet-get clock 'gc)) + (font (sawlet-config clock 'font)) + (dims (drawable-dimensions clock)) + (background (sawlet-config clock 'background)) + (foreground (sawlet-config clock 'foreground)) + (time (current-time-string nil (sawlet-config clock 'format))) + (x (quotient (- (car dims) (text-width time font)) 2)) + (y (font-ascent font)) + (granularity (clock-granularity clock)) + image) + (x-change-gc gc `((foreground . ,background))) + (x-fill-rectangle drawable gc (cons 0 0) dims) + (x-change-gc gc `((foreground . ,foreground))) + (x-draw-string drawable gc (cons x y) time font) + (setq image (make-image-from-x-drawable (x-window-id drawable))) + (when (eq 'vertical (sawlet-config clock 'orientation)) + (flip-image-vertically image) + (flip-image-diagonally image)) + (sawlet-put clock 'image image) + (expose-handler clock nil) + ; TODO: figure out finer grained now to catch second change more accurately + (sawlet-put clock 'timer + (make-timer + (lambda () + (timeout clock)) + (- granularity (% (cdr (current-time)) granularity)) 0) delete-timer))) + + ;; + + (defmacro defclock (clock . keys) + `(progn + (require 'merlin.sawlet) + ,(append + `(defsawlet ,clock) + keys ; allow override + `(:start ,start + :stop ,stop + :pre-configure ,stop + :post-configure ,start + :dimensions ,dimensions + :expose-handler ,expose-handler + :button-press-handler ,button-press-handler + :enter-notify-handler ,enter-notify-handler + :defcustom (orientation 'vertical + "Orientation." + :type (choice vertical horizontal) + :after-set sawlet-reconfigure) + :defcustom (breadth 64 + "Breadth." + :type (number 1 1024) + :after-set sawlet-reconfigure) + :defcustom (format "%H:%M:%S" + "Display format." + :tooltip "Format (a text string containing escapes):\n %H = hour (00..23)\n %l = hour ( 1..12)\n %M = minute (00..59)\n %S = second (00..60)\n %y = year (00..99)\n %m = month (01..12)\n %d = day of month (01..31)\netc. (man 3 strftime)" + :type string + :after-set sawlet-reconfigure)))))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/fishbowl.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/fishbowl.jl new file mode 100644 index 000000000000..ead0e2d89c5a --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/fishbowl.jl @@ -0,0 +1,306 @@ +;; merlin/fishbowl.jl -- a bad fishbowl + +;; version -0.4.2 + +;; Copyright (C) 2000 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv fishbowl.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. + +;; You're probably best off unpacking the entire merlin.tgz archive. + +;; Then add to your .sawfishrc: +;; (require 'merlin.fishbowl) +;; (deffishbowl fishbowl) + +;; Then restart sawfish. A fishbowl should appear in the top right corner +;; of your screen (or wherever you have configured your sawlets). + +;; Go to Customize->Sawlets->Fishpond +;; - Here you can customize the behaviour of the fishbowl. In particuar, +;; use Shrinkage to configure that the the fishbowl should treat +;; fish as being smaller than they claim to be. This is useful +;; because most dockapps have transparent border space. + +;; Next, go to Customize->Matched Windows +;; - Here you must add a matched window setting for any fish that you +;; want captured to have Place mode fishbowl. You can also set +;; Placement weight to assert an order on the fish in the bolw; +;; currently they are ordered left-to-right, least weight first. + +;; Now, restart your apps. Hopefully they'll swim in the fishbowl. + +;; You can create multiple fishbowls and can configure them programatically +;; at creation if you want.. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; This is PRE-ALPHA INCOMPLETE SOFTWARE! + +;; this is a bit hacky! + +;; allow left/right/up/down placement, N columns/rows. + +;; I don't restore fish border width. + +;; the popup fishbowl window capture item seems to always capture +;; into 'fishbowl, not subsequent fishbowls that I define.. + +;; Ideally would do substructure redirect, so sawlets can't be +;; moved at all. + +;; TODO: lots of config stuff possible... + +;;;; + +(define-structure merlin.fishbowl + (export + deffishbowl + fishbowl-eject + popup-fishbowl-menu) + + (open + rep + rep.regexp + rep.system + rep.io.timers + sawfish.wm.colors + sawfish.wm.commands + sawfish.wm.events + sawfish.wm.fonts + sawfish.wm.frames + sawfish.wm.menus + sawfish.wm.placement + sawfish.wm.misc + sawfish.wm.stacking + sawfish.wm.windows + sawfish.wm.util.x + merlin.sawlet + merlin.util + merlin.x-util) + + ;; + + (define (dimensions fishbowl) + (let* + ((fishes (sawlet-get fishbowl 'fish)) + (shrinkage (sawlet-config fishbowl 'shrinkage)) + (spacing (sawlet-config fishbowl 'spacing)) + (dim (cons (- spacing) 0))) + (mapc + (lambda (fish) + (let ((d (cons- (cadr fish) (cons* shrinkage 2)))) + (rplaca dim (+ (car dim) (car d) spacing)) + (rplacd dim (max (cdr dim) (cdr d))))) + fishes) + (cons-max dim 4))) + + (define fishbowls nil) + + (define (start fishbowl) + (setq fishbowls (nconc fishbowls (list fishbowl))) + (mapc + (lambda (window) + (when (eq fishbowl (window-get window 'place-mode)) + (after-add-window-eye window))) + (managed-windows))) + + (define (mapfish thunk fishbowl) + (let* + ((shrinkage (sawlet-config fishbowl 'shrinkage)) + (spacing (sawlet-config fishbowl 'spacing)) + (pos (cons- shrinkage)) + (fishes (sawlet-get fishbowl 'fish))) + (mapc + (lambda (fish) + (thunk fish pos) + (rplaca pos (- (+ (car pos) spacing (caadr fish)) (* 2 (car shrinkage))))) + fishes))) + + (define (stop fishbowl) + (let* + ((base (window-position (sawlet-frame fishbowl)))) + (setq fishbowls (delq fishbowl fishbowls)) + (mapfish + (lambda (fish pos) + (x-reparent-window (car fish) nil (cons+ base pos)) + (x-map-request (car fish))) + fishbowl) + (sawlet-put fishbowl 'fish nil))) + + (define (capture fishbowl) + (let* + ((window (select-window))) + (when (and window (not (eq window (sawlet-frame fishbowl)))) + (window-put window 'place-mode fishbowl) + (after-add-window-eye window)))) + + (define (eject fishbowl id) + (let* + ((base (window-position (sawlet-frame fishbowl)))) + (mapfish + (lambda (fish pos) + (when (eq id (car fish)) + (sawlet-put fishbowl 'suspend t) + (x-reparent-window id nil (cons+ base pos)) + (x-map-request id) + (sawlet-put fishbowl 'suspend nil))) + fishbowl) + (sawlet-put fishbowl 'fish + (delete-if (lambda (fish) (eq id (car fish))) (sawlet-get fishbowl 'fish))) + (sawlet-reconfigure fishbowl))) + +(require 'rep.io.files) +(define (log a . rest) + (let ((file (open-file "/tmp/log" 'append))) + (format file "%s %s\n" a rest) + (close-file file))) + + (define (replace fishbowl) + (mapfish + (lambda (fish pos) + (x-configure-window (car fish) `((x . ,(car pos)) (y . ,(cdr pos))))) + fishbowl)) + + (define (place window)) + + (define (after-add-window-eye window) + (let* + ((fishbowl (window-get window 'place-mode))) + (when (and (memq fishbowl fishbowls) (not (sawlet-get fishbowl 'suspend))) + (let* + ((id (window-id window)) + (dim (window-dimensions window)) + (weight (or (window-get window 'placement-weight) -1)) + (fishes (cons nil (sawlet-get fishbowl 'fish)))) + (x-change-window-attributes id `((override-redirect . ,t))) + (x-map-notify id) ; this removes it from window-manager + (x-change-window-attributes id `((override-redirect . ,nil))) + (x-configure-window id `((border-width . 0))) + (x-reparent-window id (sawlet-get fishbowl 'window) (cons 0 0)) + (let loop ((rest fishes)) + (if (or (null (cdr rest)) (> (nth 2 (cadr rest)) weight)) + (rplacd rest (cons (list id dim weight) (cdr rest))) + (loop (cdr rest)))) + (sawlet-put fishbowl 'fish (cdr fishes)) + (sawlet-reconfigure fishbowl) + (x-x-map-window id))))) + + (add-hook 'after-add-window-hook after-add-window-eye) + + ;; + + (define (popup-fishbowl-menu window) + (let* + ((fishbowl (sawlet-from-frame window))) + (when (memq fishbowl fishbowls) + (popup-menu + `((,(_ "_Capture") ,(lambda () (capture fishbowl))) + (,(_ "_Eject") . + ,(mapcar + (lambda (fish) + (list (aref (x-get-text-property (car fish) 'WM_NAME) 0) + (lambda () (eject fishbowl (car fish))))) + (sawlet-get fishbowl 'fish)))))))) + + (define-command 'popup-fishbowl-menu popup-fishbowl-menu #:spec "%W") + + ;; + + ; if I do substructure redirect events on the parent + ; then this gets called instead of configure notify... + ; but default sawfish just does the configure anyway + ;;;; (define (configure-request-handler fishbowl event)) + + (define (configure-notify-handler fishbowl event) + (let + ((id (cdr (assq 'window event))) + (width (cdr (assq 'width event))) + (height (cdr (assq 'height event))) + (fishes (sawlet-get fishbowl 'fish))) + (mapc + (lambda (fish) + (when (and (equal id (nth 0 fish))) + (rplaca (cdr fish) (cons width height)) + (sawlet-reconfigure fishbowl))) fishes))) + + (define (destroy-notify-handler fishbowl event) + (let* + ((id (cdr (assq 'window event))) + (fishes (sawlet-get fishbowl 'fish))) + (sawlet-put fishbowl 'fish + (delete-if (lambda (fish) (eq id (car fish))) fishes)) + (sawlet-reconfigure fishbowl))) + + (define (expose-handler fishbowl event) ;; todo: draw tiles + internal bars + (x-clear-window (sawlet-get fishbowl 'window))) + + (define (button-press-handler fishbowl event) + (popup-fishbowl-menu (sawlet-frame fishbowl))) + + (define (pre fishbowl) + (define-placement-mode fishbowl place)) + + (defmacro deffishbowl (fishbowl . keys) + + `(progn + (require 'merlin.sawlet) + ,(append + `(defsawlet ,fishbowl + :pre ,pre) + keys ; allow override + `(:start ,start + :stop ,stop + :post-configure ,replace + :dimensions ,dimensions + :expose-handler ,expose-handler + :button-press-handler ,button-press-handler + :destroy-notify-handler ,destroy-notify-handler + :configure-notify-handler ,configure-notify-handler +;;;; :configure-request-handler ,configure-request-handler + :font ,nil + :foreground ,nil + :background ,(get-color-rgb 0 0 0) + :defcustom (shrinkage (cons 0 0) + "Shrinkage." + :type (pair (number 0 8) (number 0 8)) + :after-set sawlet-reconfigure) + :defcustom (spacing 4 + "Spacing." + :type (number 0 8) + :after-set sawlet-reconfigure) + ))))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/iconbox.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/iconbox.jl new file mode 100644 index 000000000000..05a571b9834b --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/iconbox.jl @@ -0,0 +1,465 @@ +;; merlin/iconbox.jl -- a bad icon manager + +;; version -0.98 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv iconbox.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. + +;; You're probably best off unpacking the entire merlin.tgz archive. + +;; Then add to your .sawfishrc: +;; (require 'merlin.iconbox) +;; (deficonbox iconbox) + +;; Then restart sawfish. An icon box should appear in the top right corner +;; of your screen. + +;; Go to Customize->Sawlets->Iconbox +;; - Here you can customize the behaviour of the icon box +;; Also go to Customize->Matched Windows->^Sawlet/iconbox$->Edit... +;; - Here you can specify a border type for the window, etc. + +;; You can create multiple icon boxes and can configure them programatically +;; at creation if you want.. but you probably don't.. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; TODO: Orientation, ... hover delay ..., tooltips, ... use icon name + +;; TODO: only display windows iconified on current viewport/workspace. + +;; TODO: support dragging into iconbox? + +; BUG: I don't understand why, but if you click then drag a fraction +; (preferably, but not necessarily to outside of the icon) then wait +; a while then containue the drag, nothing happens. but if you +; only wait a short while before continuing then it works. +; I don't get the events?? + +; Events are lost. But it is not me (I think). + +;;;; + +(define-structure merlin.iconbox + + (export + deficonbox) + + (open + rep + rep.system + rep.io.timers + sawfish.wm.colors + sawfish.wm.events + sawfish.wm.fonts + sawfish.wm.menus + sawfish.wm.misc + sawfish.wm.stacking + sawfish.wm.viewport + sawfish.wm.windows + sawfish.wm.workspace + sawfish.wm.commands.move-resize + sawfish.wm.ext.tooltips + sawfish.wm.state.iconify + sawfish.wm.util.display-window + sawfish.wm.util.x + merlin.sawlet + merlin.util + merlin.x-util) + + ;;;; + + (define (schedule iconbox window) + (sawlet-put iconbox 'hover-pending window) + (if (eq window (sawlet-get iconbox 'hover-window)) + (sawlet-put iconbox 'hover-timer nil delete-timer) + (sawlet-put iconbox 'hover-timer + (make-timer (lambda () (timeout iconbox)) 0 333) delete-timer))) + + (define (timeout iconbox) + (let ((hover (sawlet-get iconbox 'hover-window)) + (pending (sawlet-get iconbox 'hover-pending))) + (when hover + (when (equal (sawlet-get iconbox 'hover-new-position) + (window-position hover)) + (move-window-to hover (sawlet-get iconbox 'hover-old-x) + (sawlet-get iconbox 'hover-old-y))) + (restack-windows (sawlet-get iconbox 'hover-stacking)) ;; TODO: only really want to replace hover + (hide-window hover)) + (when (sawlet-put iconbox 'hover-window pending) + (sawlet-put iconbox 'hover-pending nil) + (sawlet-put iconbox 'hover-stacking (stacking-order)) + (let ((pos (window-position pending))) + (sawlet-put iconbox 'hover-old-x (car pos)) + (sawlet-put iconbox 'hover-old-y (cdr pos))) + (show-window pending) + (raise-window pending) + (when (window-outside-viewport-p pending) + (move-window-to-current-viewport pending)) + (sawlet-put iconbox 'hover-new-position (window-position pending)) + (call-hook 'enter-notify-hook (list pending 'normal))))) + + ;;;; + + (define (dimensions iconbox) + (let* + ((columns (sawlet-config iconbox 'icon-columns))) + (cons (* columns (sawlet-config iconbox 'icon-width)) + (if (sawlet-config iconbox 'fixed-height) + (sawlet-config iconbox 'height) + (* (max 1 (ceil (length (sawlet-get iconbox 'icons)) columns)) + (+ (font-height (sawlet-config iconbox 'icon-font)) + (* 2 (car (sawlet-config iconbox 'icon-border))))))))) + + (define (icon-foo iconbox icon foo) + (sawlet-config iconbox + (if (eq icon (sawlet-get iconbox 'focused-icon)) + (intern (format nil "focused-%s" foo)) + foo))) + + (define (icon-position iconbox icon) + (let + ((columns (sawlet-config iconbox 'icon-columns)) + (index (index-of icon (sawlet-get iconbox 'icons)))) + (cons (* (% index columns) (sawlet-config iconbox 'icon-width)) + (* (quotient index columns) + (+ (font-height (sawlet-config iconbox 'icon-font)) + (* 2 (car (sawlet-config iconbox 'icon-border)))))))) + + (define (icon-dimensions iconbox icon) ; ? use max heights ? + (cons- (cons (sawlet-config iconbox 'icon-width) + (+ (font-height (sawlet-config iconbox 'icon-font)) + (* 2 (car (sawlet-config iconbox 'icon-border))))) + (* 2 (car (icon-foo iconbox icon 'icon-border))))) + + (define (icon-reconfigure iconbox icon) + (let* + ((pos (icon-position iconbox icon)) + (dim (icon-dimensions iconbox icon)) + (border (icon-foo iconbox icon 'icon-border))) + (x-configure-window + icon + `((x . ,(car pos)) + (y . ,(cdr pos)) + (width . ,(car dim)) + (height . ,(cdr dim)) + (border-width . ,(car border)))) + (x-change-window-attributes + icon + `((background . ,(cdr (icon-foo iconbox icon 'icon-color))) + (border-color . ,(cdr border)))) + (icon-repaint iconbox icon))) + + (define (icon-repaint iconbox icon) + (let* + ((window (x-window-get icon 'window)) + (gc (sawlet-get iconbox 'gc)) + (title (window-name window)) + (font (icon-foo iconbox icon 'icon-font))) + (x-clear-window icon) + (x-change-gc gc `((foreground . ,(car (icon-foo iconbox icon 'icon-color))))) + (x-draw-string icon gc (cons 1 (font-ascent font)) title font))) + + (define (icon-button-press-handler iconbox event) + (let* + ((icon (cdr (assq 'window event))) + (window (x-window-get icon 'window)) + (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) + (button (cdr (assq 'button event)))) + (cond + ((eq button 'button-1) + (sawlet-put iconbox 'click-xy xy) + (sawlet-put iconbox 'click-window window)) + ((eq button 'button-3) + (current-event-window window) + (popup-window-menu window))))) + + (define (icon-motion-notify-handler iconbox event) + (let* + ((icon (cdr (assq 'window event))) + (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) + (oxy (or (sawlet-get 'iconbox 'click-xy) xy)) + (delta (cons- xy oxy)) + (bd (car (icon-foo iconbox icon 'icon-border))) + (nxy (cons- (query-pointer) oxy bd))) + (when (> (+cons (cons* delta delta)) 36) + (sawlet-put iconbox 'click-window nil + (lambda (w) + (when (eq w (sawlet-get iconbox 'hover-window)) + (sawlet-put iconbox 'hover-window nil)) + (when (eq w (sawlet-get iconbox 'hover-pending)) + (sawlet-put iconbox 'hover-pending nil) + (sawlet-put iconbox 'hover-timer nil delete-timer)) + (unless (window-appears-in-workspace-p w current-workspace) + (move-window-to-workspace w + (nearest-workspace-with-window w current-workspace) + current-workspace)) + (move-window-to w (car nxy) (cdr nxy)) + (uniconify-window w) + (setq move-window-initial-pointer-offset (cons+ oxy bd)) + (move-window-interactively w)))))) + + (define (icon-button-release-handler iconbox event) + (let* + ((button (cdr (assq 'button event)))) + (cond + ((eq button 'button-1) + (sawlet-put iconbox 'click-window nil display-window))))) + + (define (icon-enter-notify-handler iconbox event) + (let* + ((icon (cdr (assq 'window event))) + (window (x-window-get icon 'window))) + (sawlet-put iconbox 'focused-icon icon) + (icon-reconfigure iconbox icon) + (when (sawlet-config iconbox 'hover-show) + (schedule iconbox window) + (when (eq window (sawlet-get iconbox 'hover-window)) + (call-hook 'enter-notify-hook (list window 'normal)))))) + + (define (icon-leave-notify-handler iconbox event) + (let* + ((icon (cdr (assq 'window event))) + (window (x-window-get icon 'window))) + (sawlet-put iconbox 'focused-icon nil) + (icon-reconfigure iconbox icon) + (schedule iconbox nil) + (when (eq window (sawlet-get iconbox 'hover-window)) + (call-hook 'leave-notify-hook (list window 'normal))))) + + (define (icon-expose-handler iconbox event) + (icon-repaint iconbox (cdr (assq 'window event)))) + + (define icon-event-handlers + `((button-press . ,icon-button-press-handler) + (motion-notify . ,icon-motion-notify-handler) + (button-release . ,icon-button-release-handler) + (enter-notify . ,icon-enter-notify-handler) + (leave-notify . ,icon-leave-notify-handler) + (expose . ,icon-expose-handler))) + + (define (icon-event-handler type window event) + (let + ((handler (assq type icon-event-handlers))) + (when handler + ((cdr handler) (x-window-get window 'sawlet) event)))) + + ;;;; + + (define (after-add-window-eye iconbox window) + (when (window-get window 'iconified) + (iconify-window-eye iconbox window))) + + (define (iconify-window-eye iconbox window) + (unless (not (window-mapped-p window)) + (let* + ((icon (x-create-window + (cons 1024 1024) + (cons 16 16) + 0 + `((parent . ,(sawlet-get iconbox 'window)) + (override-redirect . t) + (event-mask . (button-press button-motion button-release + enter-window leave-window exposure))) + icon-event-handler))) + (x-window-put icon 'sawlet iconbox) + (x-window-put icon 'window window) + (window-put window (sawlet-symbol iconbox 'icon) icon) + (sawlet-put iconbox 'icons (nconc (sawlet-get iconbox 'icons) (list icon))) + (x-x-map-window icon) + (sawlet-reconfigure iconbox)))) + + (define (uniconify-window-eye iconbox window) + (when (or (eq window (sawlet-get iconbox 'hover-window)) + (eq window (sawlet-get iconbox 'hover-pending))) + (sawlet-put iconbox 'hover-timer nil delete-timer)) + (when (eq window (sawlet-get iconbox 'hover-window)) + (sawlet-put iconbox 'hover-window nil) + (unless (or (window-get window 'sticky) + (window-in-workspace-p window current-workspace)) + (hide-window window)) + (unless raise-windows-on-uniconify + (restack-windows (sawlet-get iconbox 'hover-stacking))) + (unless uniconify-to-current-viewport ;; todo: or was moved + (move-window-to window + (sawlet-get iconbox 'hover-old-x) + (sawlet-get iconbox 'hover-old-y)))) + (let* + ((icon (window-get window (sawlet-symbol iconbox 'icon)))) + (when icon + (window-put window (sawlet-symbol iconbox 'icon) nil) + (sawlet-put iconbox 'icons (delq icon (sawlet-get iconbox 'icons))) + (x-destroy-window icon) + (sawlet-reconfigure iconbox)))) + + (define (hover-window-or-a-transient-p iconbox window) + (let + ((shown (sawlet-get iconbox 'hover-window)) + (transient (and (windowp window) (window-transient-p window)))) + (or (eq window shown) (and shown (eq transient (window-id shown)))))) + + (define (enter-notify-eye iconbox window) + (when (hover-window-or-a-transient-p iconbox window) + (schedule iconbox window))) + + (define (leave-notify-eye iconbox window) + (when (hover-window-or-a-transient-p iconbox window) + (schedule iconbox nil))) + + (define (property-notify-eye iconbox window property state) + (let* + ((icon (window-get window (sawlet-symbol iconbox 'icon)))) + (when (and icon (eq property 'WM_NAME)) + (icon-repaint iconbox icon)))) + + ;;;; + + (define iconboxes nil) + + (mapc + (lambda (hook) + (add-hook (car hook) + (lambda (#!rest args) + (mapc + (lambda (iconbox) + (apply (cdr hook) (list* iconbox args))) + iconboxes)))) + `((after-add-window-hook . ,after-add-window-eye) + (iconify-window-hook . ,iconify-window-eye) + (uniconify-window-hook . ,uniconify-window-eye) + (enter-notify-hook . ,enter-notify-eye) + (leave-notify-hook . ,leave-notify-eye) + (property-notify-hook . ,property-notify-eye) + (unmap-notify-hook . ,uniconify-window-eye) + (destroy-notify-hook . ,uniconify-window-eye))) + + (define (start iconbox) + (mapc + (lambda (window) + (after-add-window-eye iconbox window)) + (managed-windows)) + (setq iconboxes (nconc iconboxes (list iconbox)))) + + (define (stop iconbox) + (setq iconboxes (delq iconbox iconboxes)) + (mapc + (lambda (window) + (uniconify-window-eye iconbox window)) + (managed-windows))) + + (define (post-configure iconbox) + (mapc + (lambda (icon) + (icon-reconfigure iconbox icon)) + (sawlet-get iconbox 'icons))) + + (define (window-expose-handler iconbox event) + (x-clear-window (cdr (assq 'window event)))) + + (define (window-enter-notify-handler iconbox event) + (let + ((frame (sawlet-frame iconbox))) + (call-hook 'enter-notify-hook (list frame 'normal)))) + + (defmacro deficonbox (iconbox . keys) + `(progn + (require 'merlin.sawlet) + ,(append + `(defsawlet ,iconbox) + keys ; allow override + `(:start ,start + :stop ,stop + :post-configure ,post-configure + :dimensions ,dimensions + :expose-handler ,window-expose-handler + :enter-notify-handler ,window-enter-notify-handler + :font ,nil + :foreground ,nil + :defcustom (icon-columns 2 + "Number of icon columns." + :type (number 1 20) + :after-set sawlet-reconfigure) + :defcustom (fixed-height nil + "Fixed height." + :type boolean + :after-set sawlet-reconfigure) + :defcustom (height 64 + "Height." + :type (number 1 1024) + :depends fixed-height + :after-set sawlet-reconfigure) + :defcustom (hover-show t + "Temporarily show iconified windows on mouse hover." + :type boolean) + :defgroup (icons "Icons") + :defcustom (icon-width 48 + "Icon width." + :type (number 1 256) + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (icon-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") + "Icon font." + :type font + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (icon-color (cons (get-color-rgb 40960 40960 40960) (get-color-rgb 16384 0 0)) + "Icon color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (icon-border (cons 1 (get-color-rgb 24576 0 0)) + "Icon border." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (focused-icon-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") + "Focused icon font." + :type font + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (focused-icon-color (cons (get-color-rgb 65535 65535 65535) (get-color-rgb 28672 0 0)) + "Focused icon color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (icons) + :after-set sawlet-reconfigure) + :defcustom (focused-icon-border (cons 1 (get-color-rgb 36864 0 0)) + "Focused icon border." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (icons) + :after-set sawlet-reconfigure)))))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/icons.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/icons.jl new file mode 100644 index 000000000000..e9936333f768 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/icons.jl @@ -0,0 +1,539 @@ +;; merlin/icons.jl -- another bad icon manager + +;; version -0.5.1 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +; ; +; # ; +; # ; +; ###### ; +; ########### ; +; ########## ; +; ########## ; +; #### ; +; #### ; +; ########## ; +; ########## ; +; #### ; This Software is Not Good Software. +; ### ; +; #### # ; The Tao of Sawfish is that +; ## ; a Window Manager Manages Windows. +; # ; +; # ; That is How It Should Be. +; # ; +; # ### ; That is Right. +; ### ; +; # ### ; This Software violates the Tao of +; # ### ; Sawfish by making the window manager +; # ####### ; do what it should not. +; # ######### ; +; ######## ; The Purity of Sawfish is Sullied by +; # ######### ; this Software. +; ###### ; +; ### ; This Software Should Not Be. +; # ; +; # # ; Do not use this Software. +; ##################### ; +; ##################### ; Merely observe, weep, gnash of your +; # ## # ; teeth and pull of your hair. +; ##### # ; +; ######## # ; -- +; # ####### # # ; +; ###### ## ## ; Use instead a real icon manager +; ### ####### ; based on stph or somesuch. +; # ### ; +; # # ; -- +; ##################### ; +; # ### ; Let me reiterate one more time +; ###### ; before I'm drunk again: +; ####### ; +; ####### ; This software is a retrograde step. +; ####### ; +; ####### ; The Purity And Lightness of Sawfish +; ###### # ; is its Greatness. +; ##################### ; +; ; A Window Manager should not include +; # # ; Applications such as this. +; ##################### ; +; ##################### ; Discrete applications can do a much +; # # ; better job. +; ; +; # # ; This Software is a return to the old +; ##################### ; ways of proprietary gadgets on +; # ### ; bloated, unstable window managers. +; ###### ; +; ####### ; -- +; ####### ; +; ####### ; For the love of all that is good, +; ####### ; turn back now. +; ###### # ; +; ##################### ; +; ; +; ##### ; +; ############# ; +; ################# ; +; ### ## ; +; # # ; +; # # ; +; # # ; +; ## ## ; +; ######### #### ; +; ###### ; +; # ; +; ; + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv icons.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/util.jl, merlin/x-util.jl and merlin/uglicon.jl. + +;; Then add to your .sawfishrc: +;; (require 'merlin.icons.) + +;; Then restart sawfish. Iconified windows should now get little icons. + +;; Go to Customize->Icons +;; - Here you can customize the behaviour of the icons. +;; Go to Customize->Icons->Icon keymap +;; - Here you can configure the keymap that is active for icons. +;; - By default, mouse-1 moves the window, double-clicking mouse-1 +;; uniconifies it and mouse 3 brings up the window menu. +;; - In particular you will want to use the "Icon window commands" +;; command, which applies a sequence of commands to the iconified +;; window (as opposed to the icon itself). +;; Go to Customize->Icons->Icon matchers +;; - Here you can configure matched properties for the icons; for +;; example, you can force them all to a low depth or to use a +;; special icon placement mode. You might want to look at +;; merlin.sawlet-placement for an appropriate placement mode. +;; - Icons inherit the name of their parent, so if you want to +;; customize the icons of particular windows you can, to a +;; certain extent. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; TODO: can I share a gc? + +;; TODO: does this cope at all well with multiple workspaces? +;; I guess I should inherit workspaces from a parent... and +;; keep up with changes thereto. + +;;;; + +(define-structure merlin.icons + + (export + icons-start + icons-stop) + + (open + rep + rep.system + rep.io.timers + sawfish.wm.colors + sawfish.wm.commands + sawfish.wm.custom + sawfish.wm.events + sawfish.wm.fonts + sawfish.wm.frames + sawfish.wm.images + sawfish.wm.keymaps + sawfish.wm.menus + sawfish.wm.misc + sawfish.wm.placement + sawfish.wm.stacking + sawfish.wm.windows + sawfish.wm.ext.match-window + sawfish.wm.ext.tooltips + sawfish.wm.state.iconify + sawfish.wm.util.decode-events + sawfish.wm.util.keymap + sawfish.wm.util.x + merlin.uglicon + merlin.util + merlin.x-util) + + (defgroup icons "Icons") + + (defgroup icons-keymap "Icon keymap" :group icons :layout single) + + (defgroup icons-matchers "Icon matchers" :group icons :layout single :require sawfish.wm.ext.match-window) + + (defcustom icons-enabled t + "Enable icons for iconified windows." + :type boolean + :group (icons) + :after-set (lambda () (icons-go))) + + (defcustom icons-tooltips t + "Show iconified window titles using tooltips." + :type boolean + :group (icons)) + + (defcustom icons-background (get-color-rgb 65535 65535 65535) + "Icon background color." + :type color + :group (icons) + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-show-text t + "Show icon names." + :type boolean + :group (icons) + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-text-from 'window-name + "Source of icon name." + :type (choice window-name window-icon-name) + :group (icons) + :depends icons-show-text + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-text (cons (get-color-rgb 0 0 0) (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*")) + "Appearance of icon names." + :type (pair (labelled "Color:" color) (labelled "Font:" font)) + :group (icons) + :depends icons-show-text + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-padding (cons 8 8) + "Padding around icon." + :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) + :group (icons) + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-border (cons 1 (get-color-rgb 65535 0 0)) + "Internal border around icon." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (icons) + :after-set (lambda () (icons-reconfigure))) + + (defcustom icons-keymap (make-keymap) + "" + :group (icons icons-keymap) + :user-level expert + :type keymap) + + (defcustom icons-match-profile + `((((WM_CLASS . "icon/Merlin")) + (cycle-skip . t) + (window-list-skip . t) + (skip-tasklist . t) + (never-iconify . t) + (frame-type . border-only) + (place-mode . none))) + nil + :group (icons icons-matchers) + :type match-window) + + ;;;; + + (define (icons-get-icon w) + (let + ((icon (window-get w 'merlin.icon))) + (and icon (get-window-by-id (x-window-id icon))))) + + (define (icons-get-icon-window w) ;; oh so inefficient, want get-x-window-by-id + (let + ((id (window-id w))) + (catch 'out + (mapc (lambda (w) + (let + ((icon (window-get w 'merlin.icon))) + (when (and icon (eq id (x-window-id icon))) + (throw 'out w)))) (managed-windows)) + nil))) + + (define (icons-get-text w) + (let + ((text ((if (eq icons-text-from 'window-name) window-name window-icon-name) w)) + (width (+ uglicon-width (* 2 (car icons-padding))))) + (trim text (cdr icons-text) width))) + + ;;;; + + (define (icon-reconfigure w) + (let* + ((window (window-get w 'merlin.icon)) + (background (x-window-get window 'background)) + (gc (x-window-get window 'gc)) + (bg-dim (cons+ (cons uglicon-width (+ uglicon-height (if icons-show-text (font-height (cdr icons-text)) 0))) (cons* icons-padding 2))) + (win-dim (cons+ bg-dim (* 2 (car icons-border)))) + (caption (icons-get-text w))) + (x-set-wm-size-hints window win-dim win-dim) + (x-window-put window 'caption caption) + (x-change-gc gc + `((foreground . ,(car icons-text)))) + ((x-configure-fn) window + `((width . ,(car win-dim)) + (height . ,(cdr win-dim)))) + (x-change-window-attributes background + `((background . ,icons-background) + (border-color . ,(cdr icons-border)))) + (x-configure-window background + `((width . ,(car bg-dim)) + (height . ,(cdr bg-dim)) + (border-width . ,(car icons-border)))) + (icons-repaint w))) ;; could reapply the match-window settings + + (define (icons-reconfigure) + (mapc (lambda (w) + (when (window-get w 'merlin.icon) + (icon-reconfigure w))) (managed-windows))) + + ;;;; + + (define (icons-repaint w) + (let* + ((window (window-get w 'merlin.icon)) + (background (x-window-get window 'background)) + (gc (x-window-get window 'gc)) + (icon (x-window-get window 'icon)) + (icon-pos (cons+ (cons-quotient (cons- (cons uglicon-width uglicon-height) (image-dimensions icon)) 2) icons-padding))) + (x-clear-window background) + (x-draw-image icon background icon-pos) + (when icons-show-text + (let* + ((caption (x-window-get window 'caption)) + (caption-pos (cons (quotient (- (+ uglicon-width (* 2 (car icons-padding))) (text-width caption (cdr icons-text))) 2) (+ uglicon-height (cdr icons-padding) (- (font-height (cdr icons-text)) (font-descent (cdr icons-text))))))) + (x-draw-string background gc caption-pos caption (cdr icons-text)))))) + + ;;;; + + (define (icons-event-expose event) + (let* + ((window (cdr (assq 'window event))) + (w (x-window-get window 'parent))) + (icons-repaint w))) + + (define (icons-event-enter-notify event) + (let* + ((window (cdr (assq 'window event))) + (w (x-window-get window 'parent))) + (when icons-tooltips + (let ((tooltips-enabled t)) + (display-tooltip-after-delay (window-name w) (icons-get-icon w)))))) + + (define (icons-event-leave-notify event) + (let* + ((window (cdr (assq 'window event))) + (w (x-window-get window 'parent))) + (when icons-tooltips + (remove-tooltip)))) + + (define (icons-event-client-message event) + (let* + ((window (cdr (assq 'window event))) + (message-type (cdr (assq 'message-type event))) + (format (cdr (assq 'format event))) + (data (cdr (assq 'data event))) + (w (x-window-get window 'parent))) + (when (and (eq message-type 'WM_PROTOCOLS) + (eq format 32) + (eq (aref data 0) (x-atom 'WM_DELETE_WINDOW))) + (uniconify-window w)))) ;; or do I just delete the icon? + + (define (icons-event-handler type win event) + (cond ((eq type 'expose) (icons-event-expose event)) + ((eq type 'enter-notify) (icons-event-enter-notify event)) + ((eq type 'leave-notify) (icons-event-leave-notify event)) + ((eq type 'client-message) (icons-event-client-message event)))) + + ;;;; + + (define (icons-hook-iconify-window w) + (unless (window-get w 'merlin.icon) + (let* + ((win-pos (or (window-get w 'merlin.icon.position) (window-position w))) + (bg-dim (cons+ (cons uglicon-width (+ uglicon-height (if icons-show-text (font-height (cdr icons-text)) 0))) (cons* icons-padding 2))) + (win-dim (cons+ bg-dim (* 2 (car icons-border)))) + (caption (icons-get-text w)) + (icon (get-window-icon w)) + (window (x-create-window + win-pos + win-dim + 0 + `((override-redirect . ,nil) + (event-mask . ,'())) + icons-event-handler)) + (background (x-create-window + (cons 0 0) + bg-dim + (car icons-border) + `((parent . ,window) + (background . ,icons-background) + (border-color . ,(cdr icons-border)) + (override-redirect . ,t) + (event-mask . ,'(exposure enter-window leave-window))) + icons-event-handler)) + (gc (x-create-gc + window + `((foreground . ,(car icons-text)))))) + (x-set-wm-name window (window-name w)) + (x-set-wm-icon-name window (window-icon-name w)) + (x-set-wm-class window "Merlin" "icon") + (x-set-wm-protocols window '(delete-window)) + (x-set-wm-size-hints window win-dim win-dim) + (x-window-put background 'parent w) + (x-window-put window 'parent w) + (x-window-put window 'background background) + (x-window-put window 'gc gc) + (x-window-put window 'icon icon) + (x-window-put window 'caption caption) + (x-window-put window 'merlin.icons.is-icon t) + (window-put w 'merlin.icon window) + ((x-map-fn) window) + (x-x-map-window background) + (icons-repaint w)))) + + (define (icons-hook-uniconify-window w) + (when (window-get w 'merlin.icon) + (let* + ((window (window-get w 'merlin.icon)) + (background (x-window-get window 'background)) + (gc (x-window-get window 'gc)) + (icon (get-window-by-id (x-window-id window)))) + (window-put w 'merlin.icon.position (window-position icon)) + (window-put w 'merlin.icon nil) + (x-free-gc gc) + (x-destroy-window background) + (x-destroy-window window)))) + + (define (icons-hook-after-add-window w) + (when (window-get w 'iconified) + (icons-hook-iconify-window w))) + + (define (icons-hook-before-add-window w) + (let* + ((parent (icons-get-icon-window w)) + (match-window-profile icons-match-profile)) + (when parent ; it is an icon window + (match-window w) + (window-put w 'parent parent) + (window-put w 'keymap icons-keymap) + (when (window-get parent 'sticky) + (window-put w 'sticky t)) + (when (window-get parent 'sticky-viewport) + (window-put w 'sticky-viewport t))))) ; should I note the change? + + (define (icons-hook-unmap-notify w) + (icons-hook-uniconify-window w)) + + (define (icons-hook-destroy-notify w) + (icons-hook-uniconify-window w)) + + (define (icons-hook-property-notify w property state) + (when (eq property (if (eq icons-text-from 'window-name) 'WM_NAME 'WM_ICON_NAME)) + (when (and icons-show-text (window-get w 'merlin.icon)) + (icon-reconfigure w)))) ;; a bit brutal + + ;; sawfish doesn't really differentiate sticky and sticky-viewport + ;; at this level. + (define (window-state-change-eye w state) + (let* + ((icon (icons-get-icon w))) + (when (and icon (memq 'sticky state)) + (if (window-sticky-p w) + (make-window-sticky icon) + (make-window-unsticky icon))))) + + ;;;; + + (define icons-hooks + `((iconify-window-hook . ,icons-hook-iconify-window) + (uniconify-window-hook . ,icons-hook-uniconify-window) + (before-add-window-hook . ,icons-hook-before-add-window) + (after-add-window-hook . ,icons-hook-after-add-window) + (unmap-notify-hook . ,icons-hook-unmap-notify) + (destroy-notify-hook . ,icons-hook-destroy-notify) + (property-notify-hook . ,icons-hook-property-notify) + (window-state-change-hook . ,window-state-change-eye))) + + (define (icons-add-hooks) + (mapc (lambda (hookfun) + (unless (in-hook-p (car hookfun) (cdr hookfun)) + (add-hook (car hookfun) (cdr hookfun)))) icons-hooks)) + + (define (icons-remove-hooks) + (mapc (lambda (hookfun) + (when (in-hook-p (car hookfun) (cdr hookfun)) + (remove-hook (car hookfun) (cdr hookfun)))) icons-hooks)) + + (define (icons-start) + (icons-stop) + (mapc icons-hook-after-add-window (managed-windows)) + (icons-add-hooks)) + + (define (icons-stop) + (icons-remove-hooks) + (mapc icons-hook-uniconify-window (managed-windows))) + + (define (icons-go) + ((if icons-enabled icons-start icons-stop))) + + ;;;; commands + + (define (icon-window-commands commands) + "Invoke commands on an icon's parent window." + (let* + ((icon (current-event-window)) + (parent (and icon (icons-get-icon-window icon)))) + (unless parent + (error "icon-window-commands invoked on non icon window: %s" icon)) + (current-event-window parent) + (mapc call-command commands))) + + (define-command 'icon-window-commands icon-window-commands + #:type `(and (quoted (list command ,(_ "Command"))))) + + ;;;; initialization + + ;; TODO: how do I get the behaviour that these are only defaults??? + + (define (bind-key-unless key) + (unless (search-keymap (cdr key) icons-keymap) + (bind-keys icons-keymap (cdr key) (car key)))) + + (let + ((default-keymap (make-keymap))) + (bind-keys default-keymap + "Button1-Move" 'move-window-interactively + "Button1-Click2" `(icon-window-commands '(uniconify-window)) + "Button3-Click1" `(icon-window-commands '(popup-window-menu))) + (map-keymap bind-key-unless default-keymap) + (map-keymap bind-key-unless window-keymap)) + + (icons-go)) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/message.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/message.jl new file mode 100644 index 000000000000..0e633c8bfc60 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/message.jl @@ -0,0 +1,203 @@ +;; merlin/message.jl -- fancier message display + +;; version 0.5 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; TODO: click to hide? + +;; NB: icon handling willnot remain the ugly same!! + +(define-structure merlin.message + + (export + fancy-message + hide-fancy-message) + + (open + rep + sawfish.wm.misc + sawfish.wm.colors + sawfish.wm.fonts + sawfish.wm.images + sawfish.wm.windows.subrs + sawfish.wm.util.x + merlin.util) + + (define message-window nil) + (define message-gc nil) + (define message-msg nil) + (define message-attrs nil) + (define message-pos (cons 0 0)) + (define message-dims (cons 0 0)) + + (define default-message-padding (cons 4 4)) + (define default-message-foreground "black") + (define default-message-background "white") + (define default-message-border-color "black") + (define default-message-border-width 1) + (define default-message-spacing 1) + (define default-message-position (cons-quotient (screen-dimensions) 2)) + + (define (repaint-message-window id) + (when (eq id message-window) + (let + ((pad (cdr (assqd 'padding message-attrs default-message-padding))) + (fg (colorify (cdr (assqd 'foreground message-attrs default-message-foreground)))) + (font (fontify (cdr (assq 'font message-attrs)))) + (justify (cdr (assqd 'x-justify message-attrs 'left))) + (spacing (cdr (assqd 'spacing message-attrs default-message-spacing))) + (w (car message-dims)) x y) + (setq y (cdr pad)) + (x-clear-window message-window) + (x-change-gc message-gc `((foreground . ,fg))) + (mapcar (lambda (msg) + (when (stringp msg) + (cond ((eq 'left justify) + (setq x (car pad))) + ((eq 'center justify) + (setq x (quotient (- w (text-width msg font)) 2))) + (t ;; (eq 'right justify) + (setq x (- w (text-width msg font) (car pad))))) + (setq y (+ y (font-ascent font) spacing)) ;; spacing not on first line! + (x-draw-string message-window message-gc (cons x y) msg font) + (setq y (+ y (font-descent font)))) + (when (imagep msg) + (setq y (+ y spacing)) ;; spacing not on first line! + (x-draw-image msg message-window (cons (quotient (- w (car (image-dimensions msg))) 2) y)) + (setq y (+ y (cdr (image-dimensions msg))))) + (when (consp msg) + (cond ((eq 'font (car msg)) + (setq font (fontify (cdr msg)))) + ((eq 'foreground (car msg)) + (x-change-gc message-gc `((foreground . ,(colorify (cdr msg)))))) + ((eq 'x-justify (car msg)) + (setq justify (cdr msg))) + ((eq 'spacing (car msg)) + (setq spacing (cdr msg)))))) + message-msg)))) + + (define (calculate-message-window-dimensions) + (let + ((pad (cdr (assqd 'padding message-attrs default-message-padding))) + (font (fontify (cdr (assq 'font message-attrs)))) + (spacing (cdr (assqd 'spacing message-attrs default-message-spacing)))) + (setq message-dims (cons (* 2 (car pad)) (* 2 (cdr pad)))) + (mapcar (lambda (msg) + (when (stringp msg) + (rplaca message-dims + (max (car message-dims) (+ (* 2 (car pad)) (text-width msg font)))) + (rplacd message-dims + (+ (cdr message-dims) spacing (font-height font)))) ;; spacing not on first line! + (when (imagep msg) + (rplacd message-dims + (+ (cdr message-dims) spacing (cdr (image-dimensions msg))))) ;; spacing not on first line! + (when (consp msg) + (cond ((eq 'font (car msg)) + (setq font (fontify (cdr msg)))) + ((eq 'spacing (car msg)) + (setq spacing (cdr msg)))))) + message-msg))) + + (define (calculate-message-window-position) + (let* + ((pos (cdr (assqd 'position message-attrs default-message-position))) + (bw (cdr (assqd 'border-width message-attrs default-message-border-width))) + (dim (cons+ message-dims bw bw)) + (gravity (cdr (assqd 'gravity message-attrs 'center)))) + (setq message-pos (cons-max (cons-min (gravitate pos dim gravity) (cons- (screen-dimensions) dim)) 0)))) + + (define (message-window-event-handler type #!optional args) + (cond ((eq type 'expose) (repaint-message-window message-window)))) + + (define (create-message-window) + (let* + ((bw (cdr (assqd 'border-width message-attrs default-message-border-width))) + (bg (colorify (cdr (assqd 'background message-attrs default-message-background)))) + (bd (colorify (cdr (assqd 'border-color message-attrs default-message-border-color)))) + (window-attrs `((background . ,bg) + (border-color . ,bd) + (override-redirect . ,t) + (save-under . ,nil) + (event-mask . ,'(exposure)))) + (gc-attrs `((background . ,bg)))) + + (setq message-window (x-create-window message-pos message-dims bw window-attrs message-window-event-handler)) + (setq message-gc (x-create-gc message-window gc-attrs)) + (x-map-window message-window t))) + + (define (update-message-window) + (let* + ((x (car message-pos)) + (y (cdr message-pos)) + (w (car message-dims)) + (h (cdr message-dims)) + (bw (cdr (assqd 'border-width message-attrs default-message-border-width))) + (bg (colorify (cdr (assqd 'background message-attrs default-message-background)))) + (bd (colorify (cdr (assqd 'border-color message-attrs default-message-border-color)))) + (window-config `((x . ,x) (y . ,y) + (width . ,w) (height . ,h) + (border-width . ,bw) + (stack-mode . top-if))) + (window-attrs `((background . ,bg)6 + (border-color . ,bd))) + (gc-attrs `((background . ,bg)))) + + (x-configure-window message-window window-config) + (x-change-window-attributes message-window window-attrs) + (x-change-gc message-gc gc-attrs))) + + ;; supported global attributes: + ;; + ;; 'position - (x . y) position + ;; 'gravity - how the window is positioned relative to position + ;; 'font - default font + ;; 'foreground - default foreground + ;; 'background - default background + ;; 'border-color - border color + ;; 'font - default font + ;; 'x-justify - default justification + ;; 'spacing - interline spacing + ;; 'padding - (x . y) outer padding + ;; 'border-width - border width + + ;; supported inline attributes: + ;; + ;; 'font - font + ;; 'foreground - foreground + ;; 'x-justify - justification + ;; 'spacing - interline spacing + + (define (fancy-message message attrs) + (setq message-msg message) + (setq message-attrs attrs) + (calculate-message-window-dimensions) + (calculate-message-window-position) + (if message-window + (update-message-window) + (create-message-window)) + (repaint-message-window message-window)) + + (define (hide-fancy-message) + (when message-window + (x-destroy-window message-window) + (setq message-window nil)) + (when message-gc + (x-destroy-gc message-gc) + (setq message-gc nil)))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/pager.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/pager.jl new file mode 100644 index 000000000000..f7836a8b3d28 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/pager.jl @@ -0,0 +1,577 @@ +;; merlin/pager.jl -- a bad pager + +;; version -0.91.1 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv pager.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. + +;; You're probably best off unpacking the entire merlin.tgz archive. + +;; Then add to your .sawfishrc: +;; (require 'merlin.pager) +;; (defpager pager) + +;; Then restart sawfish. A pager should appear in the top right corner +;; of your screen. + +;; Go to Customize->Sawlets->Pager +;; - Here you can customize the behaviour of the pager +;; Also go to Customize->Matched Windows->^Sawlet/pager$->Edit... +;; - Here you can specify a border type for the window, etc. + +;; You can create multiple icon boxes and can configure them programatically +;; at creation if you want.. but you probably don't.. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; I divide window dimensions instead of dividing window bounds.. +;; but it looks better. + +;; Dragging a win from the very edge can leave the pager with +;; the wrong idea of who is focused at the end of the drag +;; because I suppress enter/leave notification. I could store +;; the last enter/leave notification to resend it after the +;; drag is finished... todo. + +;; Dragging a win from the very edge sometimes appears to lose +;; hold of the window. But this could be just a gammy mouse button. + +;; The pager does not keep up with merging workspaces.. I just +;; hear a 'workspace-state-changed which is too common for me +;; to do a full rebuild on.. In fact, I think this is a bug in +;; remove-workspace: It does not emit enter-workspace, +;; add-to-workspace or remove-from-workspace. Perhaps I could +;; fix this by noticing changes on the 'workspace* property of +;; windows? + +;; If you toggle a window 'ignored (and maybe 'sticky, etc.) +;; I don't pick up on it. I'm not sure that I care. + +;; TODO: use icon name + +;; TODO: support a delay before drags warp into the pager. + +;;;; + +(define-structure merlin.pager + + (export + defpager) + + (open + rep + rep.system + rep.io.timers + sawfish.wm.colors + sawfish.wm.custom + sawfish.wm.events + sawfish.wm.fonts + sawfish.wm.menus + sawfish.wm.misc + sawfish.wm.stacking + sawfish.wm.viewport + sawfish.wm.windows + sawfish.wm.workspace + sawfish.wm.commands.move-resize + sawfish.wm.ext.tooltips + sawfish.wm.state.iconify + sawfish.wm.util.display-window + sawfish.wm.util.x + merlin.sawlet + merlin.util + merlin.x-util) + + (defvar viewport-xy (viewport-offset)) ;; ughlobals, can probably do better + (define during-restack nil) + + ;;;; + + (define (fix-position pager pos) + (cons-quotient (cons+ pos (viewport-offset)) + (sawlet-config pager 'divisor))) + + (define (fix-dimensions pager dim bw) + (let + ((divisor (sawlet-config pager 'divisor))) + (cons-max (cons- (cons-quotient (cons+ dim (cons- divisor 1)) + divisor) (* 2 bw)) 0))) + + (define (dimensions pager) + (fix-dimensions pager + (cons* viewport-dimensions (screen-dimensions)) 0)) + + (define (viewport-position pager) + (fix-position pager (cons 0 0))) + + (define (viewport-dimensionz pager) + (fix-dimensions pager (screen-dimensions) + (car (sawlet-config pager 'viewport-border)))) + + (define (win-foo pager window foo) + (sawlet-config pager + (if (eq window (input-focus)) + (intern (format nil "focused-%s" foo)) + foo))) + + (define (win-position pager window) + (fix-position pager (window-position window))) + + (define (win-dimensions pager window) + (fix-dimensions pager (window-frame-dimensions window) + (car (win-foo pager window 'win-border)))) + + ;;;; + + (define (win-button-press-handler pager event) + (remove-tooltip) + (let* + ((win (cdr (assq 'window event))) + (window (x-window-get win 'window)) + (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) + (time (cdr (assq 'time event))) + (button (cdr (assq 'button event)))) + (cond + ((and (eq button 'button-1) (not (eq window (sawlet-frame pager)))) + (if (and (eq win (sawlet-get pager 'old-drag-win)) + (< (- time (sawlet-get pager 'drag-time)) 333)) + (display-window window) + (sawlet-put pager 'drag-win win) + (sawlet-put pager 'drag-time time) + (sawlet-put pager 'drag-xy xy) + (when (and (eq focus-mode 'click) + (window-really-wants-input-p window)) + (set-input-focus window)))) + ((eq button 'button-3) + (current-event-window window) + (popup-window-menu window))))) + +; BUG: If I click, then drag one pixel, then wait, then I +; lose the focus... Also, that first drag event doesn't +; result in the window moving... Obviously because I wait +; until I get that motion before I _start_ the interactive +; move. + + (define (win-motion-notify-handler pager event) + (let* + ((win (cdr (assq 'window event))) + (window (x-window-get win 'window)) + (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event))))) + (when (eq win (sawlet-get pager 'drag-win)) + (win-button-release-handler pager event) ;; stop multiple moves + (setq + move-window-unconstrained t + move-window-initial-pointer-offset + (cons-max 0 + (cons* (sawlet-config pager 'divisor) + (cons+ (sawlet-get pager 'drag-xy) + (car (win-foo pager window 'win-border)))))) + (move-window-interactively window)))) + + (define (win-button-release-handler pager event) + (sawlet-put pager 'drag-win nil + (lambda (win) (sawlet-put pager 'old-drag-win win)))) + + (define (win-enter-notify-handler pager event) + (let* + ((win (cdr (assq 'window event))) + (window (x-window-get win 'window))) + (unless (sawlet-get pager 'drag-win) + (let ((tooltips-enabled t)) + (display-tooltip-after-delay (window-name window) window)) + (call-hook 'enter-notify-hook (list window 'normal))))) + + (define (win-leave-notify-handler pager event) + (let* + ((win (cdr (assq 'window event))) + (window (x-window-get win 'window))) + (unless (sawlet-get pager 'drag-win) + (call-hook 'leave-notify-hook (list window 'normal))))) + + (define (win-repaint pager win) + (let* + ((window (x-window-get win 'window)) + (gc (sawlet-get pager 'gc)) + (title (window-name window)) + (font (win-foo pager window 'win-font))) + (x-clear-window win) + (x-change-gc gc `((foreground . ,(car (win-foo pager window 'win-color))))) + (x-draw-string win gc (cons 1 (font-ascent font)) title font))) + + (define (win-expose-handler pager event) + (win-repaint pager (cdr (assq 'window event)))) + + (define win-event-handlers + `((button-press . ,win-button-press-handler) + (motion-notify . ,win-motion-notify-handler) + (button-release . ,win-button-release-handler) + (enter-notify . ,win-enter-notify-handler) + (leave-notify . ,win-leave-notify-handler) + (expose . ,win-expose-handler))) + + (define (win-event-handler type window event) + (let + ((handler (assq type win-event-handlers))) + (when handler + ((cdr handler) (x-window-get window 'sawlet) event)))) + + (define (win-reconfigure pager win) + (let* + ((window (x-window-get win 'window)) + (pos (win-position pager window)) + (dim (win-dimensions pager window)) + (border (win-foo pager window 'win-border))) + (x-configure-window + win + `((x . ,(car pos)) + (y . ,(cdr pos)) + (width . ,(car dim)) + (height . ,(cdr dim)) + (border-width . ,(car border)))) + (x-change-window-attributes + win + `((background . ,(cdr (win-foo pager window 'win-color))) + (border-color . ,(cdr border)))) + (win-repaint pager win))) + + ;;;; + + (define (window-moved-eye pager window) + (when (or (equal viewport-xy (viewport-offset)) + (window-get window 'sticky-viewport)) + (let* + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (let* + ((pos (win-position pager window)) + (dim (win-dimensions pager window))) + (x-configure-window + win + `((x . ,(car pos)) + (y . ,(cdr pos)) + (width . ,(car dim)) + (height . ,(cdr dim))))))))) + + (define (after-add-window-eye pager window) + (unless (or (window-get window 'ignored) (window-get window (sawlet-symbol pager 'win))) ;; HACK + (let* + ((border (win-foo pager window 'win-border)) + (win + (x-create-window + (win-position pager window) + (win-dimensions pager window) + (car border) + `((parent . ,(sawlet-get pager 'window)) + (background . ,(cdr (win-foo pager window 'win-color))) + (border-color . ,(cdr border)) + (override-redirect . t) + (event-mask . (button-press button-release button-motion + enter-window leave-window exposure))) + win-event-handler))) + (x-window-put win 'sawlet pager) + (x-window-put win 'window window) + (window-put window (sawlet-symbol pager 'win) win) + (when (and (window-mapped-p window) (window-visible-p window)) + (x-x-map-window win))))) + + ; could do this more efficiently with better hooks + (define (after-restacking-eye pager) + (unless during-restack + (let* + ((wins (delq nil + (mapcar + (lambda (window) + (window-get window (sawlet-symbol pager 'win))) + (stacking-order))))) + (setq during-restack t) + (unwind-protect + (when (car wins) + (x-x-raise-window (car wins))) ;; hack + ;; that is a weird hack that i don't understand. + ;; essentially what happens is I have a big emacs + ;; window on the left completely covering an xterm. + ;; lower emacs and the xterm appears on top in the + ;; pager, as it should. then raise the xterm. its + ;; pager window disappears behind the emacs pager + ;; window. examining the calls, I am (apparently) + ;; correctly calling XRestackWindows but it is not + ;; doing what I expect. + (x-restack-windows wins)) + (setq during-restack nil)))) + + ;; ?? window-mapped-p and window-visible-p + (define (map-notify-eye pager window) + (let* + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (if (and (window-visible-p window) (window-mapped-p window)) + (x-x-map-window win) + (x-unmap-window win))))) + + (define (enter-workspace-eye pager) + (stop pager) + (start pager)) + + (define (viewport-moved-eye pager) + (post-configure pager)) ;; heavier than necessary + + (define (viewport-resized-eye pager) + (sawlet-reconfigure pager)) ;; heavier than necessary + + (define (focus-in-eye pager window) + (let* + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (win-reconfigure pager win)))) + + (define (focus-out-eye pager window) + (let* + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (win-reconfigure pager win)))) + + (define (property-notify-eye pager window property state) + (let* + ((win (window-get window (sawlet-symbol pager 'win)))) + (when (and win (eq property 'WM_NAME)) + (win-repaint pager win)))) + + (define (while-moving-eye pager window) + (let* + ((frame (sawlet-frame pager)) + (pos (cons- (query-pointer) (cons- (window-position frame) (window-frame-offset frame))))) + (when (and-cons (cons-and (cons>= pos 0) (cons< pos (window-dimensions frame)))) + (let* + ((repos (cons- (cons* pos (sawlet-config pager 'divisor)) move-window-initial-pointer-offset (viewport-offset)))) + (setq move-window-unconstrained t + move-resize-x (car repos) move-resize-y (cdr repos)))))) + + (define (after-move-eye pager window directions) + (sawlet-put pager 'drag-win nil)) + + ;;;; + + (define (viewport-repaint pager) + (x-clear-window (sawlet-get pager 'viewport))) + + (define (viewport-event-handler type window event) + (let ((sawlet (x-window-get window 'sawlet))) + (cond ((eq type 'expose) (viewport-repaint pager)) + ((eq type 'enter-notify) (window-enter-notify-handler pager event))))) + + (define pagers nil) + + (mapc + (lambda (hook) + (add-hook (car hook) + (lambda (#!rest args) + (mapc + (lambda (pager) + (apply (cdr hook) (list* pager args))) + pagers)))) + `((window-moved-hook . ,window-moved-eye) + (window-resized-hook . ,window-moved-eye) + (window-maximized-hook . ,window-moved-eye) + (window-unmaximized-hook . ,window-moved-eye) + (place-window-hook . ,after-add-window-eye) ;; hack + (after-add-window-hook . ,after-add-window-eye) ;; hack + (after-restacking-hook . ,after-restacking-eye) + (map-notify-hook . ,map-notify-eye) + (unmap-notify-hook . ,map-notify-eye) ;; destroy-notify-hook?? + (iconify-window-hook . ,map-notify-eye) + (uniconify-window-hook . ,map-notify-eye) + (add-to-workspace-hook . ,map-notify-eye) + (remove-from-workspace-hook . ,map-notify-eye) + (enter-workspace-hook . ,enter-workspace-eye) + (viewport-moved-hook . ,viewport-moved-eye) + (viewport-resized-hook . ,viewport-resized-eye) + (focus-in-hook . ,focus-in-eye) + (focus-out-hook . ,focus-out-eye) + (property-notify-hook . ,property-notify-eye) + (while-moving-hook . ,while-moving-eye) + (after-move-hook . ,after-move-eye))) + + (define (start pager) + (let + ((viewport + (x-create-window + (viewport-position pager) + (viewport-dimensionz pager) + (car (sawlet-config pager 'viewport-border)) + `((parent . ,(sawlet-get pager 'window)) + (background . ,(sawlet-config pager 'viewport-background)) + (border-color . ,(cdr (sawlet-config pager 'viewport-border))) + (override-redirect . t) + (event-mask . (exposure enter-window))) + viewport-event-handler))) + (x-window-put viewport 'sawlet pager) + (sawlet-put pager 'viewport viewport x-destroy-window) + (x-x-map-window viewport)) + (mapc + (lambda (window) + (after-add-window-eye pager window)) + (reverse (stacking-order))) + (setq pagers (nconc pagers (list pager)))) + + (define (stop pager) + (setq pagers (delq pager pagers)) + (mapc + (lambda (window) + (let + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (window-put window (sawlet-symbol pager 'win) nil) + (x-destroy-window win)))) + (managed-windows)) + (sawlet-put pager 'viewport nil x-destroy-window)) + + (define (post-configure pager) + (let + ((viewport (sawlet-get pager 'viewport)) + (pos (viewport-position pager)) + (dim (viewport-dimensionz pager))) + (x-configure-window + viewport + `((x . ,(car pos)) + (y . ,(cdr pos)) + (width . ,(car dim)) + (height . ,(cdr dim)) + (border-width . ,(car (sawlet-config pager 'viewport-border))))) + (x-change-window-attributes + viewport + `((background . ,(sawlet-config pager 'viewport-background)) + (border-color . ,(cdr (sawlet-config pager 'viewport-border))))) + (viewport-repaint pager)) + (mapc + (lambda (window) + (let + ((win (window-get window (sawlet-symbol pager 'win)))) + (when win + (win-reconfigure pager win)))) + (managed-windows))) + + (define (window-expose-handler pager event) + (x-clear-window (cdr (assq 'window event)))) + + (define (window-enter-notify-handler pager event) + (let + ((frame (sawlet-frame pager))) + (unless (sawlet-get pager 'drag-win) + (call-hook 'enter-notify-hook (list frame 'normal))))) + + (define (window-button-press-handler pager event) + (let* + ((button (cdr (assq 'button event))) + (x (cdr (assq 'x event))) + (y (cdr (assq 'y event))) + (viewport (cons-quotient + (cons* (cons x y) (sawlet-config pager 'divisor)) + (screen-dimensions)))) + (when (eq button 'button-1) + (set-screen-viewport (car viewport) (cdr viewport))))) + + ;; a hack on sawfish.wm.viewport#set-viewport so I can ignore the myriand + ;; move-windows... + + (eval-in + `(let + ((old-set-viewport set-viewport)) + (define (set-viewport x y) + (setq viewport-xy (cons x y)) + (old-set-viewport x y))) + 'sawfish.wm.viewport) + + (defmacro defpager (pager . keys) + `(progn + (require 'merlin.sawlet) + ,(append + `(defsawlet ,pager) + keys ; allow override + `(:start ,start + :stop ,stop + :post-configure ,post-configure + :dimensions ,dimensions + :expose-handler ,window-expose-handler + :enter-notify-handler ,window-enter-notify-handler + :button-press-handler ,window-button-press-handler + :font ,nil + :foreground ,nil + :background (get-color-rgb 0 0 0) + :defcustom (viewport-background (get-color-rgb 0 8192 0) + "Viewport background color." + :type color + :after-set sawlet-reconfigure) + :defcustom (viewport-border (cons 1 (get-color-rgb 0 16384 0)) + "Viewport internal border." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :after-set sawlet-reconfigure) + :defcustom (divisor (cons 24 24) + "Divisor from screen to pager." + :type (pair (labelled "Horizontal:" (number 2 100)) (labelled "Vertical:" (number 2 100))) + :after-set sawlet-reconfigure) + :defgroup (windows "Windows") + :defcustom (win-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") + "Window font." + :type font + :group (windows) + :after-set sawlet-reconfigure) + :defcustom (win-color (cons (get-color-rgb 36864 24576 0) (get-color-rgb 16384 0 0)) + "Window color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (windows) + :after-set sawlet-reconfigure) + :defcustom (win-border (cons 1 (get-color-rgb 24576 0 0)) + "Window border." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (windows) + :after-set sawlet-reconfigure) + :defcustom (focused-win-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") + "Focused window font." + :type font + :group (windows) + :after-set sawlet-reconfigure) + :defcustom (focused-win-color (cons (get-color-rgb 65535 65535 0) (get-color-rgb 28672 0 0)) + "Focused window color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (windows) + :after-set sawlet-reconfigure) + :defcustom (focused-win-border (cons 1 (get-color-rgb 36864 0 0)) + "Focused window border." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (windows) + :after-set sawlet-reconfigure)))))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/placement.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/placement.jl new file mode 100644 index 000000000000..6211ad533450 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/placement.jl @@ -0,0 +1,104 @@ +;; merlin/placement.jl -- opaque placement and with resize + +;; version 0.4 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv placement.jl ~/.sawfish/lisp/merlin + +;; Then add to your .sawfishrc: +;; (require 'merlin.placement) + +;; Then restart sawfish and go to Customize->Placement and select +;; (opaque-)interactively(-with-resize) +;; - Henceforth, windows will be placed opaquely if you so choose. +;; - If you select -with-resize then if you place +;; a window with a mouse button and hold it down, +;; you can drag-resize the window (twm-style). + +; BUGS: Sometimes windows get messed up by this. I don't know +; when or why so I don't know what to do about it. + +; TODO: do I fire the after-place / before-resize hooks on go-resize +; TODO: do i set the cursor - resize-cursor-shape on go-resize + +(define-structure merlin.placement + + (export) + + (open + rep + rep.system + sawfish.wm.placement + sawfish.wm.commands + sawfish.wm.commands.move-resize + sawfish.wm.events + sawfish.wm.misc + sawfish.wm.windows) + + (define (merlin-placement-go-resize) ;; hackalicious + (setq move-resize-function 'resize) + (setq move-resize-old-x move-resize-x) + (setq move-resize-old-y move-resize-y)) + + (define (merlin-place-window w opaque resize) + (accept-x-input) + (when (window-id w) + (let + ((move-outline-mode (if opaque 'opaque 'box)) + (resize-edge-mode 'border-grab) + (ptr (query-pointer)) + (siz (window-dimensions w)) + (dims (window-frame-dimensions w))) + (move-window-to w (- (car ptr) (quotient (car dims) 2)) + (- (cdr ptr) (quotient (cdr dims) 2))) + (when opaque + (hide-window w) (show-window w)) ;; hackalicious + (when resize + (bind-keys move-resize-map "Any-Click1" 'merlin-placement-go-resize)) + (move-window-interactively w) + (when resize + (unbind-keys move-resize-map "Any-Click1"))))) + + (define (place-window-opaque-interactively w) + (merlin-place-window w t nil)) + + (define (place-window-opaque-interactively-with-resize w) + (merlin-place-window w t t)) + + (define (place-window-interactively-with-resize w) + (merlin-place-window w nil t)) + + (define-placement-mode 'opaque-interactively + place-window-opaque-interactively) + + (define-placement-mode 'opaque-interactively-with-resize + place-window-opaque-interactively-with-resize) + + (define-placement-mode 'interactively-with-resize + place-window-interactively-with-resize) + + (define-command 'merlin-placement-go-resize + merlin-placement-go-resize)) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet-placement.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet-placement.jl new file mode 100644 index 000000000000..0c827d0de5eb --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet-placement.jl @@ -0,0 +1,260 @@ +;; merlin/sawlet-placement.jl -- a placement mode for sawlets etc. + +;; version 0.3 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv sawlet-placement.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/util.jl. + +;; You're probably best off unpacking the entire merlin.tgz archive. + +;; Then add to your .sawfishrc: +;; (require 'merlin.sawlet-placement) +;; (define-sawlet-placement-mode 'south-east-going-north +;; 'south-east 'north) + +;; This defines a placement mode 'south-east-going-north that starts +;; in the south-east of your screen and moves northwards. You can +;; choose whatever name you want, and define as many sawlet placement +;; modes as you want. Your options include 'north-west, 'north-east, +;; 'south-east and 'south-west, going 'north, 'south, 'east or 'west. + +;; Next, try adding: +;; (define-sawlet-subplacement-mode 'south-east-going-west +;; 'south-east-going-north nil 'west) + +;; This defines a placement mode 'south-east-going-west which is +;; treated as a composite child (with the specified placement weight) +;; of 'south-east-going-north. The two placement modes try and act +;; harmoniously, allowing you to have automatic window placement +;; as such: +;; [SEgN] +;; [SEgN] +;; [SEgW] [SEgW] [SEgW] + +;; More complex arrangements are also possible. + +;; Then restart sawfish. + +;; Go to Customize->Matched Windows +;; - Here you must add matchers on any windows that you want +;; (e.g., XBiff, XClock) for your new Place mode. Also, you +;; can use the Placement weight setting to assert an order +;; on the sawlets (least first); otherwise they are placed +;; in the order that they happen to be picked up by sawfish. + +;; Now, launch the apps. Or, if they launch at startup, restart +;; your X session. + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; I don't wrap around when I come to the edge of the screen... + +;; See merlin.pager for a probable problem with merging/removing +;; workspaces. + +;; Subplacements should try to pack windows better rather than +;; assuming pessimistic overlap with consequent full avoidance. + +;;;; + +(define-structure merlin.sawlet-placement + (export + get-size + define-sawlet-placement-mode + define-sawlet-subplacement-mode) + + (open + rep + rep.system + sawfish.wm.events + sawfish.wm.misc + sawfish.wm.placement + sawfish.wm.viewport + sawfish.wm.windows + merlin.util) + + (define modes nil) + + (define (origin mode) + (let* + ((origin (get mode 'merlin.sawlet-placement:origin))) + (cons (if (memq origin '(north-east south-east)) 1 0) + (if (memq origin '(south-west south-east)) 1 0)))) + + (define (direction mode) + (let* + ((direction (get mode 'merlin.sawlet-placement:direction))) + (cond + ((eq direction 'east) (cons 1 0)) + ((eq direction 'west) (cons -1 0)) + ((eq direction 'north) (cons 0 -1)) + (t (cons 0 1))))) + + (define (gravity mode) + (let* + ((direction (get mode 'merlin.sawlet-placement:direction)) + (org (origin mode))) + (cond ;; yech + ((eq direction 'east) (cons 0 (- (cdr org)))) + ((eq direction 'west) (cons -1 (- (cdr org)))) + ((eq direction 'north) (cons (- (car org)) -1)) + (t (cons (- (car org)) 0))))) + + (define (placement-p placement) + (and (symbolp placement) (get placement 'merlin.sawlet-placement:direction))) + + (define (subplacement-p placement) + (and (symbolp placement) (get placement 'merlin.sawlet-placement:parent))) + + (define (get-placement x) + (if (subplacement-p x) + (get x 'merlin.sawlet-placement:parent) + (window-get x 'place-mode))) + + (define (get-weight x) + (or + (if (subplacement-p x) + (get x 'merlin.sawlet-placement:weight) + (window-get x 'placement-weight)) + -1)) + + (define (visible-p window) + (and (window-mapped-p window) (window-visible-p window) + (or (window-get window 'sticky-viewport) + (not (window-outside-viewport-p window))))) + + ;; TODO: make multiple dependent placement modes be smart about + ;; just not overlapping windows; not to always be pessimistic + + ;; TODO: honour origin of subplacements... + + (define (get-size x) + (if (not (placement-p x)) + (if (visible-p x) (window-frame-dimensions x) (cons 0 0)) + (let* + ((direction (get x 'merlin.sawlet-placement:direction)) + (sawlets (get x 'merlin.sawlet-placement:list)) + (sizes (mapcar get-size sawlets)) + (op (if (memq direction '(east west)) (cons + max) (cons max +)))) + (apply cons-op op (cons 0 0) sizes)))) + + (define (mode-place mode pos) + (let* + ((sawlets (get mode 'merlin.sawlet-placement:list)) + (org (origin mode)) + (dir (direction mode)) + (grv (gravity mode))) + (mapc + (lambda (sawlet) + (if (placement-p sawlet) + (mode-place sawlet pos) + (when (visible-p sawlet) + (let* + ((dim (window-frame-dimensions sawlet)) + (tmp (cons+ pos (cons* grv dim)))) + (move-window-to sawlet (car tmp) (cdr tmp))))) + (setq pos + (cons+ pos (cons* dir (get-size sawlet))))) + sawlets))) + + (define (place x) + (let* + ((mode (let loop ((mode (get-placement x))) (if (not (subplacement-p mode)) mode (loop (get-placement mode))))) + (pos (cons* (origin mode) (screen-dimensions)))) + (mode-place mode pos))) + + (define (add-window-eye window) + (let* + ((mode (get-placement window)) + (weight (get-weight window)) + (sawlets (cons nil (and mode (get mode 'merlin.sawlet-placement:list))))) + (when (memq mode modes) + (let loop ((rest sawlets)) + (if (or (null (cdr rest)) (> (get-weight (cadr rest)) weight)) + (rplacd rest (cons window (cdr rest))) + (loop (cdr rest)))) + (put mode 'merlin.sawlet-placement:list (cdr sawlets))))) + + (define (destroy-notify-eye window) + (let* + ((mode (get-placement window)) + (sawlets (and mode (get mode 'merlin.sawlet-placement:list))) + (next (cadr (memq window sawlets)))) + (when sawlets + (put mode 'merlin.sawlet-placement:list (delq window sawlets)) + (when next + (place next))))) ;; TODO: must replace ALWAYS if it is subplaced + + (define (window-resized-eye window) + (let* + ((mode (get-placement window))) + (when (placement-p mode) + (place window)))) + + (define (after-initialization-eye) + (mapc + (lambda (mode) + (let* + ((sawlets (get mode 'merlin.sawlet-placement:list)) + (first (car sawlets))) + (when (and first (not (subplacement-p mode))) + (place first)))) + modes)) + + (add-hook 'add-window-hook add-window-eye) + + (add-hook 'destroy-notify-hook destroy-notify-eye) + + (mapc (lambda (hook) (add-hook hook window-resized-eye)) + '(window-resized-hook after-framing-hook map-notify-hook + unmap-notify-hook iconify-window-hook uniconify-window-hook + window-maximized-hook window-unmaximized-hook)) + + (mapc (lambda (hook) (add-hook hook after-initialization-eye)) + '(after-initialization-hook enter-workspace-hook + viewport-moved-hook)) + + (define (define-sawlet-subplacement-mode symbol parent weight direction) + (when (memq symbol modes) ;; TODO: Allow redefinition + (error "placement mode %s is already defined." symbol)) + (unless (placement-p parent) + (error "parent placement mode %s must be defined." parent)) + (define-sawlet-placement-mode symbol (get parent 'merlin.sawlet-placement:origin) direction) + (put symbol 'merlin.sawlet-placement:parent parent) + (put symbol 'merlin.sawlet-placement:weight weight) + (add-window-eye symbol)) + + (define (define-sawlet-placement-mode symbol origin direction) + (put symbol 'merlin.sawlet-placement:origin origin) + (put symbol 'merlin.sawlet-placement:direction direction) + (if (memq symbol modes) + (mapc place (get symbol 'merlin.sawlet-placement:list)) + (setq modes (nconc modes (list symbol)))) + (define-placement-mode symbol place))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet.jl new file mode 100644 index 000000000000..03cca6f35c29 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/sawlet.jl @@ -0,0 +1,428 @@ +;; merlin/sawlet.jl -- a bad saw(fish app)let framework + +;; version -0.3.3 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; This 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; either version 2, or (at your option) +;; any later version. + +;; This 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;;;;; +;; HERE BE DRAGONS ;; +;;;;;;;;;;;;;;;;;;;;; + +;; This software requires a patch to be applied to the Sawfish source to +;; add some additional XLib bindings. + +;; Please see x.c.patch. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Please see one of the actual sawlets + +;; Go to Customize->Matched Windows->Sawlet->Edit... +;; - Here you can specify settings for all sawlets + +;;;;;;;;;;;;;;;;;; +;; HERE BE BUGS ;; +;;;;;;;;;;;;;;;;;; + +;; sawlet's can be per-workspace but not be per-viewport. +;; sawlet defcustom/defgroup :group has to be a list, not a symbol. + +;; TODO: auto-remember sawlet position + +;; TODO: defsawlet :match-window settings + +;;;; + +(define-structure merlin.sawlet + (export + defsawlet + sawlet-start + sawlet-reconfigure + sawlet-stop + sawlet-active + sawlet-get + sawlet-put + sawlet-config + sawlet-frame + sawlet-from-frame + sawlet-symbol) + + (open + rep + rep.system + sawfish.wm.colors + sawfish.wm.custom + sawfish.wm.events + sawfish.wm.fonts + sawfish.wm.misc + sawfish.wm.windows + sawfish.wm.ext.match-window + sawfish.wm.util.x + merlin.sawlet-placement + merlin.util + merlin.x-util) + + (defgroup sawlets "Sawlets") + + (defcustom merlin.sawlet:default-placement:origin 'north-east + "Default placement origin." + :type (choice north-west north-east south-east south-west) + :group sawlets + :after-set (lambda () (define-default-sawlet-placement-mode))) + + (defcustom merlin.sawlet:default-placement:direction 'west + "Default placement direction." + :type (choice north east south west) + :group sawlets + :after-set (lambda () (define-default-sawlet-placement-mode))) + + (define (syms symbol . rest) + (intern + (apply concat + (list* + (format nil "%s" symbol) + (mapcar (lambda (sym) (format nil "-%s" sym)) rest))))) + + (define (sawlet-symbol sawlet symbol) + (intern (format nil "merlin.sawlet:%s:%s" sawlet symbol))) + + (define (sawlet-get sawlet key) + (get sawlet key)) + + (define (sawlet-put sawlet key value #!optional destructor) + (let + ((old (get sawlet key))) + (and old destructor (destructor old)) + (put sawlet key value))) + + (define (sawlet-config sawlet key) + (symbol-value (sawlet-symbol sawlet key))) + + (define (sawlet-call sawlet command . args) + (let + ((cmd (sawlet-get sawlet command))) + (and cmd (apply cmd args)))) + + (define (sawlet-frame sawlet) + (get-window-by-id (x-window-id (sawlet-get sawlet 'root)))) + + (define (sawlet-from-frame window) + (window-get window 'merlin.sawlet:sawlet)) + + (define (sawlet-root-client-message event) + (let* + ((window (cdr (assq 'window event))) + (sawlet (x-window-get window 'sawlet)) + (message-type (cdr (assq 'message-type event))) + (fmt (cdr (assq 'format event))) + (data (cdr (assq 'data event)))) + (when (and (eq message-type 'WM_PROTOCOLS) + (eq fmt 32) + (eq (aref data 0) (x-atom 'WM_DELETE_WINDOW))) + (sawlet-stop sawlet)))) + + (define (sawlet-root-event-handler type window event) + (cond + ((eq type 'client-message) (sawlet-root-client-message event)))) + + (define (sawlet-window-event-handler type window event) + (let* + ((sawlet (x-window-get window 'sawlet)) + (handler (sawlet-get sawlet (syms type 'handler)))) + (when handler + (handler sawlet event)))) + + (define event-mask-map + `((expose . exposure) + (button-press . button-press) + (enter-notify . enter-window) + (destroy-notify . substructure-notify) + (configure-notify . substructure-notify) + (configure-request . substructure-redirect))) + + (define (sawlet-create sawlet) + (let* + ((dims (or (sawlet-call sawlet 'dimensions sawlet) (cons 64 64))) + (bw (car (sawlet-config sawlet 'border))) + (root-dims (cons+ dims (* 2 bw))) + (root (x-create-window + (cons 0 0) + root-dims + 0 + `((override-redirect . ,nil) + (event-mask . ())) + sawlet-root-event-handler)) + (window (x-create-window + (cons 0 0) + dims + bw + `((parent . ,root) + (background . ,(sawlet-config sawlet 'background)) + (border-color . ,(cdr (sawlet-config sawlet 'border))) + (override-redirect . ,t) + (event-mask . + ,(mapcar (lambda (map) + (and (sawlet-get sawlet (syms (car map) 'handler)) + (cdr map))) event-mask-map))) + sawlet-window-event-handler)) + (gc (x-create-gc + root + (and (boundp (sawlet-symbol sawlet 'foreground)) + `(foreground . ,(sawlet-config sawlet 'foreground)))))) + (x-window-put window 'sawlet sawlet) + (x-window-put root 'sawlet sawlet) + (sawlet-put sawlet 'gc gc x-free-gc) + (sawlet-put sawlet 'window window x-destroy-window) + (sawlet-put sawlet 'root root x-destroy-window) + (x-set-wm-class + root + (format nil "%s" sawlet) + "Sawlet") + (x-set-wm-name + root + (or (sawlet-get sawlet 'name) (format nil "%s" sawlet))) + (x-set-wm-icon-name + root + (or (sawlet-get sawlet 'icon-name) (format nil "%s" sawlet))) + (x-set-wm-protocols + root + '(delete-window)) + (x-set-wm-size-hints + root + dims + dims) + (x-x-map-window + window) + ((x-map-fn) + root))) + + (define (sawlet-destroy sawlet) + (sawlet-put sawlet 'gc nil x-free-gc) + (sawlet-put sawlet 'window nil x-destroy-window) + (sawlet-put sawlet 'root nil x-destroy-window)) + + (define (sawlet-configure sawlet) + (let* + ((dims (or (sawlet-call sawlet 'dimensions sawlet) (cons 64 64))) + (bw (car (sawlet-config sawlet 'border))) + (root-dims (cons+ dims (* 2 bw)))) + (x-set-wm-size-hints + (sawlet-get sawlet 'root) + root-dims + root-dims) + ((x-configure-fn) + (sawlet-get sawlet 'root) + `((width . ,(car root-dims)) + (height . ,(cdr root-dims)))) + (x-configure-window + (sawlet-get sawlet 'window) + `((width . ,(car dims)) + (height . ,(cdr dims)) + (border-width . ,bw))) + (x-change-window-attributes + (sawlet-get sawlet 'window) + `((background . ,(sawlet-config sawlet 'background)) + (border-color . ,(cdr (sawlet-config sawlet 'border))))) + (when (boundp (sawlet-symbol sawlet 'foreground)) + (x-change-gc + (sawlet-get sawlet 'gc) + `((foreground . ,(sawlet-config sawlet 'foreground))))))) + + ;; pub + + (define sawlets nil) + + (define (add-window-eye window) + (mapc + (lambda (sawlet) + (when (eq window (sawlet-frame sawlet)) + (window-put window 'merlin.sawlet:sawlet sawlet))) + sawlets)) + + (add-hook 'add-window-hook add-window-eye) + + (define (sawlet-start sawlet) + (unless (memq sawlet sawlets) + (setq sawlets (nconc sawlets (list sawlet))) + (sawlet-create sawlet) + (sawlet-call sawlet 'start sawlet))) + + (define (sawlet-reconfigure sawlet) + (when (memq sawlet sawlets) + (sawlet-call sawlet 'pre-configure sawlet) + (sawlet-configure sawlet) + (sawlet-call sawlet 'post-configure sawlet) + (sawlet-call sawlet 'expose-handler sawlet `((window . ,(sawlet-get sawlet 'window)))))) ;; hack!! + + (define (sawlet-stop sawlet) + (when (sawlet-get sawlet 'root) + (setq sawlets (delq sawlet sawlets)) + (sawlet-call sawlet 'stop sawlet) + (sawlet-destroy sawlet))) + + (define (sawlet-active sawlet) + (and (sawlet-get sawlet 'root) t)) + + (define (define-default-sawlet-placement-mode) + (define-sawlet-placement-mode 'sawlet + merlin.sawlet:default-placement:origin + merlin.sawlet:default-placement:direction)) + + (define-default-sawlet-placement-mode) + + (defmacro defsawlet + (sawlet #!rest keys) + (let* + ((Sawlet (capitalize-string (format nil "%s" sawlet))) + (class (format nil "^Sawlet/%s$" sawlet)) + (fmt (lambda (sym) (intern (format nil ":%s" sym)))) + (get (lambda (sym) (cadr (memq (fmt sym) keys)))) + (no (lambda (sym) (and (memq (fmt sym) keys) (not (get sym))))) + (start-stop + (lambda () + (if (sawlet-config sawlet 'enabled) + (sawlet-start sawlet) + (sawlet-stop sawlet)))) + (configure + (lambda () + (sawlet-reconfigure sawlet)))) + + (append + `(progn + (require 'sawfish.wm.colors) + (require 'sawfish.wm.custom) + (require 'sawfish.wm.fonts) + (require 'sawfish.wm.ext.match-window) + + (sawlet-put ',sawlet 'sawlet t + (lambda () (error "Sawlet %s already defined." ',sawlet))) + + (defgroup ,sawlet ,Sawlet :group sawlets)) + + (mapcar ;; todo: ALL handlers! + (lambda (symbol) + `(sawlet-put ',sawlet ',symbol ,(get symbol))) + '(pre post init start stop pre-configure post-configure name icon-name + dimensions expose-handler button-press-handler + enter-notify-handler destroy-notify-handler + configure-notify-handler configure-request-handler)) + + (delq nil (mapcar + (lambda (def) + (let* + ((name (nth 0 def)) + (symbol (sawlet-symbol sawlet name)) + (value (or (get name) (nth 1 def))) + ;(doc (format nil "%s %s." Sawlet (nth 2 def))) + (doc (nth 2 def)) + (type (nth 3 def)) + (after-set (nth 4 def))) + (and (not (no name)) `(defcustom ,symbol ,value ,doc + :type ,type :group (sawlets ,sawlet) :after-set ,after-set)))) + `((enabled t "Enabled." boolean ,start-stop) + (font default-font "Font." font ,configure) + (foreground (get-color-rgb 0 0 0) "Foreground color." color ,configure) + (background (get-color-rgb 65535 65535 65535) "Background color." color ,configure) + (border (cons 0 (get-color-rgb 0 0 0)) "Internal border." (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) ,configure)))) + + (nreverse + (let loop ((rest keys) (defs nil)) + (if (not rest) + defs + (when (eq ':defgroup (car rest)) + (let* + ((def (append (cadr rest) ())) ; copy list + (group (memq ':group def))) + (if group ;; TODO: group can be a symbol + (rplaca (cdr group) (list* 'sawlets sawlet (cadr group))) + (nconc def `(:group (sawlets ,sawlet)))) + (setq defs (cons (cons 'defgroup def) defs)))) + (loop (cddr rest) defs)))) + + (nreverse + (let loop ((rest keys) (defs nil)) + (if (not rest) + defs + (when (eq ':defcustom (car rest)) + (let* + ((def (append (cadr rest) ())) ; copy list + (name (nth 0 def)) + (symbol (sawlet-symbol sawlet name)) + (value (or (get name) (nth 1 def))) + (group (memq ':group def)) + (after-set (memq ':after-set def)) + (depends (memq ':depends def))) + (rplaca def symbol) + (rplaca (cdr def) value) + (if group ;; TODO: group can be a symbol + (rplaca (cdr group) (list* 'sawlets sawlet (cadr group))) + (nconc def `(:group (sawlets ,sawlet)))) + (when depends + (rplaca (cdr depends) (sawlet-symbol sawlet (cadr depends)))) + (when after-set + (rplaca (cdr after-set) `(lambda () (,(cadr after-set) ',sawlet)))) + (setq defs (cons (cons 'defcustom def) defs)))) + (loop (cddr rest) defs)))) + + `((unless + (catch 'out + (mapc + (lambda (entry) + (when (member (cons 'WM_CLASS ,class) (car entry)) + (throw 'out t))) + match-window-profile) + nil) + (setq match-window-profile + (nconc match-window-profile (list (list (list (cons 'WM_CLASS ,class)))))) + (add-window-matcher 'WM_CLASS ,class)) + + (when (sawlet-get ',sawlet 'pre) + ((sawlet-get ',sawlet 'pre) ',sawlet)) + + (when (sawlet-get ',sawlet 'init) + ((sawlet-get ',sawlet 'init) ',sawlet)) + + (when (and (not batch-mode) (sawlet-config ',sawlet 'enabled)) + (sawlet-start ',sawlet)) + + (when (sawlet-get ',sawlet 'post) + ((sawlet-get ',sawlet 'post) ',sawlet)) + + (defvar ,sawlet ',sawlet))))) ;; define?? + + (unless + (catch 'out + (mapc + (lambda (entry) + (when (member (cons 'WM_CLASS "^Sawlet/") (car entry)) + (throw 'out t))) + match-window-profile) + nil) + (setq match-window-profile ;; put at end... + (nconc match-window-profile (list (list (list (cons 'WM_CLASS "^Sawlet/")))))) + (add-window-matcher 'WM_CLASS "^Sawlet/" + '(place-mode . sawlet) + '(never-focus . t) + '(sticky . t) + '(sticky-viewport . t) + '(window-list-skip . t) + '(skip-tasklist . t) + '(frame-type . border-only)))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/uglicon.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/uglicon.jl new file mode 100644 index 000000000000..3a31d69eb1cb --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/uglicon.jl @@ -0,0 +1,203 @@ +;; merlin/uglicon.jl -- window icons + +;; version 0.2 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv uglicon.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/util.jl and probably want merlin/ugliness.jl. + +(define-structure merlin.uglicon + + (export + get-window-icon) + + (open + rep + rep.io.files + sawfish.wm.colors + sawfish.wm.custom + sawfish.wm.images + sawfish.wm.misc + sawfish.wm.ext.match-window + sawfish.wm.windows.subrs + merlin.util) + + (defgroup uglicon "Window icons" :group appearance) + + (defcustom uglicon-ignore-hints t + "Ignore icons from window hints." + :type boolean + :group (appearance uglicon) +; :depends cycle-show-window-icons + :after-set (lambda () (uglicon-reset))) + + (defcustom uglicon-search-filesystem t + "Search the file system for window icons." + :type boolean + :group (appearance uglicon) +; :depends cycle-show-window-icons + :after-set (lambda () (uglicon-reset))) + + (defcustom uglicon-path "/usr/share/pixmaps:/usr/share/icons" + "Path to search for icons." + :tooltip "Colon separated paths." + :type string + :user-level expert + :group (appearance uglicon) + :depends uglicon-search-filesystem + :after-set (lambda () (uglicon-reset))) + + (defcustom uglicon-prefixes ",gnome-" + "Icon prefixes to look for." + :tooltip "Comma separated prefixes." + :type string + :user-level expert + :group (appearance uglicon) + :depends uglicon-search-filesystem + :after-set (lambda () (uglicon-reset))) + + (defcustom uglicon-suffixes "png,xpm" + "Icon suffixes to look for." + :tooltip "Comma separated suffixes." + :type string + :user-level expert + :group (appearance uglicon) + :depends uglicon-search-filesystem + :after-set (lambda () (uglicon-reset))) + + (defcustom uglicon-width 48 + "Maximum width of window icons." + :type number + :range (1 . 128) + :user-level expert + :group (appearance uglicon)) + + (defcustom uglicon-height 48 + "Maximum height of window icons." + :type number + :range (1 . 128) + :user-level expert + :group (appearance uglicon)) + + (define-match-window-property 'window-icon 'appearance 'file) + + (define uglicon-cache) ;; TODO: periodically purge the cache? + (define uglicon-split-path) + (define uglicon-split-suffixes) + (define uglicon-split-prefixes) + + (define (uglicon-reset) + (setq uglicon-cache '()) + (setq uglicon-split-path (split uglicon-path ":")) + (setq uglicon-split-suffixes (split uglicon-suffixes ",")) + (setq uglicon-split-prefixes (split uglicon-prefixes ","))) + + (uglicon-reset) + + ;; returns a cons cell of the key and entry + (define (cache-get key creator) + (let ((cached (cdr (assoc key uglicon-cache)))) + (unless cached + (when (setq cached (creator)) + (setq uglicon-cache (cons (cons key cached) uglicon-cache)))) + (and cached (cons key cached)))) + + (define (load-icon file) + (cache-get file + (lambda () + (when (file-exists-p file) + (make-image file))))) + + (define (locate-icon name) + (cache-get name + (lambda () + (catch 'out + (mapc + (lambda (dir) + (mapc + (lambda (prefix) + (mapc + (lambda (suffix) + (let ((where (expand-file-name (concat prefix name "." suffix) dir))) + (when (file-exists-p where) + (throw 'out (make-image where))))) + uglicon-split-suffixes)) + uglicon-split-prefixes)) + uglicon-split-path) + nil)))) + + (define (window-icon window) ;; TODO: this should not really be cached; should provide a purge mechanism... + (cache-get (format nil "win<0x%x>" (window-id window)) + (lambda () + (window-icon-image window)))) + + (define (scale-icon icon max) + (let ((key (format nil "%s-scale:%dx%d" (car icon) (car max) (cdr max)))) + (cache-get key + (lambda () + (let ((dims (image-dimensions (cdr icon)))) + (if (and (<= (car dims) (car max)) (<= (cdr dims) (cdr max))) + (cdr icon) + (scale-image (cdr icon) + (min (car max) (quotient (* (car dims) (cdr max)) (cdr dims))) + (min (cdr max) (quotient (* (car max) (cdr dims)) (car dims)))))))))) + + (define (fade-icon icon fade) + (let* + ((rgb (color-rgb-8 fade)) + (key (format nil "%s-fade:%02x/%02x/%02x" (car icon) (nth 0 rgb) (nth 1 rgb) (nth 2 rgb)))) + (cache-get key + (lambda () + (let ((icon (copy-image (cdr icon)))) + (image-map + (lambda (pixel) + (list + (quotient (+ (nth 0 pixel) (nth 0 rgb)) 2) + (quotient (+ (nth 1 pixel) (nth 1 rgb)) 2) + (quotient (+ (nth 2 pixel) (nth 2 rgb)) 2) + (nth 3 pixel))) icon) icon))))) + + (define (unknown-icon) + (or (and uglicon-search-filesystem (locate-icon "unknown")) + (cache-get "unknown" + (lambda () ;; TODO: Make it pretty + (bevel-image (make-sized-image uglicon-width uglicon-height (get-color "gray")) 2 t 50))))) + + (define (window-icon-name window) + (let ((class (get-x-text-property window 'WM_CLASS))) + (and class (>= (length class) 2) + (translate-string (aref class 1) downcase-table)))) + + (define (get-window-icon window #!key (max-size (cons uglicon-width uglicon-height)) (fade-to nil)) + (let ((icon (or (and (window-get window 'window-icon) (load-icon (window-get window 'window-icon))) + (and (not uglicon-ignore-hints) (window-icon window)) + (and uglicon-search-filesystem (window-icon-name window) (locate-icon (window-icon-name window))) + (unknown-icon)))) + (setq icon (scale-icon icon max-size)) + (when fade-to + (setq icon (fade-icon icon fade-to))) + (cdr icon)))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/ugliness.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/ugliness.jl new file mode 100644 index 000000000000..54f14208888f --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/ugliness.jl @@ -0,0 +1,395 @@ +;; merlin/ugliness.jl -- options for ugliness + +;; version 0.9.2 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;;;;;;;;;;;;;;;; +;; INSTALLATION ;; +;;;;;;;;;;;;;;;;;; + +;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: +;; mkdir -p ~/.sawfish/lisp/merlin +;; mv ugliness.jl ~/.sawfish/lisp/merlin + +;; You also need merlin/util.jl, merlin/uglicon.jl and merlin/message.jl. + +;; Then add to your .sawfishrc: +;; (require 'merlin.ugliness) + +;; Then restart sawfish and go to Customize->Focus or Customize->Move/Reisze. +;; - You should have lots of options for configuring ugliness. +;; Also go to Customize->Appearance->Window icons +;; - Here you can configure how window icons are determined +;; Also go to Customize->Matched windows->Appearance +;; - Here you can specify per-window icons + +;; TODO: honour position of cycle window when icons are showing... + +;; Thanks to Christian Marillat, Barthel(?) and Guillermo S. Romero for +;; bug reports, patches and suggestions. + +(define-structure merlin.ugliness + + (export + ugly-cycle-show-window-list + ugly-cycle-hide-window-list) + + (open + rep + rep.io.files + sawfish.wm.colors + sawfish.wm.custom + sawfish.wm.fonts + sawfish.wm.images + sawfish.wm.misc + sawfish.wm.commands.move-resize + sawfish.wm.commands.x-cycle + sawfish.wm.util.x + sawfish.wm.windows.subrs + merlin.message + merlin.util + merlin.uglicon) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; x-cycle basic appearance settings + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defgroup focus-ugliness "Ugliness" :group focus) + + (defcustom ugly-cycle-show-windows t + "Display full list of window names in cycle ring." + :group (focus focus-ugliness) + :type boolean) + + (defcustom ugly-cycle-relative 'screen + "Display cycle list relative to: \\w" + :type symbol + :options (screen window) + :group (focus focus-ugliness)) + + (defcustom ugly-cycle-percent (cons 50 50) + "Offset of cycle list as percentage of parent dimensions." + :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) + :group (focus focus-ugliness)) + + (defcustom ugly-cycle-color (cons (get-color "black") (get-color "white")) + "Window cycle list color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (focus focus-ugliness)) + + (defcustom ugly-cycle-font default-font + "Font for cycle list." + :type font + :group (focus focus-ugliness)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; x-cycle advanced ugliness settings + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defgroup focus-extra-ugliness "Extra Ugliness" :group focus) + + (defcustom ugly-cycle-justify 'center + "Justification of window names." + :type symbol + :options (left center right) + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-current-foreground (get-color "red") + "Foreground color for currently-selected window." + :type color + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-current-font default-font + "Font for currently-selected window." + :type font + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-iconified-foreground (get-color "blue") + "Foreground color for iconified windows." + :type color + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-iconified-font default-font + "Font for iconified windows." + :type font + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-caption t + "Display current window name in caption." + :group (focus focus-extra-ugliness) + :type boolean) + + (defcustom ugly-cycle-caption-foreground (get-color "white") + "Foreground color for caption." + :type color + :group (focus focus-extra-ugliness) + :depends ugly-cycle-caption) + + (defcustom ugly-cycle-caption-font default-font + "Font for caption." + :type font + :group (focus focus-extra-ugliness) + :depends ugly-cycle-caption) + + (defcustom ugly-cycle-border (cons 2 (get-color "black")) + "Border around window list." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-padding (cons 4 4) + "Padding around window list." + :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) + :group (focus focus-extra-ugliness)) + + (defcustom ugly-cycle-gravity 'center + "Gravity of window list." + :type symbol + :options + (north-west north north-east west center east south-west south south-east) + :group (focus focus-extra-ugliness)) + + ;;;;;;;;;;;;;;;;;;;;;;;; + ;; my ugly display stuff + ;;;;;;;;;;;;;;;;;;;;;;;; + + (define (ugly-cycle-display-position win) + (if (eq ugly-cycle-relative 'window) + (cons+ (window-position win) (cons-percent (window-frame-dimensions win) ugly-cycle-percent)) + (cons-percent (screen-dimensions) ugly-cycle-percent))) + + (define (justify child parent) + (cond ((eq ugly-cycle-justify 'left) 0) + ((eq ugly-cycle-justify 'right) (- parent child)) + (t (quotient (- parent child) 2)))) + + (let (ugly-w ugly-g width height rectangle icons labels) + (define (ugly-cycle-show win win-list) ;; bleargh!!! + (setq width 0 height 0 rectangle nil icons nil labels nil) + (if cycle-show-window-icons +(let* ;; just hideous; tidy this all up?? +((fonts (list* ugly-cycle-current-font ugly-cycle-iconified-font ugly-cycle-font)) + (th (apply max 0 (mapcar (lambda (f) (font-height f)) fonts))) + (mi (min (length win-list) (quotient (- (screen-width) (car ugly-cycle-padding) (* 2 (car ugly-cycle-border))) (+ uglicon-width (car ugly-cycle-padding))))) + (iw (+ (* mi uglicon-width) (* (1- mi) (car ugly-cycle-padding))))) + (setq + width (apply max iw (and ugly-cycle-caption (mapcar (lambda (w) (text-width (window-name w) ugly-cycle-caption-font)) win-list))) + height (+ height (* (+ uglicon-height th) (ceil (length win-list) mi))) + labels + (mapcar + (lambda (w) + (let* + ((iconified (window-get w 'iconified)) + (font (if (eq w win) ugly-cycle-current-font (if iconified ugly-cycle-iconified-font ugly-cycle-font))) + (color (if (eq w win) ugly-cycle-current-foreground (if iconified ugly-cycle-iconified-foreground (car ugly-cycle-color)))) + (text (trim (window-name w) font uglicon-width)) + (icon (get-window-icon w #:fade-to (and iconified (cdr ugly-cycle-color)))) + (index (index-of w win-list)) + (pos (cons+ (cons* (cons%/ index mi) (cons (+ uglicon-width (car ugly-cycle-padding)) (+ uglicon-height th))) (cons (justify iw width) 0) ugly-cycle-padding)) + (ipos (cons+ pos (cons-quotient (cons- (cons uglicon-width uglicon-height) (image-dimensions icon)) 2))) + (tpos (cons+ pos (cons (justify (text-width text font) uglicon-width) (+ uglicon-height (- th (font-descent font))))))) + (when (eq win w) + (setq rectangle (list color (cons- pos 1) (cons+ (cons uglicon-width (+ uglicon-height th)) 1)))) + (setq icons (list* (list icon ipos) icons)) + (list color tpos text font))) win-list))) +(let* +((fonts (list* ugly-cycle-current-font ugly-cycle-iconified-font ugly-cycle-font (and ugly-cycle-caption (list ugly-cycle-caption-font))))) + (setq + width (apply max 0 (mapcar (lambda (w) (apply max 0 (mapcar (lambda (f) (text-width (window-name w) f)) fonts))) win-list)) ; + 2*padding + labels + (mapcar + (lambda (w) + (let* + ((iconified (window-get w 'iconified)) + (font (if (eq w win) ugly-cycle-current-font (if iconified ugly-cycle-iconified-font ugly-cycle-font))) + (color (if (eq w win) ugly-cycle-current-foreground (if iconified ugly-cycle-iconified-foreground (car ugly-cycle-color)))) + (text (window-name w)) + (pos (cons+ (cons (justify (text-width text font) width) (+ height (font-ascent font))) ugly-cycle-padding))) + (setq height (+ height (font-height font))) ; font-height? + (list color pos text font))) win-list)))) + (when ugly-cycle-caption + (let* + ((text (window-name win)) + (font ugly-cycle-caption-font) + (color ugly-cycle-caption-foreground) + (pos (cons+ (cons (justify (text-width text font) width) (+ height (cdr ugly-cycle-padding) (font-ascent font))) ugly-cycle-padding))) + (setq height (+ height (cdr ugly-cycle-padding) (font-height font))) ; font-height? + (setq labels (nconc labels (list (list color pos text font)))))) + (setq width (+ width (* 2 (car ugly-cycle-padding))) height (+ height (* 2 (cdr ugly-cycle-padding)))) + (let* + ((dim (cons+ (cons width height) (* 2 (car ugly-cycle-border)))) + (pos (cons-max (cons-min (gravitate (ugly-cycle-display-position win) dim ugly-cycle-gravity) (cons- (screen-dimensions) dim)) 0)) + (repaint + (lambda () + (x-clear-window ugly-w) + (when rectangle + (x-change-gc ugly-g `((foreground . ,(nth 0 rectangle)))) + (x-draw-rectangle ugly-w ugly-g (nth 1 rectangle) (nth 2 rectangle))) + (mapc + (lambda (icon) + (x-draw-image (nth 0 icon) ugly-w (nth 1 icon))) icons) + (mapc + (lambda (label) + (x-change-gc ugly-g `((foreground . ,(nth 0 label)))) + (x-draw-string ugly-w ugly-g (nth 1 label) (nth 2 label) (nth 3 label))) labels)))) + (if ugly-w + (x-configure-window ugly-w + `((x . ,(car pos)) + (y . ,(cdr pos)) + (width . ,width) + (height . ,height) + (stack-mode . top-if))) + (setq ugly-w (x-create-window + pos (cons width height) (car ugly-cycle-border) + `((background . ,(cdr ugly-cycle-color)) + (border-color . ,(cdr ugly-cycle-border)) + (override-redirect . ,t) + (save-under . ,nil) + (event-mask . ,'(exposure))) + repaint) + ugly-g (x-create-gc + ugly-w + `((background . ,(cdr ugly-cycle-color))))) + (x-map-window ugly-w t)) + (repaint))) + + (define (ugly-cycle-hide) + (when ugly-w + (x-destroy-window ugly-w) + (setq ugly-w nil)) + (when ugly-g + (x-destroy-gc ugly-g) + (setq ugly-g nil)))) + + ;; function proxy + + (define (ugly-cycle-show-window-list win win-list) + (ugly-cycle-show win (if ugly-cycle-show-windows win-list (list win)))) + + (define (ugly-cycle-hide-window-list) + (ugly-cycle-hide)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; x-cycle ugly display stuff + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (eval-in + `(progn + (require 'merlin.ugliness) + + ;; an awful thing, copied from x-cycle.jl + (define (ugly-cycle-windows) + (let + ((win (window-order (if cycle-all-workspaces nil current-workspace) + cycle-include-iconified cycle-all-viewports))) + (unless (eq (fluid x-cycle-windows) t) + (setq win (delete-if (lambda (w) + (not (memq w (fluid x-cycle-windows)))) win))) + (setq win (delete-if-not window-in-cycle-p win)))) + + (define (cycle-display-message) + (ugly-cycle-show-window-list (fluid x-cycle-current) (ugly-cycle-windows))) + + (define (remove-message) + (ugly-cycle-hide-window-list))) + + 'sawfish.wm.commands.x-cycle) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; move-resize basic ugliness settings + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defgroup move-ugliness "Ugliness" :group move) + + (defcustom ugly-move-resize-relative 'window + "Display move/resize coordinates relative to: \\w" + :type symbol + :options (screen window) + :group (move move-ugliness)) + + (defcustom ugly-move-resize-percent (cons 50 50) + "Offset of move/resize coordinates as percentage of parent dimensions." + :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) + :group (move move-ugliness)) + + (defcustom ugly-move-resize-color (cons (get-color "black") (get-color "white")) + "Move/resize coordinates color." + :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) + :group (move move-ugliness)) + + (defcustom ugly-move-resize-font default-font + "Font for move/resize coordinates." + :type font + :group (move move-ugliness)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; move-resize advanced ugliness settings + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (defgroup move-extra-ugliness "Extra Ugliness" :group move) + + (defcustom ugly-move-resize-border (cons 2 (get-color "black")) + "Border around move-resize coordinates." + :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) + :group (move move-extra-ugliness)) + + (defcustom ugly-move-resize-padding (cons 4 4) + "Padding around move-resize coordinates." + :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) + :group (move move-extra-ugliness)) + + (defcustom ugly-move-resize-gravity 'center + "Gravity of move-resize coordinates." + :type symbol + :options + (north-west north north-east west center east south-west south south-east) + :group (move move-extra-ugliness)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; move-resize ugly display stuff + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (eval-in + `(progn + (require 'merlin.message) + (require 'merlin.util) + + (define (ugly-move-resize-display-message msg) + (let* + ((pos (if (eq ugly-move-resize-relative 'window) + (cons+ (cons move-resize-x move-resize-y) + (cons-percent (cons+ move-resize-frame (cons move-resize-width move-resize-height)) ugly-move-resize-percent)) + (cons-percent (screen-dimensions) ugly-move-resize-percent))) + (attrs `((position . ,pos) + (font . ,ugly-move-resize-font) + (foreground . ,(car ugly-move-resize-color)) + (background . ,(cdr ugly-move-resize-color)) + (border-color . ,(cdr ugly-move-resize-border)) + (border-width . ,(car ugly-move-resize-border)) + (padding . ,ugly-move-resize-padding) + (gravity . ,ugly-move-resize-gravity) + (spacing . ,0)))) + (fancy-message (list msg) attrs))) + + (define (display-message msg) + (if msg + (ugly-move-resize-display-message msg) + (hide-fancy-message)))) + + 'sawfish.wm.commands.move-resize)) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/util.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/util.jl new file mode 100644 index 000000000000..4d161a141ff4 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/util.jl @@ -0,0 +1,169 @@ +;; merlin/util.jl -- some utilities + +;; version 0.7.3 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +(define-structure merlin.util + + (export + fontify + colorify + wm-initialized + percent + assqd + split + index-of + rplac + cons-op + op-cons + cons+ cons- cons* cons% cons/ cons< cons> cons<= cons>= cons= cons%/ cons/% + cons-percent cons-quotient cons-min cons-max cons-and cons-or + and-cons or-cons +cons + trim + gravitate + screen-dimensions + viewport-offset + ceil) + + (open + rep + rep.regexp + rep.system + sawfish.wm.colors + sawfish.wm.fonts + sawfish.wm.misc + sawfish.wm.windows) + + ;; string/font -> font + (define (fontify font) + (if (stringp font) (get-font font) font)) + + ;; string/color -> color + (define (colorify color) + (if (stringp color) (get-color color) color)) + + (define after-initialization nil) + + (add-hook 'after-initialization-hook + (lambda () (setq after-initialization t))) + + ;; is the window manager initialized yet + (define (wm-initialized) ;; a hack + (or after-initialization (managed-windows))) + + ;; b % of a + (define (percent a b) + (quotient (* a b) 100)) + + ;; assq with default + (define (assqd key alist default) + (if (assq key alist) + (assq key alist) + (cons key default))) + + ;; split of "" is ("") + (define (split string separator) + (let + ((n (length string)) + (m (length separator)) + (point 0) + out end) + (while (<= point n) + (setq end (if (string-match separator string point) + (match-start) + (length string))) + (setq out (cons (substring string point end) out)) + (setq point (+ m end))) + (nreverse out))) + + ;; the index of item in list or -1 + (define (index-of item list) + (let loop ((rest list) (i 0)) + (cond + ((null rest) -1) + ((eq (car rest) item) i) + (t (loop (cdr rest) (1+ i)))))) + + ;; replace car and cdr + (define (rplac a b) + (rplaca a (car b)) + (rplacd a (cdr b))) + + ;; op of cons cells and values + (define (cons-op op a . rest) + (let + ((cars (mapcar (lambda (x) (if (consp x) (car x) x)) (list* a rest))) + (cdrs (mapcar (lambda (x) (if (consp x) (cdr x) x)) (list* a rest)))) + (cons (apply (or (car op) op) cars) (apply (or (cdr op) op) cdrs)))) + + ;; op of car and cdr + (define (op-cons op a) + (op (car a) (cdr a))) + + (defmacro defcons-ops ops + (append `(progn) (apply append (mapcar (lambda (op) + (let* + ((name (or (car op) op)) + (func (or (cdr op) op)) + (alpha (alpha-char-p (aref (symbol-name name) 0))) + (consop (intern (format nil (if alpha "cons-%s" "cons%s") name))) + (opcons (intern (format nil (if alpha "%s-cons" "%scons") name)))) + `((define (,consop a . rest) (apply cons-op ,func a rest)) + (define (,opcons a) (op-cons ,func a))))) ops)))) + + (define (myand . args) (let loop ((a args)) + (if (or (null (cdr a)) (not (car a))) (car a) (loop (cdr a))))) + + (define (myor . args) (let loop ((a args)) + (if (or (null (cdr a)) (car a)) (car a) (loop (cdr a))))) + + (defcons-ops + - * % / < > <= >= = percent quotient min max + (and . myand) (or . myor) (%/ . (cons % quotient)) (/% . (cons quotient %))) + + ;; trim text in specified font to specified width, appending ... + (define (trim text font width) + (if (<= (text-width text font) width) + text + (let loop ((s (concat text "...")) (n (length text))) + (if (or (= 0 n) (<= (text-width s font) width)) + s + (aset s (1- n) 46) + (loop (substring s 0 (+ 2 n)) (1- n)))))) + + ;; return position of object of specified dimensions gravitated around speified point + (define (gravitate pos dim gravity) + (cons (cond ((memq gravity '(north center south)) (- (car pos) (quotient (car dim) 2))) + ((memq gravity '(north-west west south-west)) (- (car pos) (car dim))) + (t (car pos))) + (cond ((memq gravity '(west center east)) (- (cdr pos) (quotient (cdr dim) 2))) + ((memq gravity '(north-west north north-west)) (- (cdr pos) (cdr dim))) + (t (cdr pos))))) + + ;; screen dimensions + (define (screen-dimensions) + (cons (screen-width) (screen-height))) + + ;; viewport offset + (define (viewport-offset) + (cons viewport-x-offset viewport-y-offset)) + + ;; ceiling quotient + (define (ceil a b) + (quotient (+ a (1- b)) b))) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x-util.jl b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x-util.jl new file mode 100644 index 000000000000..3a5ce38a10a0 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x-util.jl @@ -0,0 +1,95 @@ +;; merlin/x-util.jl -- some x utilities + +;; version -0.3 + +;; Copyright (C) 2000-2001 merlin <merlin@merlin.org> + +;; http://merlin.org/sawfish/ + +;; this 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; either version 2, or (at your option) +;; any later version. + +;; this 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 sawfish; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +(define-structure merlin.x-util + + (export + x-map-fn + x-configure-fn + x-set-wm-name + x-set-wm-icon-name + x-set-wm-class + x-set-wm-protocols + x-set-wm-size-hints + x-set-transient-for-hint + any-window-id + move-window-unconstrained + move-window-initial-pointer-offset) + + (open + rep + rep.system + sawfish.wm.misc + sawfish.wm.util.x + merlin.util) + + (define (x-map-fn) + (if (wm-initialized) x-map-request x-x-map-window)) + + (define (x-configure-fn) + (if (wm-initialized) x-configure-request x-configure-window)) + + (define (x-set-wm-name w name) + (x-set-text-property w (vector name) 'WM_NAME)) + + (define (x-set-wm-icon-name w name) + (x-set-text-property w (vector name) 'WM_ICON_NAME)) + + (define (x-set-wm-class w name class) + (x-set-text-property w (vector name class) 'WM_CLASS)) + + (define protocol-map `((delete-window . WM_DELETE_WINDOW))) + + (define (x-set-wm-protocols w protocols) + (let* + ((mapper (lambda (protocol) (cdr (assq protocol protocol-map)))) + (mapped (delete-if not (mapcar mapper protocols))) + (atoms (mapcar x-atom mapped))) + (x-change-property w 'WM_PROTOCOLS 'ATOM 32 + 'prop-mode-replace (apply vector atoms)))) + + (define (x-set-wm-size-hints w min max) + (x-change-property w 'WM_NORMAL_HINTS 'WM_SIZE_HINTS 32 'prop-mode-replace + (vector 48 0 0 0 0 (car min) (cdr min) (car max) (cdr max) 0 0 0 0 0 0 0))) + + (define (any-window-id window) + (cond + ((integerp window) window) + ((windowp window) (window-id window)) + ((x-window-p window) (x-window-id window)) + (t (error "unknown window type: %s" window)))) + + (define (x-set-transient-for-hint w parent) + (if (null parent) + (x-delete-property w 'WM_TRANSIENT_FOR) + (x-change-property w 'WM_TRANSIENT_FOR 'WINDOW 32 'prop-mode-replace (vector (any-window-id parent))))) + + (defvar move-window-preprocessed nil) ;; private + (defvar move-window-unconstrained nil) ;; allow move resize beyond screen bounds + (defvar move-window-initial-pointer-offset nil) ;; set/get initial pointer offset in window + + (add-hook 'after-move-hook + (lambda (w dirs) + (setq move-window-preprocessed nil) + (setq move-window-unconstrained nil) + (setq move-window-initial-pointer-offset nil))) +) diff --git a/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x.c.patch b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x.c.patch new file mode 100644 index 000000000000..f77cfa8bbfa0 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfish/lisp/merlin/x.c.patch @@ -0,0 +1,1364 @@ +# +# version -0.8.4 +# +# Copyright (C) 2000-2001 merlin <merlin@merlin.org> +# +# Built from sawfish 1.00. +# +# ********************* +# ** HERE BE DRAGONS ** +# ********************* +# +# This code contains horrendous hacks. It introduces the high +# probability of crashing your Window Manager and Rendering it +# Unstable and Destroying your Valuable Work and Property. +# +# Tnis is unlikely to work with earlier or later versions of +# Sawfish. +# +# Sawfish was not written with code of this nature on mind. +# +# More to the point, Sawfish was written with the express +# intention of this NOT EVER being done. As a result, this +# Software introduces the EXTREME PROBABILITY of FAILURE that +# DOES NOT EXIST in Sawfish itself. +# +# ****************** +# ** INSTALLATION ** +# ****************** +# +# I assume that you have a recent copy of the Sawfish +# source unpacked somewhere. +# +# Change into the `src' directory. +# cd sawfish-x.yz/src/ +# +# Run patch against this file to patch x.c: +# patch -p1 < /path/to/x.c.patch +# +# Compile and install Sawfish. +# make +# make install +# +# Restart Sawfish. +# +# Alternatively, you might want to install sawfish using +# some package manager, such as apt or RPM. Then you can +# build and locally install just the patched library using +# the following technique: +# make +# mkdir -p ~/.sawfish/lib/sawfish/wm/util +# cp src/.libs/x.* ~/.sawfish/lib +# cp src/.libs/x.* ~/.sawfish/lib/sawfish/wm/util +# +# You'll also need to add the following line to the *start* +# of your ~/.sawfishrc: +# (setq dl-load-path (cons "~/.sawfish/lib" dl-load-path)) +# +# Restart Sawfish. +# +# ****************** +# ** HERE BE BUGS ** +# ****************** +# +# Many XLib features are unimplemented and misimplemented. +# +# My understanding of rep modules is incomplete and erroneous. +# +# In order to support managed windows I introduced many hacks with +# UNKNOWN CONSEQUENCES. +# +# This code allows you to emulate being a distinct X application when you +# are in fact just a tiny part of a Window Manager that knows NOTHING +# about you. As a result, expect Window Management not to work as it +# should, and expect Your Application not to work as it should. You won't +# get events that you expect, you will get events that you don't and the +# Window Manager will simply not operate 100% as it should. +# +# In particular, if you create a managed window then it will probably be +# useless to you; you'll want to cover it with a child. +# +# One day I'll chop this off so it is a separate rep module that allows +# you to write standalone XLib applications that are not bastard, +# deformed monstrosities sprouting from the side of something beautiful. +# +# - merlin + +Index: src/x.c +=================================================================== +RCS file: /cvs/gnome/sawfish/src/x.c,v +retrieving revision 1.22 +diff -u -r1.22 x.c +--- src/x.c 2001/04/11 21:01:03 1.22 ++++ src/x.c 2001/09/09 11:57:09 +@@ -6,6 +6,9 @@ + Originally written by merlin <merlin@merlin.org>, with additions + from John Harper + ++ Then patched again by merlin to add some wicked functions: ++ x.c#pl:merlin/-0.8.4 ++ + This file is part of sawmill. + + sawmill is free software; you can redistribute it and/or modify it +@@ -72,6 +75,7 @@ + int is_pixmap : 1; + int is_bitmap : 1; /* depth == 1 */ + int width, height; ++ repv plist; + } Lisp_X_Window; + + #define X_XDRAWABLEP(v) rep_CELL16_TYPEP(v, x_window_type) +@@ -82,6 +86,8 @@ + #define X_PIXMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_pixmap) + #define X_BITMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_bitmap) + ++#define ANY_WINDOWP(w) (rep_INTEGERP(w) || X_WINDOWP(w) || (WINDOWP(w) && VWIN(w)->id != 0)) ++ + static Lisp_X_GC *x_gc_list = NULL; + int x_gc_type; + +@@ -115,6 +121,36 @@ + DEFSYM (clip_mask, "clip-mask"); + DEFSYM (clip_x_origin, "clip-x-origin"); + DEFSYM (clip_y_origin, "clip-y-origin"); ++DEFSYM (sibling, "sibling"); ++DEFSYM (stack_mode, "stack-mode"); ++DEFSYM (override_redirect, "override-redirect"); ++DEFSYM (save_under, "save-under"); ++DEFSYM (event_mask, "event-mask"); ++DEFSYM (parent, "parent"); ++DEFSYM (raise_lowest, "raise-lowest"); ++DEFSYM (lower_highest, "lower-highest"); ++ ++DEFSYM (serial, "serial"); ++DEFSYM (send_event, "send-event"); ++DEFSYM (window, "window"); ++DEFSYM (event, "event"); ++DEFSYM (subwindow, "subwindow"); ++DEFSYM (time, "time"); ++DEFSYM (x_root, "x-root"); ++DEFSYM (y_root, "y-root"); ++DEFSYM (state, "state"); ++DEFSYM (keycode, "keycode"); ++DEFSYM (same_screen, "same-screen"); ++DEFSYM (button, "button"); ++DEFSYM (is_hint, "is-hint"); ++DEFSYM (focus, "focus"); ++DEFSYM (mode, "mode"); ++DEFSYM (detail, "detail"); ++DEFSYM (count, "count"); ++DEFSYM (message_type, "message-type"); ++DEFSYM (format, "format"); ++DEFSYM (data, "data"); ++DEFSYM (above, "above"); + + DEFSYM (LineSolid, "line-solid"); + DEFSYM (LineOnOffDash, "line-on-off-dash"); +@@ -216,7 +252,60 @@ + return GXcopy; + } + ++static Atom ++x_symbol_atom (repv symbol) { ++ return XInternAtom (dpy, rep_STR (rep_SYM (symbol)->name), False); ++} ++ + ++/* Symbol matching Functions */ ++ ++typedef struct { ++ unsigned int value; ++ char *str; ++} x_value_str; ++ ++static repv ++x_value_match (unsigned int value, x_value_str *match) { ++ while (match->str) { ++ if (value == match->value) ++ return Fintern (rep_string_dup (match->str), Qnil); ++ ++ match; ++ } ++ return Qnil; ++} ++ ++static repv ++x_valuemask_match (unsigned int value, x_value_str *match) { ++ repv result = Qnil; ++ while (match->str) { ++ if (value & match->value) ++ result = Fcons (Fintern (rep_string_dup (match->str), Qnil), result); ++ ++ match; ++ } ++ return result; ++} ++ ++typedef struct { ++ char *str; ++ unsigned int value; ++} x_str_value; ++ ++static int ++x_symbol_match (repv symbol, x_str_value *match) { ++ char *tmp; ++ if (!rep_SYMBOLP (symbol)) ++ return -1; ++ tmp = rep_STR (rep_SYM (symbol)->name); ++ while (match->str) { ++ if (!strcmp (match->str, tmp)) ++ return match->value; ++ ++ match; ++ } ++ return -1; ++} ++ ++ + /* GC Functions */ + + static long +@@ -470,6 +559,16 @@ + return Qt; + } + ++DEFUN ("x-free-gc", Fx_free_gc, Sx_free_gc, (repv gc), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-free-gc:: ++x-free-gc X-GC ++ ++Free the X-GC. Same as x-destroy-gc. ++::end:: */ ++{ ++ return Fx_destroy_gc (gc); ++} ++ + DEFUN ("x-gc-p", Fx_gc_p, Sx_gc_p, (repv gc), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-gc-p:: + x-gcp ARG +@@ -483,6 +582,15 @@ + + /* Window functions */ + ++static x_str_value x_stack_mode_matches[] = { ++ { "above", Above }, ++ { "below", Below }, ++ { "top-if", TopIf }, ++ { "bottom-if", BottomIf }, ++ { "opposite", Opposite }, ++ { 0, 0 } ++}; ++ + static long + x_window_parse_changes (XWindowChanges *changes, repv attrs) + { +@@ -520,6 +628,24 @@ + changes->border_width = rep_INT (rep_CDR (tem)); + changesMask |= CWBorderWidth; + } ++ else if (car == Qsibling) ++ { ++ Window sibling = window_from_arg (rep_CDR (tem)); ++ if (sibling) ++ { ++ changes->sibling = sibling; ++ changesMask |= CWSibling; ++ } ++ } ++ else if (car == Qstack_mode) ++ { ++ int stack_mode = x_symbol_match (rep_CDR (tem), x_stack_mode_matches); ++ if (stack_mode != -1) ++ { ++ changes->stack_mode = stack_mode; ++ changesMask |= CWStackMode; ++ } ++ } + } + + attrs = rep_CDR (attrs); +@@ -537,6 +663,35 @@ + w->height = changes->height; + } + ++static x_str_value x_event_mask_matches[] = { ++ { "key-press", KeyPressMask }, ++ { "key-release", KeyReleaseMask }, ++ { "button-press", ButtonPressMask }, ++ { "button-release", ButtonReleaseMask }, ++ { "enter-window", EnterWindowMask }, ++ { "leave-window", LeaveWindowMask }, ++ { "pointer-motion", PointerMotionMask }, ++ { "pointer-motion-hint", PointerMotionHintMask }, ++ { "button-1-motion", Button1MotionMask }, ++ { "button-2-motion", Button2MotionMask }, ++ { "button-3-motion", Button3MotionMask }, ++ { "button-4-motion", Button4MotionMask }, ++ { "button-5-motion", Button5MotionMask }, ++ { "button-motion", ButtonMotionMask }, ++ { "keymap-state", KeymapStateMask }, ++ { "exposure", ExposureMask }, ++ { "visibility-change", VisibilityChangeMask }, ++ { "structure-notify", StructureNotifyMask }, ++ { "resize-redirect", ResizeRedirectMask }, ++ { "substructure-notify", SubstructureNotifyMask }, ++ { "substructure-redirect", SubstructureRedirectMask }, ++ { "focus-change", FocusChangeMask }, ++ { "property-change", PropertyChangeMask }, ++ { "colormap-change", ColormapChangeMask }, ++ { "owner-grab-button", OwnerGrabButtonMask }, ++ { 0, 0 } ++}; ++ + static long + x_window_parse_attributes (XSetWindowAttributes *attributes, repv attrs) + { +@@ -559,6 +714,28 @@ + attributes->border_pixel = VCOLOR (rep_CDR (tem))->pixel; + attributesMask |= CWBorderPixel; + } ++ else if (car == Qoverride_redirect) ++ { ++ attributes->override_redirect = rep_NILP(rep_CDR(tem)) ? False : True; ++ attributesMask |= CWOverrideRedirect; ++ } ++ else if (car == Qsave_under) ++ { ++ attributes->save_under = rep_NILP(rep_CDR(tem)) ? False : True; ++ attributesMask |= CWSaveUnder; ++ } ++ else if ((car == Qevent_mask) && rep_LISTP(rep_CDR(tem))) ++ { ++ repv evl = rep_CDR (tem); ++ attributes->event_mask = 0; ++ while (rep_CONSP (evl)) { ++ int mask = x_symbol_match (rep_CAR (evl), x_event_mask_matches); ++ if (mask != -1) ++ attributes->event_mask |= mask; ++ evl = rep_CDR (evl); ++ } ++ attributesMask |= CWEventMask; ++ } + } + + attrs = rep_CDR (attrs); +@@ -567,32 +744,265 @@ + return attributesMask; + } + ++/* inefficient */ ++static x_value_str x_event_type_matches[] = { ++ { KeyPress, "key-press" }, ++ { KeyRelease, "key-release" }, ++ { ButtonPress, "button-press" }, ++ { ButtonRelease, "button-release" }, ++ { MotionNotify, "motion-notify" }, ++ { EnterNotify, "enter-notify" }, ++ { LeaveNotify, "leave-notify" }, ++ { FocusIn, "focus-in" }, ++ { FocusOut, "focus-out" }, ++ { KeymapNotify, "keymap-notify" }, ++ { Expose, "expose" }, ++ { GraphicsExpose, "graphics-expose" }, ++ { NoExpose, "no-expose" }, ++ { VisibilityNotify, "visibility-notify" }, ++ { CreateNotify, "create-notify" }, ++ { DestroyNotify, "destroy-notify" }, ++ { UnmapNotify, "unmap-notify" }, ++ { MapNotify, "map-notify" }, ++ { MapRequest, "map-request" }, ++ { ReparentNotify, "reparent-notify" }, ++ { ConfigureNotify, "configure-notify" }, ++ { ConfigureRequest, "configure-request" }, ++ { GravityNotify, "gravity-notify" }, ++ { ResizeRequest, "resize-request" }, ++ { CirculateNotify, "circulate-notify" }, ++ { CirculateRequest, "circulate-request" }, ++ { PropertyNotify, "property-notify" }, ++ { SelectionClear, "selection-clear" }, ++ { SelectionRequest, "selection-request" }, ++ { SelectionNotify, "selection-notify" }, ++ { ColormapNotify, "colormap-notify" }, ++ { ClientMessage, "client-message" }, ++ { MappingNotify, "mapping-notify" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_crossing_mode_matches[] = { ++ { NotifyNormal, "notify-normal" }, ++ { NotifyGrab, "notify-grab" }, ++ { NotifyUngrab, "notify-ungrab" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_crossing_detail_matches[] = { ++ { NotifyAncestor, "notify-ancestor" }, ++ { NotifyVirtual, "notify-virtual" }, ++ { NotifyInferior, "notify-inferior" }, ++ { NotifyNonlinear, "notify-nonlinear" }, ++ { NotifyNonlinearVirtual, "notify-nonlinear-virtual" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_motion_is_hint_matches[] = { ++ { NotifyNormal, "notify-normal" }, ++ { NotifyHint, "notify-hint" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_button_matches[] = { ++ { Button1, "button-1" }, ++ { Button2, "button-2" }, ++ { Button3, "button-3" }, ++ { Button4, "button-4" }, ++ { Button5, "button-5" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_state_matches[] = { ++ { Button1Mask, "button-1" }, ++ { Button2Mask, "button-2" }, ++ { Button3Mask, "button-3" }, ++ { Button4Mask, "button-4" }, ++ { Button5Mask, "button-5" }, ++ { ShiftMask, "shift" }, ++ { LockMask, "lock" }, ++ { ControlMask, "control" }, ++ { Mod1Mask, "mod-1" }, ++ { Mod2Mask, "mod-2" }, ++ { Mod3Mask, "mod-3" }, ++ { Mod4Mask, "mod-4" }, ++ { Mod5Mask, "mod-5" }, ++ { 0, 0 } ++}; ++ ++static repv ++x_encode_keysym (unsigned int keycode, unsigned int state) { ++ KeySym sym = NoSymbol; ++ char *name; ++ if (state & ShiftMask) ++ sym = XKeycodeToKeysym (dpy, keycode, 1); ++ if (sym == NoSymbol) ++ sym = XKeycodeToKeysym (dpy, keycode, 0); ++ /* I don't reset the shift modifier!!! */ ++ name = XKeysymToString (sym); ++ return name ? Fintern (rep_string_dup (name), Qnil) : Qnil; ++} ++ ++#define ALIST_PRE(A,B,C) A = Fcons (Fcons (B, C), A) ++ ++static repv x_window_or_int_from_id (Window window) { ++ repv tmp = x_window_from_id (window); ++ if (tmp == Qnil) ++ tmp = rep_MAKE_INT (window); ++ return tmp; ++} ++ ++static repv ++x_encode_event (XEvent *ev) ++{ ++ repv event = Qnil, data = Qnil; ++ ++ ALIST_PRE (event, Qserial, rep_make_long_uint (ev->xany.serial)); ++ ALIST_PRE (event, Qsend_event, ev->xany.send_event ? Qt : Qnil); ++ ALIST_PRE (event, Qwindow, x_window_from_id (ev->xany.window)); ++ ++ switch (ev->type) { ++ case KeyPress: ++ case KeyRelease: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xkey.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xkey.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xkey.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xkey.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xkey.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xkey.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xkey.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xkey.state, x_state_matches)); ++ ALIST_PRE (event, Qkeycode, x_encode_keysym (ev->xkey.keycode, ev->xkey.state)); ++ ALIST_PRE (event, Qsame_screen, ev->xkey.same_screen ? Qt : Qnil); ++ break; ++ ++ case ButtonPress: ++ case ButtonRelease: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xbutton.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xbutton.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xbutton.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xbutton.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xbutton.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xbutton.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xbutton.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xbutton.state, x_state_matches)); ++ ALIST_PRE (event, Qbutton, x_value_match (ev->xbutton.button, x_button_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xbutton.same_screen ? Qt : Qnil); ++ break; ++ ++ case MotionNotify: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xmotion.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xmotion.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xmotion.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xmotion.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xmotion.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xmotion.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xmotion.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xmotion.state, x_state_matches)); ++ ALIST_PRE (event, Qis_hint, x_value_match (ev->xmotion.is_hint, x_motion_is_hint_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xmotion.same_screen ? Qt : Qnil); ++ break; ++ ++ case EnterNotify: ++ case LeaveNotify: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xcrossing.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xcrossing.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xcrossing.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xcrossing.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xcrossing.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xcrossing.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xcrossing.y_root)); ++ ALIST_PRE (event, Qmode, x_value_match (ev->xcrossing.mode, x_crossing_mode_matches)); ++ ALIST_PRE (event, Qdetail, x_value_match (ev->xcrossing.detail, x_crossing_detail_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xcrossing.same_screen ? Qt : Qnil); ++ ALIST_PRE (event, Qfocus, ev->xcrossing.focus ? Qt : Qnil); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xcrossing.state, x_state_matches)); ++ break; ++ ++ case Expose: ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xexpose.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xexpose.y)); ++ ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xexpose.width)); ++ ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xexpose.height)); ++ ALIST_PRE (event, Qcount, rep_MAKE_INT (ev->xexpose.count)); ++ break; ++ ++ case DestroyNotify: ++ ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xdestroywindow.event)); ++ ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xdestroywindow.window)); ++ break; ++ ++ case ConfigureNotify: ++ ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xconfigure.event)); ++ ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xconfigure.window)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xconfigure.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xconfigure.y)); ++ ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xconfigure.width)); ++ ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xconfigure.height)); ++ ALIST_PRE (event, Qborder_width, rep_MAKE_INT (ev->xconfigure.border_width)); ++ ALIST_PRE (event, Qabove, x_window_or_int_from_id (ev->xconfigure.above)); ++ ALIST_PRE (event, Qoverride_redirect, ev->xconfigure.override_redirect ? Qt : Qnil); ++ break; ++ ++ case ClientMessage: ++ ALIST_PRE (event, Qmessage_type, x_atom_symbol (ev->xclient.message_type)); ++ ALIST_PRE (event, Qformat, rep_MAKE_INT (ev->xclient.format)); ++ data = Qnil; ++ switch (ev->xclient.format) { ++ int i; ++ ++ case 8: /* not a string because length unknown */ ++ data = Fmake_vector (rep_MAKE_INT (20), Qnil); ++ for (i = 0; i < 20; ++ i) ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.b[i]); ++ break; ++ ++ case 16: ++ data = Fmake_vector (rep_MAKE_INT (10), Qnil); ++ for (i = 0; i < 10; ++ i) ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.s[i]); ++ break; ++ ++ case 32: ++ data = Fmake_vector (rep_MAKE_INT (5), Qnil); ++ for (i = 0; i < 5; ++ i) /* decoding atoms makes little sense */ ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.l[i]); ++ break; ++ } ++ ALIST_PRE (event, Qdata, data); ++ break; ++ } ++ ++ /* ++ not done... ++ FocusIn FocusOut KeymapNotify GraphicsExpose NoExpose VisibilityNotify ++ CreateNotify UnmapNotify MapNotify MapRequest ReparentNotify ++ ConfigureRequest GravityNotify ResizeRequest CirculateNotify ++ CirculateRequest PropertyNotify SelectionClear SelectionRequest ++ SelectionNotify ColormapNotify MappingNotify ++ */ ++ ++ return event; ++} ++ + static void + x_window_event_handler (XEvent *ev) + { + repv win = x_window_from_id (ev->xany.window); + if (win != Qnil && VX_DRAWABLE (win)->event_handler != Qnil) + { +- repv type = Qnil, args = Qnil; +- switch (ev->type) +- { +- case Expose: +- /* Since we don't provide a method of detecting which +- part of the window to redraw, ignore all but the last +- expose event. (Another option is to set the clip +- rectangle?) */ +- if (ev->xexpose.count == 0) +- type = Qexpose; +- break; +- +- /* XXX other event types..? */ +- } +- if (type != Qnil) +- { +- args = Fcons (type, Fcons (win, args)); +- rep_funcall (VX_DRAWABLE (win)->event_handler, args, rep_FALSE); +- } ++ repv type = x_value_match (ev->type, x_event_type_matches); ++ repv event = x_encode_event (ev); ++ repv args = Fcons (type, Fcons (win, Fcons (event, Qnil))); ++ /* Note that in Sawfish 0.34+, expose events whose count is non ++ * zero are silently suppressed. I don't do that because I ++ * supply the count. Which means that other people's expose ++ * handlers will be called multiply... */ ++ rep_funcall (VX_DRAWABLE(win)->event_handler, args, rep_FALSE); + } ++ ++ if (ev->type < LASTEvent && event_handlers[ev->type] != 0) ++ event_handlers[ev->type] (ev); + } + + static Lisp_X_Window * +@@ -608,10 +1018,37 @@ + w->height = height; + w->is_window = w->is_pixmap = w->is_bitmap = 0; + w->event_handler = Qnil; ++ w->plist = Qnil; + XSaveContext (dpy, id, x_drawable_context, (XPointer) w); + return w; + } + ++DEFUN ("x-reparent-window", Fx_reparent_window, Sx_reparent_window, ++ (repv win, repv parent, repv xy), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-create-window:: ++x-create-window WINDOW PARENT (X . Y) ++ ++Reparents a windows. ++::end:: */ ++{ ++ Window _win, _parent; ++ int _x, _y; ++ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ rep_DECLARE (2, parent, (parent == Qnil) || ANY_WINDOWP (parent)); ++ rep_DECLARE (3, xy, rep_CONSP (xy) ++ && rep_INTP (rep_CAR (xy)) && rep_INTP (rep_CDR (xy))); ++ ++ _win = window_from_arg (win); ++ _parent = (parent == Qnil) ? root_window : window_from_arg (parent); ++ _x = rep_INT (rep_CAR (xy)); ++ _y = rep_INT (rep_CDR (xy)); ++ ++ XReparentWindow (dpy, _win, _parent, _x, _y); ++ ++ return Qt; ++} ++ + DEFUN ("x-create-window", Fx_create_window, Sx_create_window, + (repv xy, repv wh, repv bw, repv attrs, repv ev), rep_Subr5) /* + ::doc:sawfish.wm.util.x#x-create-window:: +@@ -619,12 +1056,15 @@ + + Creates a new X-WINDOW with the specified position, dimensions and + border width. ATTRS should be a list of cons cells mapping attributes +-to values. Known attributes are `background' and `border-color'. The +-window is created unmapped. ++to values. Known attributes include the symbols `x', `y', ++`width', `height', `border-width', `sibling' and `stack-mode'. Valid ++values for stack-mode are `above', `below', `top-if', `bottom-if' and ++`opposite'. The window is created unmapped. + ::end:: */ + { + Lisp_X_Window *w; +- Window id; ++ repv parent = Qnil; ++ Window id, _parent; + XSetWindowAttributes attributes; + long attributesMask; + int _x, _y, _w, _h, _bw; +@@ -636,6 +1076,11 @@ + rep_DECLARE3 (bw, rep_INTP); + rep_DECLARE4 (attrs, rep_LISTP); + ++ if (rep_CONSP (attrs) && (Fassq (Qparent, attrs) != Qnil)) ++ parent = rep_CDR (Fassq (Qparent, attrs)); ++ if (!(_parent = window_from_arg (parent))) ++ _parent = root_window; ++ + _x = rep_INT (rep_CAR (xy)); + _y = rep_INT (rep_CDR (xy)); + _w = rep_INT (rep_CAR (wh)); +@@ -643,19 +1088,21 @@ + _bw = rep_INT (bw); + + attributesMask = x_window_parse_attributes (&attributes, attrs); +- attributes.override_redirect = True; +- attributes.event_mask = ExposureMask; +- attributes.colormap = image_cmap; ++ if (! (attributesMask & CWOverrideRedirect)) ++ { ++ attributes.override_redirect = True; ++ attributesMask |= CWOverrideRedirect; ++ } + if (! (attributesMask & CWBorderPixel)) + { + attributes.border_pixel = BlackPixel (dpy, + BlackPixel (dpy, screen_num)); + attributesMask |= CWBorderPixel; + } +- +- attributesMask |= CWOverrideRedirect | CWEventMask | CWColormap; ++ attributes.colormap = image_cmap; ++ attributesMask |= CWOverrideRedirect; + +- id = XCreateWindow (dpy, root_window, _x, _y, _w, _h, _bw, ++ id = XCreateWindow (dpy, _parent, _x, _y, _w, _h, _bw, + image_depth, InputOutput, image_visual, + attributesMask, &attributes); + +@@ -708,6 +1155,37 @@ + return rep_VAL (w); + } + ++DEFUN("x-map-notify", Fx_map_notify, Sx_map_notify, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-notify:: ++x-map-notify X-WINDOW ++::end:: */ ++{ ++ XEvent fake = { MapNotify }; /* ouch the pain */ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ ++ fake.xmap.window = window_from_arg (win); ++ fake.xmap.event = fake.xmap.window; ++ ++ event_handlers[MapNotify] (&fake); ++ ++ return Qt; ++} ++ ++DEFUN("x-map-request", Fx_map_request, Sx_map_request, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-request:: ++x-map-request X-WINDOW ++::end:: */ ++{ ++ XEvent fake = { MapRequest }; /* ouch the pain */ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ ++ fake.xmaprequest.window = window_from_arg (win); ++ ++ event_handlers[MapRequest] (&fake); ++ ++ return Qt; ++} ++ + DEFUN ("x-map-window", Fx_map_window, Sx_map_window, + (repv win, repv unraised), rep_Subr2) /* + ::doc:sawfish.wm.util.x#x-map-window:: +@@ -722,6 +1200,38 @@ + return Qt; + } + ++DEFUN ("x-x-map-window", Fx_x_map_window, Sx_x_map_window, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-map-window:: ++x-x-map-window X-WINDOW ++ ++The real XMapWindow. ++::end:: */ ++{ ++ rep_DECLARE1 (win, ANY_WINDOWP); ++ XMapWindow (dpy, window_from_arg (win)); ++ return Qt; ++} ++ ++DEFUN("x-map-raised", Fx_map_raised, Sx_map_raised, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-raised:: ++x-map-raised X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XMapRaised (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ ++DEFUN("x-map-subwindows", Fx_map_subwindows, Sx_map_subwindows, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-subwindows:: ++x-map-subwindows X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XMapSubwindows (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ + DEFUN ("x-unmap-window", Fx_unmap_window, + Sx_unmap_window, (repv win), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-unmap-window:: +@@ -733,6 +1243,50 @@ + return Qt; + } + ++DEFUN("x-unmap-subwindows", Fx_unmap_subwindows, Sx_unmap_subwindows, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-unmap-subwindows:: ++x-unmap-subwindows X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XUnmapSubwindows (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ ++DEFUN("x-configure-request", Fx_configure_request, Sx_configure_request, (repv window, repv attrs), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-configure-request:: ++x-configure-request WINDOW ATTRS ++::end:: */ ++{ ++ XWindowChanges changes; ++ long changesMask; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(attrs, rep_LISTP); ++ ++ changesMask = x_window_parse_changes (&changes, attrs); ++ ++ if (changesMask) ++ { ++ XEvent fake = { ConfigureRequest }; ++ ++ fake.xconfigurerequest.display = dpy; ++ fake.xconfigurerequest.window = VX_DRAWABLE(window)->id; ++ fake.xconfigurerequest.x = changes.x; ++ fake.xconfigurerequest.y = changes.y; ++ fake.xconfigurerequest.width = changes.width; ++ fake.xconfigurerequest.height = changes.height; ++ fake.xconfigurerequest.border_width = changes.border_width; ++ fake.xconfigurerequest.above = changes.sibling; ++ fake.xconfigurerequest.detail = changes.stack_mode; ++ fake.xconfigurerequest.value_mask = changesMask; ++ ++ event_handlers[ConfigureRequest] (&fake); ++ } ++ ++ return Qt; ++} ++ + DEFUN ("x-configure-window", Fx_configure_window, + Sx_configure_window, (repv window, repv attrs), rep_Subr2) /* + ::doc:sawfish.wm.util.x#x-configure-window:: +@@ -740,20 +1294,22 @@ + + Reconfigures the X-WINDOW. ATTRS should be an alist mapping attribute + names to values. Known attributes include the symbols `x', `y', +-`width', `height' and `border-width'. ++`width', `height', `border-width', `sibling' and `stack-mode'. Valid ++values for stack-mode are `above', `below', `top-if', `bottom-if' and ++`opposite'. + ::end:: */ + { + XWindowChanges changes; + long changesMask; + +- rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (attrs, rep_LISTP); + + changesMask = x_window_parse_changes (&changes, attrs); + + if (changesMask) + { +- XConfigureWindow (dpy, VX_DRAWABLE (window)->id, ++ XConfigureWindow (dpy, window_from_arg (window), + changesMask, &changes); + x_window_note_changes (VX_DRAWABLE (window), changesMask, &changes); + } +@@ -774,20 +1330,118 @@ + XSetWindowAttributes attributes; + long attributesMask; + +- rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (attrs, rep_LISTP); + + attributesMask = x_window_parse_attributes (&attributes, attrs); + + if (attributesMask) + { +- XChangeWindowAttributes (dpy, VX_DRAWABLE (window)->id, ++ XChangeWindowAttributes (dpy, window_from_arg (window), + attributesMask, &attributes); + } + + return Qt; + } + ++DEFUN("x-x-raise-window", Fx_x_raise_window, Sx_x_raise_window, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-raise-window:: ++x-x-raise-window WINDOW ++ ++The real XRaiseWindow. Raises the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XRaiseWindow (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-x-lower-window", Fx_x_lower_window, Sx_x_lower_window, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-lower-window:: ++x-x-lower-window WINDOW ++ ++The real XLowerWindow. Lowers the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XLowerWindow (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows", Fx_circulate_subwindows, Sx_circulate_subwindows, (repv window, repv direction), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows:: ++x-circulate-subwindows WINDOW DIRECTION ++ ++Circulates the subwindows of the X-WINDOW in DIRECTION ++for either `raise-lowest' or `lower-highest'. ++::end:: */ ++{ ++ int _direction; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE(2, direction, (direction == Qraise_lowest) || (direction == Qlower_highest)); ++ _direction = (direction == Qraise_lowest) ? RaiseLowest : LowerHighest; ++ ++ XCirculateSubwindows (dpy, VX_DRAWABLE(window)->id, _direction); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows-up", Fx_circulate_subwindows_up, Sx_circulate_subwindows_up, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows-up:: ++x-circulate-subwindows-up WINDOW ++ ++Circulates up the subwindows of the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XCirculateSubwindowsUp (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows-down", Fx_circulate_subwindows_down, Sx_circulate_subwindows_down, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows-down:: ++x-circulate-subwindows-down WINDOW ++ ++Circulates down the subwindows of the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XCirculateSubwindowsDown (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-restack-windows", Fx_restack_windows, Sx_restack_windows, (repv list), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-restack-windows:: ++x-restack-windows LIST ++ ++Restacks the LIST of X-WINDOWs. ++::end:: */ ++{ ++ Window *windows; ++ int n = 0; ++ ++ rep_DECLARE1(list, rep_LISTP); ++ ++ windows = alloca (rep_INT (Flength (list)) * sizeof (Window)); ++ while (rep_CONSP (list)) { ++ if (X_WINDOWP (rep_CAR (list))) ++ windows[n ++] = VX_DRAWABLE (rep_CAR (list))->id; ++ list = rep_CDR (list); ++ } ++ XRestackWindows (dpy, windows, n); ++ ++ return Qt; ++} ++ + DEFUN ("x-destroy-drawable", Fx_destroy_drawable, + Sx_destroy_drawable, (repv drawable), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-destroy-drawable:: +@@ -959,6 +1613,268 @@ + } + + ++/* Lisp property functions */ ++ ++DEFUN ("x-window-put", Fx_window_put, Sx_window_put, (repv window, repv key, repv value), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-window-put:: ++x-window-put WINDOW KEY VALUE ++ ++Stores the specified VALUE in the specified WINDOW under the specified ++(symbolic) KEY. ++::end:: */ ++{ ++ repv plist, ptr; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(key, rep_SYMBOLP); ++ ++ ptr = plist = VX_DRAWABLE(window)->plist; ++ while (ptr != Qnil) { ++ repv cons = rep_CAR (ptr); ++ if (rep_CAR (cons) == key) { ++ rep_CDR (cons) = value; ++ return Qt; ++ } ++ ptr = rep_CDR (ptr); ++ } ++ VX_DRAWABLE(window)->plist = Fcons (Fcons (key, value), plist); ++ ++ return Qt; ++} ++ ++DEFUN ("x-window-get", Fx_window_get, Sx_window_get, (repv window, repv key), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-window-get:: ++x-window-get WINDOW KEY ++ ++Gets the value stored in the specified WINDOW under the specified ++(symbolic) KEY. ++::end:: */ ++{ ++ repv plist, ptr; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(key, rep_SYMBOLP); ++ ++ ptr = plist = VX_DRAWABLE(window)->plist; ++ while (ptr != Qnil) { ++ repv cons = rep_CAR (ptr); ++ if (rep_CAR (cons) == key) ++ return rep_CDR (cons); ++ ptr = rep_CDR (ptr); ++ } ++ ++ return Qnil; ++} ++ ++ ++/* X property functions */ ++ ++DEFUN("x-set-text-property", Fx_set_text_property, Sx_set_text_property, (repv window, repv textv, repv property), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-set-text-property:: ++x-set-text-property X-WINDOW TEXTV PROPERTY ++ ++Sets the specified PROPERTY on the specified X-WINDOW to the specified ++value TEXTV, a vector of strings. ++::end:: */ ++{ ++ Atom _prop; ++ int i, n; ++ char **_textv; ++ XTextProperty textprop; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE2 (textv, rep_VECTORP); ++ n = rep_VECT_LEN (textv); ++ for (i = 0; i < n; ++ i) ++ rep_DECLARE (2, textv, rep_STRINGP (rep_VECTI (textv, i))); ++ rep_DECLARE3 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ _textv = alloca (n * sizeof (char *)); ++ for (i = 0; i < n; ++ i) ++ _textv[i] = rep_STR (rep_VECTI (textv, i)); ++ if (!XStringListToTextProperty (_textv, n, &textprop)) ++ return Qnil; ++ ++ XSetTextProperty (dpy, VX_DRAWABLE(window)->id, &textprop, _prop); ++ XFree (textprop.value); ++ ++ return Qt; ++} ++ ++DEFUN("x-get-text-property", Fx_get_text_property, Sx_get_text_property, (repv window, repv property), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-get-text-property:: ++x-get-text-property X-WINDOW PROPERTY ++ ++Gets the specified PROPERTY of the specified X-WINDOW as a vector ++of strings. ++::end:: */ ++{ ++ Atom _prop; ++ XTextProperty textprop; ++ int i, n; ++ char **_textv; ++ repv textv; ++ ++ rep_DECLARE1 (window, ANY_WINDOWP); ++ rep_DECLARE2 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ if (!XGetTextProperty (dpy, window_from_arg (window), &textprop, _prop)) ++ return Qnil; ++ if (!XTextPropertyToStringList (&textprop, &_textv, &n)) { ++ XFree (textprop.value); ++ return Qnil; ++ } ++ XFree (textprop.value); ++ textv = Fmake_vector (rep_MAKE_INT (n), Qnil); ++ for (i = 0; i < n; ++ i) ++ rep_VECTI (textv, i) = rep_string_dup (_textv[i]); ++ XFreeStringList (_textv); ++ ++ return textv; ++} ++ ++DEFUN("x-list-properties", Fx_list_properties, Sx_list_properties, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-list-properties:: ++x-list-properties X-WINDOW ++ ++Returns a list of the properties of the specified X-WINDOW. ++::end:: */ ++{ ++ Atom *atoms; ++ char **_props; ++ repv props = Qnil; ++ int i, n; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ ++ atoms = XListProperties (dpy, VX_DRAWABLE(window)->id, &n); ++ if (!atoms) ++ return Qnil; ++ _props = alloca (n * sizeof (char *)); ++ if (!XGetAtomNames (dpy, atoms, n, _props)) { ++ XFree (atoms); ++ return Qnil; ++ } ++ XFree (atoms); ++ for (i = n - 1; i >= 0; -- i) ++ props = Fcons (Fintern (rep_string_dup (_props[i]), Qnil), props); ++ for (i = 0; i < n; ++ i) ++ XFree (_props[i]); ++ ++ return props; ++} ++ ++static x_str_value x_change_property_mode_matches[] = { ++ { "prop-mode-replace", PropModeReplace }, ++ { "prop-mode-prepend", PropModePrepend }, ++ { "prop-mode-append", PropModeAppend }, ++ { 0, 0 } ++}; ++ ++#define nDECLARE(index,arg, assert) {\ ++ rep_DECLARE (index, args, rep_CONSP (args));\ ++ arg = rep_CAR (args);\ ++ args = rep_CDR (args);\ ++ rep_DECLARE (index, arg, assert);\ ++} ++ ++DEFUN("x-change-property", Fx_change_property, Sx_change_property, (repv args), rep_SubrN) /* ++::doc:sawfish.wm.util.x#x-change-property:: ++x-change-property X-WINDOW PROPERTY TYPE FORMAT MODE DATAV ++ ++Sets the specified PROPERTY in the specified X-WINDOW to the ++specified TYPE vector value DATAV in format FORMAT. MODE can be ++`prop-mode-replace', `prop-mode-prepend' or `prop-mode-append'. ++::end:: */ ++{ ++ repv window, property, type, format, mode, datav; ++ Window _window; ++ Atom _property, _type; ++ int _format, _mode; ++ void *_data; ++ int i, n; ++ ++ nDECLARE (1, window, ANY_WINDOWP (window)); ++ _window = window_from_arg (window); ++ nDECLARE (2, property, rep_SYMBOLP (property)); ++ _property = x_symbol_atom (property); ++ nDECLARE (3, type, rep_SYMBOLP (type)); ++ _type = x_symbol_atom (type); ++ nDECLARE (4, format, rep_INTP (format)); ++ _format = rep_INT (format); ++ rep_DECLARE (4, format, (_format == 8) || (_format == 16) || (_format == 32));; ++ nDECLARE (5, mode, rep_SYMBOLP (mode)); ++ _mode = x_symbol_match (mode, x_change_property_mode_matches); ++ rep_DECLARE (5, mode, (_mode != -1)); ++ nDECLARE (6, datav, rep_VECTORP (datav)); ++ n = rep_VECT_LEN (datav); ++ for (i = 0; i < n; ++ i) ++ rep_DECLARE (6, datav, rep_INTP (rep_VECTI (datav, i))); ++ ++ _data = alloca (n * 4); ++ for (i = 0; i < n; ++ i) { ++ int datum = rep_INT (rep_VECTI (datav, i)); ++ if (format == 8) ++ ((char *) _data)[i] = (char) datum; ++ else if (format == 16) ++ ((short *) _data)[i] = (short) datum; ++ else ++ ((int *) _data)[i] = datum; ++ } ++ XChangeProperty (dpy, _window, _property, _type, _format, _mode, _data, n); ++ ++ return Qt; ++} ++ ++DEFUN("x-rotate-window-properties", Fx_rotate_window_properties, Sx_rotate_window_properties, (repv window, repv list, repv npos), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-rotate-window-properties:: ++x-rotate-window-properties X-WINDOW PROPERTIES NPOS ++ ++Rotates the values of the specified list of X-WINDOW PROPERTIES by NPOS. ++::end:: */ ++{ ++ Atom *atoms; ++ int n = 0; ++ int _npos; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE2 (list, rep_LISTP); ++ rep_DECLARE3 (npos, rep_INTP); ++ ++ _npos = rep_INT (npos); ++ ++ atoms = alloca (rep_INT (Flength (list)) * sizeof (Atom)); ++ while (rep_CONSP (list)) { ++ if (rep_SYMBOLP (rep_CAR (list))) ++ atoms[n ++] = x_symbol_atom (rep_CAR (list)); ++ list = rep_CDR (list); ++ } ++ XRotateWindowProperties (dpy, VX_DRAWABLE(window)->id, atoms, n, _npos); ++ ++ return Qt; ++} ++ ++DEFUN("x-delete-property", Fx_delete_property, Sx_delete_property, (repv window, repv property), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-delete-property:: ++x-delete-property X-WINDOW PROPERTY ++ ++Deletes the specified PROPERTY from the specified X-WINDOW. ++::end:: */ ++{ ++ Atom _prop; ++ ++ rep_DECLARE1 (window, ANY_WINDOWP); ++ rep_DECLARE2 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ XDeleteProperty (dpy, window_from_arg (window), _prop); ++ ++ return Qt; ++} ++ ++ + /* Drawing functions */ + + DEFUN ("x-clear-window", Fx_clear_window, +@@ -1425,6 +2341,7 @@ + x_window_mark (repv obj) + { + rep_MARKVAL (VX_DRAWABLE (obj)->event_handler); ++ rep_MARKVAL (VX_DRAWABLE (obj)->plist); + } + + static void +@@ -1470,6 +2387,7 @@ + rep_ADD_SUBR (Sx_create_root_xor_gc); + rep_ADD_SUBR (Sx_change_gc); + rep_ADD_SUBR (Sx_destroy_gc); ++ rep_ADD_SUBR (Sx_free_gc); + rep_ADD_SUBR (Sx_gc_p); + + x_drawable_context = XUniqueContext (); +@@ -1479,12 +2397,26 @@ + x_window_sweep, x_window_mark, + 0, 0, 0, 0, 0, 0, 0); + rep_ADD_SUBR (Sx_create_window); ++ rep_ADD_SUBR (Sx_reparent_window); + rep_ADD_SUBR (Sx_create_pixmap); + rep_ADD_SUBR (Sx_create_bitmap); ++ rep_ADD_SUBR (Sx_map_request); ++ rep_ADD_SUBR (Sx_map_notify); + rep_ADD_SUBR (Sx_map_window); ++ rep_ADD_SUBR (Sx_x_map_window); ++ rep_ADD_SUBR (Sx_map_raised); ++ rep_ADD_SUBR (Sx_map_subwindows); + rep_ADD_SUBR (Sx_unmap_window); ++ rep_ADD_SUBR (Sx_unmap_subwindows); ++ rep_ADD_SUBR (Sx_configure_request); + rep_ADD_SUBR (Sx_configure_window); + rep_ADD_SUBR (Sx_change_window_attributes); ++ rep_ADD_SUBR (Sx_x_raise_window); ++ rep_ADD_SUBR (Sx_x_lower_window); ++ rep_ADD_SUBR (Sx_circulate_subwindows); ++ rep_ADD_SUBR (Sx_circulate_subwindows_up); ++ rep_ADD_SUBR (Sx_circulate_subwindows_down); ++ rep_ADD_SUBR (Sx_restack_windows); + rep_ADD_SUBR (Sx_destroy_drawable); + rep_ADD_SUBR (Sx_destroy_window); + rep_ADD_SUBR (Sx_drawable_p); +@@ -1498,6 +2430,16 @@ + rep_ADD_SUBR (Sx_window_back_buffer); + rep_ADD_SUBR (Sx_window_swap_buffers); + ++ rep_ADD_SUBR (Sx_window_put); ++ rep_ADD_SUBR (Sx_window_get); ++ ++ rep_ADD_SUBR (Sx_set_text_property); ++ rep_ADD_SUBR (Sx_get_text_property); ++ rep_ADD_SUBR (Sx_list_properties); ++ rep_ADD_SUBR (Sx_change_property); ++ rep_ADD_SUBR (Sx_rotate_window_properties); ++ rep_ADD_SUBR (Sx_delete_property); ++ + rep_ADD_SUBR (Sx_clear_window); + rep_ADD_SUBR (Sx_draw_string); + rep_ADD_SUBR (Sx_draw_line); +@@ -1534,6 +2476,36 @@ + rep_INTERN (clip_mask); + rep_INTERN (clip_x_origin); + rep_INTERN (clip_y_origin); ++ rep_INTERN (sibling); ++ rep_INTERN (stack_mode); ++ rep_INTERN (override_redirect); ++ rep_INTERN (save_under); ++ rep_INTERN (event_mask); ++ rep_INTERN (parent); ++ ++ rep_INTERN (serial); ++ rep_INTERN (send_event); ++ rep_INTERN (event); ++ rep_INTERN (window); ++ rep_INTERN (subwindow); ++ rep_INTERN (time); ++ rep_INTERN (x_root); ++ rep_INTERN (y_root); ++ rep_INTERN (state); ++ rep_INTERN (keycode); ++ rep_INTERN (same_screen); ++ rep_INTERN (button); ++ rep_INTERN (is_hint); ++ rep_INTERN (focus); ++ rep_INTERN (mode); ++ rep_INTERN (detail); ++ rep_INTERN (count); ++ rep_INTERN (message_type); ++ rep_INTERN (format); ++ rep_INTERN (data); ++ rep_INTERN (above); ++ rep_INTERN (raise_lowest); ++ rep_INTERN (lower_highest); + + rep_INTERN (LineSolid); + rep_INTERN (LineOnOffDash); diff --git a/x11-wm/sawfish-merlin/files/sawfishrc b/x11-wm/sawfish-merlin/files/sawfishrc new file mode 100644 index 000000000000..89580b9fd27c --- /dev/null +++ b/x11-wm/sawfish-merlin/files/sawfishrc @@ -0,0 +1,357 @@ +(setq dl-load-path (cons "/usr/lib/sawfish/1.0.1/sawfish-merlin" dl-load-path)) +(require 'merlin.util) +(require 'merlin.x-util) +(require 'merlin.message) +(require 'merlin.sawlet) +(require 'merlin.uglicon) +(require 'merlin.ugliness) +(require 'merlin.icons) +(require 'merlin.placement) +(require 'merlin.sawlet-placement) +(require 'merlin.clock) +(require 'merlin.fishbowl) +(require 'merlin.iconbox) +(require 'merlin.pager) +(defpager pager) +(defclock clock) +(deffishbowl fishbowl) +(deficonbox iconbox) +(defvar apps-business-menu + `( + ("Gaspell" (system "gaspell &")) + ("Gdict" (system "gdict -a &")) + ("Gnumeric" (system "gnumeric &")) + ("Star Office" (system "/opt/office52/soffice &")) + )) + +(defvar apps-editors-menu + `( + ("Nedit" (system "nedit &")) + ("Vim" (system "gvim &")) + ("XEmacs" (system "xemacs &")) + )) + +(defvar apps-gnome-business-menu + `( + ("Gnome Calendar" (system "gnomecal &")) + ("Gnome Card" (system "gnomecard &")) + ("Gnome Timetracker" (system "gtt &")) + ("Gnumeric" (system "gnumeric-bonobo &")) + )) + +(defvar apps-gnome-development-menu + `( + ("Gide" (system "gide &")) + ("Glade" (system "glade &")) + )) + +(defvar apps-gnome-games-menu + `( + ("Freecell" (system "freecell &")) + ("Gataxx" (system "gataxx &")) + ("Glines" (system "glines &")) + ("Gnibbles" (system "gnibbles &")) + ("Gnobots2" (system "gnobots2 &")) + ("Gnome Chess" (system "gnome-chess &")) + ("Gnome Stones" (system "gnome-stones &")) + ("Gnometris" (system "gnometris &")) + ("Gnome Xbill" (system "gnome-xbill &")) + ("Gnomine" (system "gnomine &")) + ("Gturing" (system "gturing &")) + ("Iagno" (system "iagno &")) + ("Mahjongg" (system "mahjongg &")) + ("Same Gnome" (system "same-gnome &")) + )) + +(defvar apps-gnome-graphics-menu + `( + ("Electric Eyes" (system "ee &")) + ("Eye Of Gnome" (system "eog &")) + ("Gnome Ghostview" (system "ggv &")) + )) + +(defvar apps-gnome-multimedia-menu + `( + ("Gmix" (system "gmix &")) + ("Grecord" (system "grecord &")) + ("Gtcd" (system "gtcd &")) + ("Vumeter" (system "vumeter &")) + )) + +(defvar apps-gnome-networking-menu + `( + ("Balsa" (system "balsa &")) + ("Evolution" (system "evolution &")) + ("Gmailman" (system "gmailman &")) + ("Gnome Ppp" (system "gnome-ppp &")) + ("Gtalk" (system "gtalk &")) + ("XChat" (system "xchat &")) + )) + +(defvar apps-gnome-system-menu + `( + ("Active Users Listing" (system "gw &")) + ("Gnome Control Center" (system "gnomecc &")) + ("Gnome Object Activation Directory Browser" (system "goad-browser &")) + ("Gnome Save Session" (system "save-session &")) + ("Gnome System Information" (system "guname &")) + ("Gnorpm" (system "gnorpm &")) + ("Logview" (system "logview &")) + ("Panel" (system "panel &")) + )) + +(defvar apps-gnome-utilities-menu + `( + ("Bug Buddy" (system "bug-buddy &")) + ("Gdict" (system "gdict -a &")) + ("Gdiskfree" (system "gdiskfree &")) + ("Gless" (system "gless &")) + ("Gmenu" (system "gmenu &")) + ("Gnome About" (system "gnome-about &")) + ("Gnome Calculator" (system "gcalc &")) + ("Gnome Character Map" (system "gcharmap &")) + ("Gnome Color Selector" (system "gcolorsel &")) + ("Gnome Font Browser" (system "gfontsel &")) + ("Gnome Help Browser" (system "gnome-help-browser &")) + ("Gnome Terminal" (system "gnome-terminal &")) + ("Gsearchtool" (system "gsearchtool &")) + ("Gtop" (system "gtop &")) + )) + +(defvar apps-gnome-menu + `( + ("Business" . apps-gnome-business-menu) + ("Development" . apps-gnome-development-menu) + ("Games" . apps-gnome-games-menu) + ("Graphics" . apps-gnome-graphics-menu) + ("Multimedia" . apps-gnome-multimedia-menu) + ("Networking" . apps-gnome-networking-menu) + ("System" . apps-gnome-system-menu) + ("Utilities" . apps-gnome-utilities-menu) + )) + +(defvar apps-graphics-menu + `( + ("Acrobat Reader 4" (system "/opt/Acrobat4/acroread &")) + ("Corel Photopaint 9" (system "photopaint &")) + ("Dia" (system "dia &")) + ("Gimp" (system "gimp &")) + ("GQview" (system "gqview &")) + )) + +(defvar apps-kde-applications-menu + `( + ("KOrganizer" (system "korganizer &")) + )) + +(defvar apps-kde-development-menu + `( + ("Cervisia" (system "cervisia &")) + ("KBabel" (system "kbabel &")) + ("KBabeldict" (system "kbabeldict &")) + ("KDbg" (system "kdbg &")) + ("KDevelop" (system "kdevelop &")) + ("KDevelop-setup" (system "kdevelop-setup &")) + ("KProf" (system "kprof &")) + )) + +(defvar apps-kde-editors-menu + `( + ("KEdit" (system "kedit &")) + ("KWrite" (system "kwrite &")) + )) + +(defvar apps-kde-games-menu + `( + ("KAbalone" (system "kabalone &")) + ("KAsteroids" (system "kasteroids &")) + ("KAtomic" (system "katomic &")) + ("KBackgammon" (system "kbackgammon &")) + ("KBattleship" (system "kbattleship &")) + ("KBlackbox" (system "kblackbox &")) + ("KJezz" (system "kjezz &")) + ("KJumpingcube" (system "kjumpingcube &")) + ("KLines" (system "klines &")) + ("KMahjongg" (system "kmahjongg &")) + ("KMines" (system "kmines &")) + ("Konquest" (system "konquest &")) + ("KPat" (system "kpat &")) + ("KPoker" (system "kpoker &")) + ("KReversi" (system "kreversi &")) + ("KSame" (system "ksame &")) + ("KShisen" (system "kshisen &")) + ("KSirtet" (system "ksirtet &")) + ("KFouleggs" (system "kfouleggs &")) + ("KSmiletris" (system "ksmiletris &")) + ("KSnake" (system "ksnake &")) + ("KSokoban" (system "ksokoban &")) + ("KSpaceduel" (system "kspaceduel &")) + ("KTron" (system "ktron &")) + ("KTuberling" (system "ktuberling &")) + ("KWin4" (system "kwin4 &")) + ("KProc4" (system "kproc4 &")) + ("Lskat" (system "lskat &")) + )) + +(defvar apps-kde-graphics-menu + `( + ("KDvi" (system "kdvi &")) + ("KFax" (system "kfax &")) + ("KFract" (system "kfract &")) + ("KGhostview" (system "kghostview &")) + ("KIconedit" (system "kiconedit &")) + ("KPaint" (system "kpaint &")) + ("KPixmap2bitmap" (system "kpixmap2bitmap &")) + ("KRuler" (system "kruler &")) + ("KSnapshot" (system "ksnapshot &")) + ("KView" (system "kview &")) + ("Pixie" (system "pixie &")) + )) + +(defvar apps-kde-internet-menu + `( + ("KBear" (system "kbear &")) + ("KEditbookmarks" (system "keditbookmarks &")) + ("Keystone" (system "keystone &")) + ("Kit" (system "kit &")) + ("KMail" (system "kmail &")) + ("KNode" (system "knode &")) + ("Konqueror" (system "kfmclient openProfile webbrowsing &")) + ("Korn" (system "korn &")) + ("KPpp" (system "kppp &")) + ("KPpplogview" (system "kppplogview &")) + ("KSirc" (system "ksirc &")) + )) + +(defvar apps-kde-multimedia-menu + `( + ("Aktion" (system "aktion &")) + ("Artsbuilder" (system "artsbuilder &")) + ("Artscontrol" (system "artscontrol &")) + ("KMid" (system "kmid &")) + ("KMidi" (system "kmidi &")) + ("KMix" (system "kmix &")) + ("KScd" (system "kscd &")) + ("Noatun" (system "noatun &")) + ("Timidity" (system "timidity &")) + )) + +(defvar apps-kde-office-menu + `( + ("Office Shell" (system "koshell &")) + ("KChart" (system "kchart &")) + ("KFormula" (system "kformula &")) + ("KIllustrator" (system "killustrator &")) + ("Kivio" (system "kivio &")) + ("KPresenter" (system "kpresenter &")) + ("Krayon" (system "krayon &")) + ("KSpread" (system "kspread &")) + ("Kugar" (system "kugar &")) + ("KWord" (system "kword &")) + )) + +(defvar apps-kde-system-menu + `( + ("Control Center" (system "kcontrol &")) + ("Appfinder" (system "kappfinder &")) + ("KCron" (system "kcron &")) + ("Kdf" (system "kdf &")) + ("Konqueror" (system "kfmclient &")) + ("Konqueror Superuser" (system "kdesu konqueror &")) + ("Konsole" (system "konsole &")) + ("Konsole Superuser" (system "kdesu konsole &")) + ("KPackage" (system "kpackage &")) + ("KSysguard" (system "ksysguard &")) + ("KSysv" (system "ksysv &")) + ("KUser" (system "kuser &")) + ("Kwikdisk" (system "kwikdisk &")) + ("KWuftpd" (system "kwuftpd &")) + ("Legacy theme importer" (system "klegacyimport &")) + ("Process management" (system "kpm &")) + )) + +(defvar apps-kde-toys-menu + `( + ("Amor" (system "amor &")) + ("KMoon" (system "kmoon &")) + ("kKdo" (system "kodo &")) + ("KTeatime" (system "kteatime &")) + ("KTux" (system "ktux &")) + ("KWorldclock" (system "kworldclock &")) + )) + +(defvar apps-kde-utilities-menu + `( + ("Ark" (system "ark &")) + ("Kab" (system "kab &")) + ("Karm" (system "karm &")) + ("KCalc" (system "kcalc &")) + ("KCharselect" (system "kcharselect &")) + ("Kdf" (system "kdf &")) + ("Kwikdisk" (system "kwikdisk &")) + ("KEdit" (system "kedit &")) + ("KFind" (system "kfind &")) + ("KFloppy" (system "kfloppy &")) + ("KHexedit" (system "khexedit &")) + ("KJots" (system "kjots &")) + ("KLjettool" (system "kljettool &")) + ("KLpq" (system "klpq &")) + ("KLprfax" (system "klprfax &")) + ("KNotes" (system "knotes &")) + ("Kpm" (system "kpm &")) + ("KTimer" (system "ktimer &")) + )) + +(defvar apps-kde-menu + `( + ("Applications" . apps-kde-applications-menu) + ("Development" . apps-kde-development-menu) + ("Editors" . apps-kde-editors-menu) + ("Games" . apps-kde-games-menu) + ("Graphics" . apps-kde-graphics-menu) + ("Internet" . apps-kde-internet-menu) + ("Multimedia" . apps-kde-multimedia-menu) + ("Office" . apps-kde-office-menu) + ("System" . apps-kde-system-menu) + ("Toys" . apps-kde-toys-menu) + ("Utilities" . apps-kde-utilities-menu) + )) + +(defvar apps-multimedia-menu + `( + ("Grip" (system "grip &")) + ("Realplayer" (system "/opt/RealPlayer8/realplay &")) + ("Videolan Client" (system "vlc &")) + ("Xine" (system "xine &")) + ("XMMS" (system "xmms &")) + )) + +(defvar apps-network-menu + `( + ("Evolution" (system "evolution &")) + ("Fidelio" (system "fidelio &")) + ("Gabber" (system "gabber &")) + ("Galeon" (system "galeon &")) + ("Gnome transfer manager" (system "gtm &")) + ("Gnutella" (system "gtk-gnutella &")) + ("Konqueror" (system "kfmclient openProfile webbrowsing &")) + ("Licq" (system "licq &")) + ("Mozilla" (system "mozilla&")) + ("Netscape Mail" (system "netscape -mail -no-about-splash &")) + ("Netscape" (system "netscape -no-about-splash &")) + ("Opera" (system "opera &")) + ("Psi" (system "psi &")) + ("Webdownloader" (system "nt &")) + ("XChat" (system "xchat &")) + )) + +(setq apps-menu + `( + ("Business" . apps-business-menu) + ("Editors" . apps-editors-menu) + ("Gnome" . apps-gnome-menu) + ("Graphics" . apps-graphics-menu) + ("Kde" . apps-kde-menu) + ("Multimedia" . apps-multimedia-menu) + ("Network" . apps-network-menu) + )) diff --git a/x11-wm/sawfish-merlin/files/x.c.patch-merlin-1.0.2 b/x11-wm/sawfish-merlin/files/x.c.patch-merlin-1.0.2 new file mode 100644 index 000000000000..f77cfa8bbfa0 --- /dev/null +++ b/x11-wm/sawfish-merlin/files/x.c.patch-merlin-1.0.2 @@ -0,0 +1,1364 @@ +# +# version -0.8.4 +# +# Copyright (C) 2000-2001 merlin <merlin@merlin.org> +# +# Built from sawfish 1.00. +# +# ********************* +# ** HERE BE DRAGONS ** +# ********************* +# +# This code contains horrendous hacks. It introduces the high +# probability of crashing your Window Manager and Rendering it +# Unstable and Destroying your Valuable Work and Property. +# +# Tnis is unlikely to work with earlier or later versions of +# Sawfish. +# +# Sawfish was not written with code of this nature on mind. +# +# More to the point, Sawfish was written with the express +# intention of this NOT EVER being done. As a result, this +# Software introduces the EXTREME PROBABILITY of FAILURE that +# DOES NOT EXIST in Sawfish itself. +# +# ****************** +# ** INSTALLATION ** +# ****************** +# +# I assume that you have a recent copy of the Sawfish +# source unpacked somewhere. +# +# Change into the `src' directory. +# cd sawfish-x.yz/src/ +# +# Run patch against this file to patch x.c: +# patch -p1 < /path/to/x.c.patch +# +# Compile and install Sawfish. +# make +# make install +# +# Restart Sawfish. +# +# Alternatively, you might want to install sawfish using +# some package manager, such as apt or RPM. Then you can +# build and locally install just the patched library using +# the following technique: +# make +# mkdir -p ~/.sawfish/lib/sawfish/wm/util +# cp src/.libs/x.* ~/.sawfish/lib +# cp src/.libs/x.* ~/.sawfish/lib/sawfish/wm/util +# +# You'll also need to add the following line to the *start* +# of your ~/.sawfishrc: +# (setq dl-load-path (cons "~/.sawfish/lib" dl-load-path)) +# +# Restart Sawfish. +# +# ****************** +# ** HERE BE BUGS ** +# ****************** +# +# Many XLib features are unimplemented and misimplemented. +# +# My understanding of rep modules is incomplete and erroneous. +# +# In order to support managed windows I introduced many hacks with +# UNKNOWN CONSEQUENCES. +# +# This code allows you to emulate being a distinct X application when you +# are in fact just a tiny part of a Window Manager that knows NOTHING +# about you. As a result, expect Window Management not to work as it +# should, and expect Your Application not to work as it should. You won't +# get events that you expect, you will get events that you don't and the +# Window Manager will simply not operate 100% as it should. +# +# In particular, if you create a managed window then it will probably be +# useless to you; you'll want to cover it with a child. +# +# One day I'll chop this off so it is a separate rep module that allows +# you to write standalone XLib applications that are not bastard, +# deformed monstrosities sprouting from the side of something beautiful. +# +# - merlin + +Index: src/x.c +=================================================================== +RCS file: /cvs/gnome/sawfish/src/x.c,v +retrieving revision 1.22 +diff -u -r1.22 x.c +--- src/x.c 2001/04/11 21:01:03 1.22 ++++ src/x.c 2001/09/09 11:57:09 +@@ -6,6 +6,9 @@ + Originally written by merlin <merlin@merlin.org>, with additions + from John Harper + ++ Then patched again by merlin to add some wicked functions: ++ x.c#pl:merlin/-0.8.4 ++ + This file is part of sawmill. + + sawmill is free software; you can redistribute it and/or modify it +@@ -72,6 +75,7 @@ + int is_pixmap : 1; + int is_bitmap : 1; /* depth == 1 */ + int width, height; ++ repv plist; + } Lisp_X_Window; + + #define X_XDRAWABLEP(v) rep_CELL16_TYPEP(v, x_window_type) +@@ -82,6 +86,8 @@ + #define X_PIXMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_pixmap) + #define X_BITMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_bitmap) + ++#define ANY_WINDOWP(w) (rep_INTEGERP(w) || X_WINDOWP(w) || (WINDOWP(w) && VWIN(w)->id != 0)) ++ + static Lisp_X_GC *x_gc_list = NULL; + int x_gc_type; + +@@ -115,6 +121,36 @@ + DEFSYM (clip_mask, "clip-mask"); + DEFSYM (clip_x_origin, "clip-x-origin"); + DEFSYM (clip_y_origin, "clip-y-origin"); ++DEFSYM (sibling, "sibling"); ++DEFSYM (stack_mode, "stack-mode"); ++DEFSYM (override_redirect, "override-redirect"); ++DEFSYM (save_under, "save-under"); ++DEFSYM (event_mask, "event-mask"); ++DEFSYM (parent, "parent"); ++DEFSYM (raise_lowest, "raise-lowest"); ++DEFSYM (lower_highest, "lower-highest"); ++ ++DEFSYM (serial, "serial"); ++DEFSYM (send_event, "send-event"); ++DEFSYM (window, "window"); ++DEFSYM (event, "event"); ++DEFSYM (subwindow, "subwindow"); ++DEFSYM (time, "time"); ++DEFSYM (x_root, "x-root"); ++DEFSYM (y_root, "y-root"); ++DEFSYM (state, "state"); ++DEFSYM (keycode, "keycode"); ++DEFSYM (same_screen, "same-screen"); ++DEFSYM (button, "button"); ++DEFSYM (is_hint, "is-hint"); ++DEFSYM (focus, "focus"); ++DEFSYM (mode, "mode"); ++DEFSYM (detail, "detail"); ++DEFSYM (count, "count"); ++DEFSYM (message_type, "message-type"); ++DEFSYM (format, "format"); ++DEFSYM (data, "data"); ++DEFSYM (above, "above"); + + DEFSYM (LineSolid, "line-solid"); + DEFSYM (LineOnOffDash, "line-on-off-dash"); +@@ -216,7 +252,60 @@ + return GXcopy; + } + ++static Atom ++x_symbol_atom (repv symbol) { ++ return XInternAtom (dpy, rep_STR (rep_SYM (symbol)->name), False); ++} ++ + ++/* Symbol matching Functions */ ++ ++typedef struct { ++ unsigned int value; ++ char *str; ++} x_value_str; ++ ++static repv ++x_value_match (unsigned int value, x_value_str *match) { ++ while (match->str) { ++ if (value == match->value) ++ return Fintern (rep_string_dup (match->str), Qnil); ++ ++ match; ++ } ++ return Qnil; ++} ++ ++static repv ++x_valuemask_match (unsigned int value, x_value_str *match) { ++ repv result = Qnil; ++ while (match->str) { ++ if (value & match->value) ++ result = Fcons (Fintern (rep_string_dup (match->str), Qnil), result); ++ ++ match; ++ } ++ return result; ++} ++ ++typedef struct { ++ char *str; ++ unsigned int value; ++} x_str_value; ++ ++static int ++x_symbol_match (repv symbol, x_str_value *match) { ++ char *tmp; ++ if (!rep_SYMBOLP (symbol)) ++ return -1; ++ tmp = rep_STR (rep_SYM (symbol)->name); ++ while (match->str) { ++ if (!strcmp (match->str, tmp)) ++ return match->value; ++ ++ match; ++ } ++ return -1; ++} ++ ++ + /* GC Functions */ + + static long +@@ -470,6 +559,16 @@ + return Qt; + } + ++DEFUN ("x-free-gc", Fx_free_gc, Sx_free_gc, (repv gc), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-free-gc:: ++x-free-gc X-GC ++ ++Free the X-GC. Same as x-destroy-gc. ++::end:: */ ++{ ++ return Fx_destroy_gc (gc); ++} ++ + DEFUN ("x-gc-p", Fx_gc_p, Sx_gc_p, (repv gc), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-gc-p:: + x-gcp ARG +@@ -483,6 +582,15 @@ + + /* Window functions */ + ++static x_str_value x_stack_mode_matches[] = { ++ { "above", Above }, ++ { "below", Below }, ++ { "top-if", TopIf }, ++ { "bottom-if", BottomIf }, ++ { "opposite", Opposite }, ++ { 0, 0 } ++}; ++ + static long + x_window_parse_changes (XWindowChanges *changes, repv attrs) + { +@@ -520,6 +628,24 @@ + changes->border_width = rep_INT (rep_CDR (tem)); + changesMask |= CWBorderWidth; + } ++ else if (car == Qsibling) ++ { ++ Window sibling = window_from_arg (rep_CDR (tem)); ++ if (sibling) ++ { ++ changes->sibling = sibling; ++ changesMask |= CWSibling; ++ } ++ } ++ else if (car == Qstack_mode) ++ { ++ int stack_mode = x_symbol_match (rep_CDR (tem), x_stack_mode_matches); ++ if (stack_mode != -1) ++ { ++ changes->stack_mode = stack_mode; ++ changesMask |= CWStackMode; ++ } ++ } + } + + attrs = rep_CDR (attrs); +@@ -537,6 +663,35 @@ + w->height = changes->height; + } + ++static x_str_value x_event_mask_matches[] = { ++ { "key-press", KeyPressMask }, ++ { "key-release", KeyReleaseMask }, ++ { "button-press", ButtonPressMask }, ++ { "button-release", ButtonReleaseMask }, ++ { "enter-window", EnterWindowMask }, ++ { "leave-window", LeaveWindowMask }, ++ { "pointer-motion", PointerMotionMask }, ++ { "pointer-motion-hint", PointerMotionHintMask }, ++ { "button-1-motion", Button1MotionMask }, ++ { "button-2-motion", Button2MotionMask }, ++ { "button-3-motion", Button3MotionMask }, ++ { "button-4-motion", Button4MotionMask }, ++ { "button-5-motion", Button5MotionMask }, ++ { "button-motion", ButtonMotionMask }, ++ { "keymap-state", KeymapStateMask }, ++ { "exposure", ExposureMask }, ++ { "visibility-change", VisibilityChangeMask }, ++ { "structure-notify", StructureNotifyMask }, ++ { "resize-redirect", ResizeRedirectMask }, ++ { "substructure-notify", SubstructureNotifyMask }, ++ { "substructure-redirect", SubstructureRedirectMask }, ++ { "focus-change", FocusChangeMask }, ++ { "property-change", PropertyChangeMask }, ++ { "colormap-change", ColormapChangeMask }, ++ { "owner-grab-button", OwnerGrabButtonMask }, ++ { 0, 0 } ++}; ++ + static long + x_window_parse_attributes (XSetWindowAttributes *attributes, repv attrs) + { +@@ -559,6 +714,28 @@ + attributes->border_pixel = VCOLOR (rep_CDR (tem))->pixel; + attributesMask |= CWBorderPixel; + } ++ else if (car == Qoverride_redirect) ++ { ++ attributes->override_redirect = rep_NILP(rep_CDR(tem)) ? False : True; ++ attributesMask |= CWOverrideRedirect; ++ } ++ else if (car == Qsave_under) ++ { ++ attributes->save_under = rep_NILP(rep_CDR(tem)) ? False : True; ++ attributesMask |= CWSaveUnder; ++ } ++ else if ((car == Qevent_mask) && rep_LISTP(rep_CDR(tem))) ++ { ++ repv evl = rep_CDR (tem); ++ attributes->event_mask = 0; ++ while (rep_CONSP (evl)) { ++ int mask = x_symbol_match (rep_CAR (evl), x_event_mask_matches); ++ if (mask != -1) ++ attributes->event_mask |= mask; ++ evl = rep_CDR (evl); ++ } ++ attributesMask |= CWEventMask; ++ } + } + + attrs = rep_CDR (attrs); +@@ -567,32 +744,265 @@ + return attributesMask; + } + ++/* inefficient */ ++static x_value_str x_event_type_matches[] = { ++ { KeyPress, "key-press" }, ++ { KeyRelease, "key-release" }, ++ { ButtonPress, "button-press" }, ++ { ButtonRelease, "button-release" }, ++ { MotionNotify, "motion-notify" }, ++ { EnterNotify, "enter-notify" }, ++ { LeaveNotify, "leave-notify" }, ++ { FocusIn, "focus-in" }, ++ { FocusOut, "focus-out" }, ++ { KeymapNotify, "keymap-notify" }, ++ { Expose, "expose" }, ++ { GraphicsExpose, "graphics-expose" }, ++ { NoExpose, "no-expose" }, ++ { VisibilityNotify, "visibility-notify" }, ++ { CreateNotify, "create-notify" }, ++ { DestroyNotify, "destroy-notify" }, ++ { UnmapNotify, "unmap-notify" }, ++ { MapNotify, "map-notify" }, ++ { MapRequest, "map-request" }, ++ { ReparentNotify, "reparent-notify" }, ++ { ConfigureNotify, "configure-notify" }, ++ { ConfigureRequest, "configure-request" }, ++ { GravityNotify, "gravity-notify" }, ++ { ResizeRequest, "resize-request" }, ++ { CirculateNotify, "circulate-notify" }, ++ { CirculateRequest, "circulate-request" }, ++ { PropertyNotify, "property-notify" }, ++ { SelectionClear, "selection-clear" }, ++ { SelectionRequest, "selection-request" }, ++ { SelectionNotify, "selection-notify" }, ++ { ColormapNotify, "colormap-notify" }, ++ { ClientMessage, "client-message" }, ++ { MappingNotify, "mapping-notify" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_crossing_mode_matches[] = { ++ { NotifyNormal, "notify-normal" }, ++ { NotifyGrab, "notify-grab" }, ++ { NotifyUngrab, "notify-ungrab" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_crossing_detail_matches[] = { ++ { NotifyAncestor, "notify-ancestor" }, ++ { NotifyVirtual, "notify-virtual" }, ++ { NotifyInferior, "notify-inferior" }, ++ { NotifyNonlinear, "notify-nonlinear" }, ++ { NotifyNonlinearVirtual, "notify-nonlinear-virtual" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_motion_is_hint_matches[] = { ++ { NotifyNormal, "notify-normal" }, ++ { NotifyHint, "notify-hint" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_button_matches[] = { ++ { Button1, "button-1" }, ++ { Button2, "button-2" }, ++ { Button3, "button-3" }, ++ { Button4, "button-4" }, ++ { Button5, "button-5" }, ++ { 0, 0 } ++}; ++ ++static x_value_str x_state_matches[] = { ++ { Button1Mask, "button-1" }, ++ { Button2Mask, "button-2" }, ++ { Button3Mask, "button-3" }, ++ { Button4Mask, "button-4" }, ++ { Button5Mask, "button-5" }, ++ { ShiftMask, "shift" }, ++ { LockMask, "lock" }, ++ { ControlMask, "control" }, ++ { Mod1Mask, "mod-1" }, ++ { Mod2Mask, "mod-2" }, ++ { Mod3Mask, "mod-3" }, ++ { Mod4Mask, "mod-4" }, ++ { Mod5Mask, "mod-5" }, ++ { 0, 0 } ++}; ++ ++static repv ++x_encode_keysym (unsigned int keycode, unsigned int state) { ++ KeySym sym = NoSymbol; ++ char *name; ++ if (state & ShiftMask) ++ sym = XKeycodeToKeysym (dpy, keycode, 1); ++ if (sym == NoSymbol) ++ sym = XKeycodeToKeysym (dpy, keycode, 0); ++ /* I don't reset the shift modifier!!! */ ++ name = XKeysymToString (sym); ++ return name ? Fintern (rep_string_dup (name), Qnil) : Qnil; ++} ++ ++#define ALIST_PRE(A,B,C) A = Fcons (Fcons (B, C), A) ++ ++static repv x_window_or_int_from_id (Window window) { ++ repv tmp = x_window_from_id (window); ++ if (tmp == Qnil) ++ tmp = rep_MAKE_INT (window); ++ return tmp; ++} ++ ++static repv ++x_encode_event (XEvent *ev) ++{ ++ repv event = Qnil, data = Qnil; ++ ++ ALIST_PRE (event, Qserial, rep_make_long_uint (ev->xany.serial)); ++ ALIST_PRE (event, Qsend_event, ev->xany.send_event ? Qt : Qnil); ++ ALIST_PRE (event, Qwindow, x_window_from_id (ev->xany.window)); ++ ++ switch (ev->type) { ++ case KeyPress: ++ case KeyRelease: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xkey.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xkey.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xkey.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xkey.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xkey.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xkey.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xkey.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xkey.state, x_state_matches)); ++ ALIST_PRE (event, Qkeycode, x_encode_keysym (ev->xkey.keycode, ev->xkey.state)); ++ ALIST_PRE (event, Qsame_screen, ev->xkey.same_screen ? Qt : Qnil); ++ break; ++ ++ case ButtonPress: ++ case ButtonRelease: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xbutton.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xbutton.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xbutton.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xbutton.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xbutton.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xbutton.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xbutton.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xbutton.state, x_state_matches)); ++ ALIST_PRE (event, Qbutton, x_value_match (ev->xbutton.button, x_button_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xbutton.same_screen ? Qt : Qnil); ++ break; ++ ++ case MotionNotify: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xmotion.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xmotion.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xmotion.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xmotion.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xmotion.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xmotion.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xmotion.y_root)); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xmotion.state, x_state_matches)); ++ ALIST_PRE (event, Qis_hint, x_value_match (ev->xmotion.is_hint, x_motion_is_hint_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xmotion.same_screen ? Qt : Qnil); ++ break; ++ ++ case EnterNotify: ++ case LeaveNotify: ++ ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xcrossing.root)); ++ ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xcrossing.subwindow)); ++ ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xcrossing.time)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xcrossing.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xcrossing.y)); ++ ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xcrossing.x_root)); ++ ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xcrossing.y_root)); ++ ALIST_PRE (event, Qmode, x_value_match (ev->xcrossing.mode, x_crossing_mode_matches)); ++ ALIST_PRE (event, Qdetail, x_value_match (ev->xcrossing.detail, x_crossing_detail_matches)); ++ ALIST_PRE (event, Qsame_screen, ev->xcrossing.same_screen ? Qt : Qnil); ++ ALIST_PRE (event, Qfocus, ev->xcrossing.focus ? Qt : Qnil); ++ ALIST_PRE (event, Qstate, x_valuemask_match (ev->xcrossing.state, x_state_matches)); ++ break; ++ ++ case Expose: ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xexpose.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xexpose.y)); ++ ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xexpose.width)); ++ ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xexpose.height)); ++ ALIST_PRE (event, Qcount, rep_MAKE_INT (ev->xexpose.count)); ++ break; ++ ++ case DestroyNotify: ++ ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xdestroywindow.event)); ++ ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xdestroywindow.window)); ++ break; ++ ++ case ConfigureNotify: ++ ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xconfigure.event)); ++ ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xconfigure.window)); ++ ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xconfigure.x)); ++ ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xconfigure.y)); ++ ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xconfigure.width)); ++ ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xconfigure.height)); ++ ALIST_PRE (event, Qborder_width, rep_MAKE_INT (ev->xconfigure.border_width)); ++ ALIST_PRE (event, Qabove, x_window_or_int_from_id (ev->xconfigure.above)); ++ ALIST_PRE (event, Qoverride_redirect, ev->xconfigure.override_redirect ? Qt : Qnil); ++ break; ++ ++ case ClientMessage: ++ ALIST_PRE (event, Qmessage_type, x_atom_symbol (ev->xclient.message_type)); ++ ALIST_PRE (event, Qformat, rep_MAKE_INT (ev->xclient.format)); ++ data = Qnil; ++ switch (ev->xclient.format) { ++ int i; ++ ++ case 8: /* not a string because length unknown */ ++ data = Fmake_vector (rep_MAKE_INT (20), Qnil); ++ for (i = 0; i < 20; ++ i) ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.b[i]); ++ break; ++ ++ case 16: ++ data = Fmake_vector (rep_MAKE_INT (10), Qnil); ++ for (i = 0; i < 10; ++ i) ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.s[i]); ++ break; ++ ++ case 32: ++ data = Fmake_vector (rep_MAKE_INT (5), Qnil); ++ for (i = 0; i < 5; ++ i) /* decoding atoms makes little sense */ ++ rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.l[i]); ++ break; ++ } ++ ALIST_PRE (event, Qdata, data); ++ break; ++ } ++ ++ /* ++ not done... ++ FocusIn FocusOut KeymapNotify GraphicsExpose NoExpose VisibilityNotify ++ CreateNotify UnmapNotify MapNotify MapRequest ReparentNotify ++ ConfigureRequest GravityNotify ResizeRequest CirculateNotify ++ CirculateRequest PropertyNotify SelectionClear SelectionRequest ++ SelectionNotify ColormapNotify MappingNotify ++ */ ++ ++ return event; ++} ++ + static void + x_window_event_handler (XEvent *ev) + { + repv win = x_window_from_id (ev->xany.window); + if (win != Qnil && VX_DRAWABLE (win)->event_handler != Qnil) + { +- repv type = Qnil, args = Qnil; +- switch (ev->type) +- { +- case Expose: +- /* Since we don't provide a method of detecting which +- part of the window to redraw, ignore all but the last +- expose event. (Another option is to set the clip +- rectangle?) */ +- if (ev->xexpose.count == 0) +- type = Qexpose; +- break; +- +- /* XXX other event types..? */ +- } +- if (type != Qnil) +- { +- args = Fcons (type, Fcons (win, args)); +- rep_funcall (VX_DRAWABLE (win)->event_handler, args, rep_FALSE); +- } ++ repv type = x_value_match (ev->type, x_event_type_matches); ++ repv event = x_encode_event (ev); ++ repv args = Fcons (type, Fcons (win, Fcons (event, Qnil))); ++ /* Note that in Sawfish 0.34+, expose events whose count is non ++ * zero are silently suppressed. I don't do that because I ++ * supply the count. Which means that other people's expose ++ * handlers will be called multiply... */ ++ rep_funcall (VX_DRAWABLE(win)->event_handler, args, rep_FALSE); + } ++ ++ if (ev->type < LASTEvent && event_handlers[ev->type] != 0) ++ event_handlers[ev->type] (ev); + } + + static Lisp_X_Window * +@@ -608,10 +1018,37 @@ + w->height = height; + w->is_window = w->is_pixmap = w->is_bitmap = 0; + w->event_handler = Qnil; ++ w->plist = Qnil; + XSaveContext (dpy, id, x_drawable_context, (XPointer) w); + return w; + } + ++DEFUN ("x-reparent-window", Fx_reparent_window, Sx_reparent_window, ++ (repv win, repv parent, repv xy), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-create-window:: ++x-create-window WINDOW PARENT (X . Y) ++ ++Reparents a windows. ++::end:: */ ++{ ++ Window _win, _parent; ++ int _x, _y; ++ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ rep_DECLARE (2, parent, (parent == Qnil) || ANY_WINDOWP (parent)); ++ rep_DECLARE (3, xy, rep_CONSP (xy) ++ && rep_INTP (rep_CAR (xy)) && rep_INTP (rep_CDR (xy))); ++ ++ _win = window_from_arg (win); ++ _parent = (parent == Qnil) ? root_window : window_from_arg (parent); ++ _x = rep_INT (rep_CAR (xy)); ++ _y = rep_INT (rep_CDR (xy)); ++ ++ XReparentWindow (dpy, _win, _parent, _x, _y); ++ ++ return Qt; ++} ++ + DEFUN ("x-create-window", Fx_create_window, Sx_create_window, + (repv xy, repv wh, repv bw, repv attrs, repv ev), rep_Subr5) /* + ::doc:sawfish.wm.util.x#x-create-window:: +@@ -619,12 +1056,15 @@ + + Creates a new X-WINDOW with the specified position, dimensions and + border width. ATTRS should be a list of cons cells mapping attributes +-to values. Known attributes are `background' and `border-color'. The +-window is created unmapped. ++to values. Known attributes include the symbols `x', `y', ++`width', `height', `border-width', `sibling' and `stack-mode'. Valid ++values for stack-mode are `above', `below', `top-if', `bottom-if' and ++`opposite'. The window is created unmapped. + ::end:: */ + { + Lisp_X_Window *w; +- Window id; ++ repv parent = Qnil; ++ Window id, _parent; + XSetWindowAttributes attributes; + long attributesMask; + int _x, _y, _w, _h, _bw; +@@ -636,6 +1076,11 @@ + rep_DECLARE3 (bw, rep_INTP); + rep_DECLARE4 (attrs, rep_LISTP); + ++ if (rep_CONSP (attrs) && (Fassq (Qparent, attrs) != Qnil)) ++ parent = rep_CDR (Fassq (Qparent, attrs)); ++ if (!(_parent = window_from_arg (parent))) ++ _parent = root_window; ++ + _x = rep_INT (rep_CAR (xy)); + _y = rep_INT (rep_CDR (xy)); + _w = rep_INT (rep_CAR (wh)); +@@ -643,19 +1088,21 @@ + _bw = rep_INT (bw); + + attributesMask = x_window_parse_attributes (&attributes, attrs); +- attributes.override_redirect = True; +- attributes.event_mask = ExposureMask; +- attributes.colormap = image_cmap; ++ if (! (attributesMask & CWOverrideRedirect)) ++ { ++ attributes.override_redirect = True; ++ attributesMask |= CWOverrideRedirect; ++ } + if (! (attributesMask & CWBorderPixel)) + { + attributes.border_pixel = BlackPixel (dpy, + BlackPixel (dpy, screen_num)); + attributesMask |= CWBorderPixel; + } +- +- attributesMask |= CWOverrideRedirect | CWEventMask | CWColormap; ++ attributes.colormap = image_cmap; ++ attributesMask |= CWOverrideRedirect; + +- id = XCreateWindow (dpy, root_window, _x, _y, _w, _h, _bw, ++ id = XCreateWindow (dpy, _parent, _x, _y, _w, _h, _bw, + image_depth, InputOutput, image_visual, + attributesMask, &attributes); + +@@ -708,6 +1155,37 @@ + return rep_VAL (w); + } + ++DEFUN("x-map-notify", Fx_map_notify, Sx_map_notify, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-notify:: ++x-map-notify X-WINDOW ++::end:: */ ++{ ++ XEvent fake = { MapNotify }; /* ouch the pain */ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ ++ fake.xmap.window = window_from_arg (win); ++ fake.xmap.event = fake.xmap.window; ++ ++ event_handlers[MapNotify] (&fake); ++ ++ return Qt; ++} ++ ++DEFUN("x-map-request", Fx_map_request, Sx_map_request, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-request:: ++x-map-request X-WINDOW ++::end:: */ ++{ ++ XEvent fake = { MapRequest }; /* ouch the pain */ ++ rep_DECLARE1(win, ANY_WINDOWP); ++ ++ fake.xmaprequest.window = window_from_arg (win); ++ ++ event_handlers[MapRequest] (&fake); ++ ++ return Qt; ++} ++ + DEFUN ("x-map-window", Fx_map_window, Sx_map_window, + (repv win, repv unraised), rep_Subr2) /* + ::doc:sawfish.wm.util.x#x-map-window:: +@@ -722,6 +1200,38 @@ + return Qt; + } + ++DEFUN ("x-x-map-window", Fx_x_map_window, Sx_x_map_window, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-map-window:: ++x-x-map-window X-WINDOW ++ ++The real XMapWindow. ++::end:: */ ++{ ++ rep_DECLARE1 (win, ANY_WINDOWP); ++ XMapWindow (dpy, window_from_arg (win)); ++ return Qt; ++} ++ ++DEFUN("x-map-raised", Fx_map_raised, Sx_map_raised, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-raised:: ++x-map-raised X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XMapRaised (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ ++DEFUN("x-map-subwindows", Fx_map_subwindows, Sx_map_subwindows, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-map-subwindows:: ++x-map-subwindows X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XMapSubwindows (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ + DEFUN ("x-unmap-window", Fx_unmap_window, + Sx_unmap_window, (repv win), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-unmap-window:: +@@ -733,6 +1243,50 @@ + return Qt; + } + ++DEFUN("x-unmap-subwindows", Fx_unmap_subwindows, Sx_unmap_subwindows, (repv win), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-unmap-subwindows:: ++x-unmap-subwindows X-WINDOW ++::end:: */ ++{ ++ rep_DECLARE1(win, X_WINDOWP); ++ XUnmapSubwindows (dpy, VX_DRAWABLE(win)->id); ++ return Qt; ++} ++ ++DEFUN("x-configure-request", Fx_configure_request, Sx_configure_request, (repv window, repv attrs), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-configure-request:: ++x-configure-request WINDOW ATTRS ++::end:: */ ++{ ++ XWindowChanges changes; ++ long changesMask; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(attrs, rep_LISTP); ++ ++ changesMask = x_window_parse_changes (&changes, attrs); ++ ++ if (changesMask) ++ { ++ XEvent fake = { ConfigureRequest }; ++ ++ fake.xconfigurerequest.display = dpy; ++ fake.xconfigurerequest.window = VX_DRAWABLE(window)->id; ++ fake.xconfigurerequest.x = changes.x; ++ fake.xconfigurerequest.y = changes.y; ++ fake.xconfigurerequest.width = changes.width; ++ fake.xconfigurerequest.height = changes.height; ++ fake.xconfigurerequest.border_width = changes.border_width; ++ fake.xconfigurerequest.above = changes.sibling; ++ fake.xconfigurerequest.detail = changes.stack_mode; ++ fake.xconfigurerequest.value_mask = changesMask; ++ ++ event_handlers[ConfigureRequest] (&fake); ++ } ++ ++ return Qt; ++} ++ + DEFUN ("x-configure-window", Fx_configure_window, + Sx_configure_window, (repv window, repv attrs), rep_Subr2) /* + ::doc:sawfish.wm.util.x#x-configure-window:: +@@ -740,20 +1294,22 @@ + + Reconfigures the X-WINDOW. ATTRS should be an alist mapping attribute + names to values. Known attributes include the symbols `x', `y', +-`width', `height' and `border-width'. ++`width', `height', `border-width', `sibling' and `stack-mode'. Valid ++values for stack-mode are `above', `below', `top-if', `bottom-if' and ++`opposite'. + ::end:: */ + { + XWindowChanges changes; + long changesMask; + +- rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (attrs, rep_LISTP); + + changesMask = x_window_parse_changes (&changes, attrs); + + if (changesMask) + { +- XConfigureWindow (dpy, VX_DRAWABLE (window)->id, ++ XConfigureWindow (dpy, window_from_arg (window), + changesMask, &changes); + x_window_note_changes (VX_DRAWABLE (window), changesMask, &changes); + } +@@ -774,20 +1330,118 @@ + XSetWindowAttributes attributes; + long attributesMask; + +- rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (attrs, rep_LISTP); + + attributesMask = x_window_parse_attributes (&attributes, attrs); + + if (attributesMask) + { +- XChangeWindowAttributes (dpy, VX_DRAWABLE (window)->id, ++ XChangeWindowAttributes (dpy, window_from_arg (window), + attributesMask, &attributes); + } + + return Qt; + } + ++DEFUN("x-x-raise-window", Fx_x_raise_window, Sx_x_raise_window, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-raise-window:: ++x-x-raise-window WINDOW ++ ++The real XRaiseWindow. Raises the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XRaiseWindow (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-x-lower-window", Fx_x_lower_window, Sx_x_lower_window, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-x-lower-window:: ++x-x-lower-window WINDOW ++ ++The real XLowerWindow. Lowers the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XLowerWindow (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows", Fx_circulate_subwindows, Sx_circulate_subwindows, (repv window, repv direction), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows:: ++x-circulate-subwindows WINDOW DIRECTION ++ ++Circulates the subwindows of the X-WINDOW in DIRECTION ++for either `raise-lowest' or `lower-highest'. ++::end:: */ ++{ ++ int _direction; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE(2, direction, (direction == Qraise_lowest) || (direction == Qlower_highest)); ++ _direction = (direction == Qraise_lowest) ? RaiseLowest : LowerHighest; ++ ++ XCirculateSubwindows (dpy, VX_DRAWABLE(window)->id, _direction); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows-up", Fx_circulate_subwindows_up, Sx_circulate_subwindows_up, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows-up:: ++x-circulate-subwindows-up WINDOW ++ ++Circulates up the subwindows of the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XCirculateSubwindowsUp (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-circulate-subwindows-down", Fx_circulate_subwindows_down, Sx_circulate_subwindows_down, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-circulate-subwindows-down:: ++x-circulate-subwindows-down WINDOW ++ ++Circulates down the subwindows of the X-WINDOW. ++::end:: */ ++{ ++ rep_DECLARE1(window, X_WINDOWP); ++ ++ XCirculateSubwindowsDown (dpy, VX_DRAWABLE(window)->id); ++ ++ return Qt; ++} ++ ++DEFUN("x-restack-windows", Fx_restack_windows, Sx_restack_windows, (repv list), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-restack-windows:: ++x-restack-windows LIST ++ ++Restacks the LIST of X-WINDOWs. ++::end:: */ ++{ ++ Window *windows; ++ int n = 0; ++ ++ rep_DECLARE1(list, rep_LISTP); ++ ++ windows = alloca (rep_INT (Flength (list)) * sizeof (Window)); ++ while (rep_CONSP (list)) { ++ if (X_WINDOWP (rep_CAR (list))) ++ windows[n ++] = VX_DRAWABLE (rep_CAR (list))->id; ++ list = rep_CDR (list); ++ } ++ XRestackWindows (dpy, windows, n); ++ ++ return Qt; ++} ++ + DEFUN ("x-destroy-drawable", Fx_destroy_drawable, + Sx_destroy_drawable, (repv drawable), rep_Subr1) /* + ::doc:sawfish.wm.util.x#x-destroy-drawable:: +@@ -959,6 +1613,268 @@ + } + + ++/* Lisp property functions */ ++ ++DEFUN ("x-window-put", Fx_window_put, Sx_window_put, (repv window, repv key, repv value), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-window-put:: ++x-window-put WINDOW KEY VALUE ++ ++Stores the specified VALUE in the specified WINDOW under the specified ++(symbolic) KEY. ++::end:: */ ++{ ++ repv plist, ptr; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(key, rep_SYMBOLP); ++ ++ ptr = plist = VX_DRAWABLE(window)->plist; ++ while (ptr != Qnil) { ++ repv cons = rep_CAR (ptr); ++ if (rep_CAR (cons) == key) { ++ rep_CDR (cons) = value; ++ return Qt; ++ } ++ ptr = rep_CDR (ptr); ++ } ++ VX_DRAWABLE(window)->plist = Fcons (Fcons (key, value), plist); ++ ++ return Qt; ++} ++ ++DEFUN ("x-window-get", Fx_window_get, Sx_window_get, (repv window, repv key), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-window-get:: ++x-window-get WINDOW KEY ++ ++Gets the value stored in the specified WINDOW under the specified ++(symbolic) KEY. ++::end:: */ ++{ ++ repv plist, ptr; ++ ++ rep_DECLARE1(window, X_WINDOWP); ++ rep_DECLARE2(key, rep_SYMBOLP); ++ ++ ptr = plist = VX_DRAWABLE(window)->plist; ++ while (ptr != Qnil) { ++ repv cons = rep_CAR (ptr); ++ if (rep_CAR (cons) == key) ++ return rep_CDR (cons); ++ ptr = rep_CDR (ptr); ++ } ++ ++ return Qnil; ++} ++ ++ ++/* X property functions */ ++ ++DEFUN("x-set-text-property", Fx_set_text_property, Sx_set_text_property, (repv window, repv textv, repv property), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-set-text-property:: ++x-set-text-property X-WINDOW TEXTV PROPERTY ++ ++Sets the specified PROPERTY on the specified X-WINDOW to the specified ++value TEXTV, a vector of strings. ++::end:: */ ++{ ++ Atom _prop; ++ int i, n; ++ char **_textv; ++ XTextProperty textprop; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE2 (textv, rep_VECTORP); ++ n = rep_VECT_LEN (textv); ++ for (i = 0; i < n; ++ i) ++ rep_DECLARE (2, textv, rep_STRINGP (rep_VECTI (textv, i))); ++ rep_DECLARE3 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ _textv = alloca (n * sizeof (char *)); ++ for (i = 0; i < n; ++ i) ++ _textv[i] = rep_STR (rep_VECTI (textv, i)); ++ if (!XStringListToTextProperty (_textv, n, &textprop)) ++ return Qnil; ++ ++ XSetTextProperty (dpy, VX_DRAWABLE(window)->id, &textprop, _prop); ++ XFree (textprop.value); ++ ++ return Qt; ++} ++ ++DEFUN("x-get-text-property", Fx_get_text_property, Sx_get_text_property, (repv window, repv property), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-get-text-property:: ++x-get-text-property X-WINDOW PROPERTY ++ ++Gets the specified PROPERTY of the specified X-WINDOW as a vector ++of strings. ++::end:: */ ++{ ++ Atom _prop; ++ XTextProperty textprop; ++ int i, n; ++ char **_textv; ++ repv textv; ++ ++ rep_DECLARE1 (window, ANY_WINDOWP); ++ rep_DECLARE2 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ if (!XGetTextProperty (dpy, window_from_arg (window), &textprop, _prop)) ++ return Qnil; ++ if (!XTextPropertyToStringList (&textprop, &_textv, &n)) { ++ XFree (textprop.value); ++ return Qnil; ++ } ++ XFree (textprop.value); ++ textv = Fmake_vector (rep_MAKE_INT (n), Qnil); ++ for (i = 0; i < n; ++ i) ++ rep_VECTI (textv, i) = rep_string_dup (_textv[i]); ++ XFreeStringList (_textv); ++ ++ return textv; ++} ++ ++DEFUN("x-list-properties", Fx_list_properties, Sx_list_properties, (repv window), rep_Subr1) /* ++::doc:sawfish.wm.util.x#x-list-properties:: ++x-list-properties X-WINDOW ++ ++Returns a list of the properties of the specified X-WINDOW. ++::end:: */ ++{ ++ Atom *atoms; ++ char **_props; ++ repv props = Qnil; ++ int i, n; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ ++ atoms = XListProperties (dpy, VX_DRAWABLE(window)->id, &n); ++ if (!atoms) ++ return Qnil; ++ _props = alloca (n * sizeof (char *)); ++ if (!XGetAtomNames (dpy, atoms, n, _props)) { ++ XFree (atoms); ++ return Qnil; ++ } ++ XFree (atoms); ++ for (i = n - 1; i >= 0; -- i) ++ props = Fcons (Fintern (rep_string_dup (_props[i]), Qnil), props); ++ for (i = 0; i < n; ++ i) ++ XFree (_props[i]); ++ ++ return props; ++} ++ ++static x_str_value x_change_property_mode_matches[] = { ++ { "prop-mode-replace", PropModeReplace }, ++ { "prop-mode-prepend", PropModePrepend }, ++ { "prop-mode-append", PropModeAppend }, ++ { 0, 0 } ++}; ++ ++#define nDECLARE(index,arg, assert) {\ ++ rep_DECLARE (index, args, rep_CONSP (args));\ ++ arg = rep_CAR (args);\ ++ args = rep_CDR (args);\ ++ rep_DECLARE (index, arg, assert);\ ++} ++ ++DEFUN("x-change-property", Fx_change_property, Sx_change_property, (repv args), rep_SubrN) /* ++::doc:sawfish.wm.util.x#x-change-property:: ++x-change-property X-WINDOW PROPERTY TYPE FORMAT MODE DATAV ++ ++Sets the specified PROPERTY in the specified X-WINDOW to the ++specified TYPE vector value DATAV in format FORMAT. MODE can be ++`prop-mode-replace', `prop-mode-prepend' or `prop-mode-append'. ++::end:: */ ++{ ++ repv window, property, type, format, mode, datav; ++ Window _window; ++ Atom _property, _type; ++ int _format, _mode; ++ void *_data; ++ int i, n; ++ ++ nDECLARE (1, window, ANY_WINDOWP (window)); ++ _window = window_from_arg (window); ++ nDECLARE (2, property, rep_SYMBOLP (property)); ++ _property = x_symbol_atom (property); ++ nDECLARE (3, type, rep_SYMBOLP (type)); ++ _type = x_symbol_atom (type); ++ nDECLARE (4, format, rep_INTP (format)); ++ _format = rep_INT (format); ++ rep_DECLARE (4, format, (_format == 8) || (_format == 16) || (_format == 32));; ++ nDECLARE (5, mode, rep_SYMBOLP (mode)); ++ _mode = x_symbol_match (mode, x_change_property_mode_matches); ++ rep_DECLARE (5, mode, (_mode != -1)); ++ nDECLARE (6, datav, rep_VECTORP (datav)); ++ n = rep_VECT_LEN (datav); ++ for (i = 0; i < n; ++ i) ++ rep_DECLARE (6, datav, rep_INTP (rep_VECTI (datav, i))); ++ ++ _data = alloca (n * 4); ++ for (i = 0; i < n; ++ i) { ++ int datum = rep_INT (rep_VECTI (datav, i)); ++ if (format == 8) ++ ((char *) _data)[i] = (char) datum; ++ else if (format == 16) ++ ((short *) _data)[i] = (short) datum; ++ else ++ ((int *) _data)[i] = datum; ++ } ++ XChangeProperty (dpy, _window, _property, _type, _format, _mode, _data, n); ++ ++ return Qt; ++} ++ ++DEFUN("x-rotate-window-properties", Fx_rotate_window_properties, Sx_rotate_window_properties, (repv window, repv list, repv npos), rep_Subr3) /* ++::doc:sawfish.wm.util.x#x-rotate-window-properties:: ++x-rotate-window-properties X-WINDOW PROPERTIES NPOS ++ ++Rotates the values of the specified list of X-WINDOW PROPERTIES by NPOS. ++::end:: */ ++{ ++ Atom *atoms; ++ int n = 0; ++ int _npos; ++ ++ rep_DECLARE1 (window, X_WINDOWP); ++ rep_DECLARE2 (list, rep_LISTP); ++ rep_DECLARE3 (npos, rep_INTP); ++ ++ _npos = rep_INT (npos); ++ ++ atoms = alloca (rep_INT (Flength (list)) * sizeof (Atom)); ++ while (rep_CONSP (list)) { ++ if (rep_SYMBOLP (rep_CAR (list))) ++ atoms[n ++] = x_symbol_atom (rep_CAR (list)); ++ list = rep_CDR (list); ++ } ++ XRotateWindowProperties (dpy, VX_DRAWABLE(window)->id, atoms, n, _npos); ++ ++ return Qt; ++} ++ ++DEFUN("x-delete-property", Fx_delete_property, Sx_delete_property, (repv window, repv property), rep_Subr2) /* ++::doc:sawfish.wm.util.x#x-delete-property:: ++x-delete-property X-WINDOW PROPERTY ++ ++Deletes the specified PROPERTY from the specified X-WINDOW. ++::end:: */ ++{ ++ Atom _prop; ++ ++ rep_DECLARE1 (window, ANY_WINDOWP); ++ rep_DECLARE2 (property, rep_SYMBOLP); ++ ++ _prop = x_symbol_atom (property); ++ XDeleteProperty (dpy, window_from_arg (window), _prop); ++ ++ return Qt; ++} ++ ++ + /* Drawing functions */ + + DEFUN ("x-clear-window", Fx_clear_window, +@@ -1425,6 +2341,7 @@ + x_window_mark (repv obj) + { + rep_MARKVAL (VX_DRAWABLE (obj)->event_handler); ++ rep_MARKVAL (VX_DRAWABLE (obj)->plist); + } + + static void +@@ -1470,6 +2387,7 @@ + rep_ADD_SUBR (Sx_create_root_xor_gc); + rep_ADD_SUBR (Sx_change_gc); + rep_ADD_SUBR (Sx_destroy_gc); ++ rep_ADD_SUBR (Sx_free_gc); + rep_ADD_SUBR (Sx_gc_p); + + x_drawable_context = XUniqueContext (); +@@ -1479,12 +2397,26 @@ + x_window_sweep, x_window_mark, + 0, 0, 0, 0, 0, 0, 0); + rep_ADD_SUBR (Sx_create_window); ++ rep_ADD_SUBR (Sx_reparent_window); + rep_ADD_SUBR (Sx_create_pixmap); + rep_ADD_SUBR (Sx_create_bitmap); ++ rep_ADD_SUBR (Sx_map_request); ++ rep_ADD_SUBR (Sx_map_notify); + rep_ADD_SUBR (Sx_map_window); ++ rep_ADD_SUBR (Sx_x_map_window); ++ rep_ADD_SUBR (Sx_map_raised); ++ rep_ADD_SUBR (Sx_map_subwindows); + rep_ADD_SUBR (Sx_unmap_window); ++ rep_ADD_SUBR (Sx_unmap_subwindows); ++ rep_ADD_SUBR (Sx_configure_request); + rep_ADD_SUBR (Sx_configure_window); + rep_ADD_SUBR (Sx_change_window_attributes); ++ rep_ADD_SUBR (Sx_x_raise_window); ++ rep_ADD_SUBR (Sx_x_lower_window); ++ rep_ADD_SUBR (Sx_circulate_subwindows); ++ rep_ADD_SUBR (Sx_circulate_subwindows_up); ++ rep_ADD_SUBR (Sx_circulate_subwindows_down); ++ rep_ADD_SUBR (Sx_restack_windows); + rep_ADD_SUBR (Sx_destroy_drawable); + rep_ADD_SUBR (Sx_destroy_window); + rep_ADD_SUBR (Sx_drawable_p); +@@ -1498,6 +2430,16 @@ + rep_ADD_SUBR (Sx_window_back_buffer); + rep_ADD_SUBR (Sx_window_swap_buffers); + ++ rep_ADD_SUBR (Sx_window_put); ++ rep_ADD_SUBR (Sx_window_get); ++ ++ rep_ADD_SUBR (Sx_set_text_property); ++ rep_ADD_SUBR (Sx_get_text_property); ++ rep_ADD_SUBR (Sx_list_properties); ++ rep_ADD_SUBR (Sx_change_property); ++ rep_ADD_SUBR (Sx_rotate_window_properties); ++ rep_ADD_SUBR (Sx_delete_property); ++ + rep_ADD_SUBR (Sx_clear_window); + rep_ADD_SUBR (Sx_draw_string); + rep_ADD_SUBR (Sx_draw_line); +@@ -1534,6 +2476,36 @@ + rep_INTERN (clip_mask); + rep_INTERN (clip_x_origin); + rep_INTERN (clip_y_origin); ++ rep_INTERN (sibling); ++ rep_INTERN (stack_mode); ++ rep_INTERN (override_redirect); ++ rep_INTERN (save_under); ++ rep_INTERN (event_mask); ++ rep_INTERN (parent); ++ ++ rep_INTERN (serial); ++ rep_INTERN (send_event); ++ rep_INTERN (event); ++ rep_INTERN (window); ++ rep_INTERN (subwindow); ++ rep_INTERN (time); ++ rep_INTERN (x_root); ++ rep_INTERN (y_root); ++ rep_INTERN (state); ++ rep_INTERN (keycode); ++ rep_INTERN (same_screen); ++ rep_INTERN (button); ++ rep_INTERN (is_hint); ++ rep_INTERN (focus); ++ rep_INTERN (mode); ++ rep_INTERN (detail); ++ rep_INTERN (count); ++ rep_INTERN (message_type); ++ rep_INTERN (format); ++ rep_INTERN (data); ++ rep_INTERN (above); ++ rep_INTERN (raise_lowest); ++ rep_INTERN (lower_highest); + + rep_INTERN (LineSolid); + rep_INTERN (LineOnOffDash); diff --git a/x11-wm/sawfish-merlin/sawfish-merlin-1.0.1.ebuild b/x11-wm/sawfish-merlin/sawfish-merlin-1.0.1.ebuild new file mode 100644 index 000000000000..e6abcb7a2062 --- /dev/null +++ b/x11-wm/sawfish-merlin/sawfish-merlin-1.0.1.ebuild @@ -0,0 +1,91 @@ +# Copyright 2001 theLeaf sprl/bvba +# Author Geert Bevin <gbevin@theleaf.be> +# $Header: /var/cvsroot/gentoo-x86/x11-wm/sawfish-merlin/sawfish-merlin-1.0.1.ebuild,v 1.1 2002/02/17 16:15:06 gbevin Exp $ + +A=sawfish-${PV}.tar.gz +S=${WORKDIR}/sawfish-${PV} +DESCRIPTION="Extensible window manager using a Lisp-based scripting language" +SRC_URI="http://prdownloads.sourceforge.net/sawmill/"${A} +HOMEPAGE="http://sawmill.sourceforge.net/" + +DEPEND=">=dev-libs/rep-gtk-0.15-r1 + >=dev-libs/librep-0.14 + >=media-libs/imlib-1.9.10-r1 + esd? ( >=media-sound/esound-0.2.22 ) + readline? ( >=sys-libs/readline-4.1 ) + nls? ( sys-devel/gettext ) + gnome? ( >=media-libs/gdk-pixbuf-0.11.0-r1 + >=gnome-base/gnome-core-1.4.0.4-r1 )" + +RDEPEND=">=dev-libs/rep-gtk-0.15-r1 + >=dev-libs/librep-0.14 + >=x11-libs/gtk+-1.2.10-r4 + >=media-libs/imlib-1.9.10-r1 + esd? ( >=media-sound/esound-0.2.22 ) + gnome? ( >=media-libs/gdk-pixbuf-0.11.0-r1 + >=gnome-base/gnome-core-1.4.0.4-r1 )" + +src_unpack() { + + unpack ${A} + cd ${S}/po + cd ${S}/src + patch -p1 < ${FILESDIR}/x.c.patch-merlin-1.0.2 +} + + +src_compile() { + + local myconf + if [ "`use esd`" ] + then + myconf="--with-esd" + else + myconf="--without-esd" + fi + if [ "`use gnome`" ] + then + myconf="${myconf} --with-gnome-prefix=/usr --enable-gnome-widgets --enable-capplet" + else + myconf="${myconf} --disable-gnome-widgets --disable-capplet --without-gdk-pixbuf" + fi + if [ "`use readline`" ] + then + myconf="${myconf} --with-readline" + else + myconf="${myconf} --without-readline" + fi + if [ -z "`use nls`" ] + then + myconf="${myconf} --disable-linguas" + fi + + ./configure --host=${CHOST} \ + --prefix=/usr \ + --infodir=/usr/share/info \ + --libexecdir=/usr/lib \ + --with-audiofile \ + ${myconf} || die + + emake || die + +} + +src_install() { + mkdir -p ${D}/usr/lib/sawfish/${PV}/sawfish-merlin/sawfish/wm/util + cp src/.libs/x.* ${D}/usr/lib/sawfish/${PV}/sawfish-merlin + cp src/.libs/x.* ${D}/usr/lib/sawfish/${PV}/sawfish-merlin/sawfish/wm/util + + dodir /etc/X11/gdm/Sessions/ + exeinto /etc/X11/gdm/Sessions/ + newexe ${FILESDIR}/gdm_session Sawfish + + dodir /etc/skel + insinto /etc/skel + cp -a ${FILESDIR}/sawfish ${D}/etc/skel/.sawfish + find ${D}/etc/skel/.sawfish -name "CVS" -exec rm -rf '{}' ';' + cp -a ${FILESDIR}/sawfishrc ${D}/etc/skel/.sawfishrc +} + + + |