From 1d426ce2dd3d846328ae9b920bd71c8ca2bacaa8 Mon Sep 17 00:00:00 2001
From: frese <frese>
Date: Sun, 30 Mar 2003 01:49:10 +0000
Subject: [PATCH] added free-options fixed wm-hints stuff added
 uppercase/lowercase to keys option

---
 src/utils.scm | 67 +++++++++++++++++++++++++++++++++++----------------
 1 file changed, 46 insertions(+), 21 deletions(-)

diff --git a/src/utils.scm b/src/utils.scm
index cb1eb9d..2917b96 100644
--- a/src/utils.scm
+++ b/src/utils.scm
@@ -68,9 +68,22 @@
 	      option-alist type-alist)
     (make-options dpy colormap option-alist value-alist type-alist)))
 
-(define (free-options options)
-  ;; TODO
-  #t)
+;; if the colormap gets freed, then the colors don't have to
+(define (free-options options free-colors?)
+  (for-each (lambda (n.v)
+	      (let* ((name (car n.v))
+		     (value (cdr n.v))
+		     (type (assq/false name (options:type-alist options))))
+		(cond
+		 ((eq? (option-type font) type)
+		  (unload-font (options:dpy options) value))
+		 ((eq? (option-type color) type)
+		  (free-colors (options:dpy options) (options:colormap options)
+			       (list value) 0))
+		 ((eq? (option-type colors) type)
+		  (free-colors (options:dpy options) (options:colormap options)
+			       value 0)))))
+	    (options:value-alist options)))
 
 (define (get-option-value options name)
   (let ((p (assq name (options:value-alist options))))
@@ -120,10 +133,13 @@
     (define id (list (list (quote name) (option-type type) default)
 		     ...)))))
 
+(define (options-spec-union spec1 spec2)
+  (append spec1 spec2))
+
 (define (allocate-option dpy colormap name type def)
   (let ((check (lambda (value pred)
 		 (if (not (pred value))
-		     (error "wrong type argument" value) ;; TODO: other??
+		     (error "wrong type argument" value) ;; TODO: other error??
 		     value))))
     (cond
      ((eq? type (option-type int)) (check def integer?))
@@ -167,13 +183,20 @@
 	 (keys (map (lambda (s) (string->key dpy s)) keys-s)))
     (and (not (memq #f keys)) keys)))
 
+(define (is-uppercase? keysym)
+  (let ((low.up (convert-case keysym)))
+    (not (equal? (car low.up) keysym))))
+
 (define (string->key dpy s)
   (let* ((l (reverse (split-minus s)))
 	 (mod-strings (reverse (cdr l)))
 	 (key-string (car l))
-	 (modifiers (strings->modifiers mod-strings))
-	 ;; TODO: upcase chars + Shift
-	 (keycode (keysym->keycode dpy (string->keysym key-string))))
+	 (keysym (string->keysym key-string))
+	 (keycode (keysym->keycode dpy keysym))
+	 (modifiers (enum-set-union (if (is-uppercase? keysym)
+					(state-set shift)
+					(state-set))
+				    (strings->modifiers mod-strings))))
     (and modifiers keycode
 	 (make-key modifiers keycode))))
 
@@ -202,10 +225,9 @@
 ;; *** xlib utilities ************************************************
 
 (define (reparent-to-root dpy window)
-  ;; reparent window to it's root-window so that it stays virtually at
-  ;; the same position.
-  ;; TODO
-  (reparent-window dpy window (window-root dpy window)))
+  (let ((r (root-rectangle dpy window)))
+    (reparent-window dpy window (window-root dpy window)
+		     (rectangle:x r) (rectangle:y r))))
 
 (define (window-path dpy window)
   (cons window
@@ -347,18 +369,21 @@
                        (height (cdr size))))))
 
 (define (desired-size/hints dpy window default-size)
-  (let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
-         (size (or (assq/false (size-hint us-size) hints)
-                   (assq/false (size-hint size) hints)
-                   default-size)))
-    (adjust-size/hints hints (car size) (cdr size))))
+  (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
+    (if hints
+	(let ((size (or (assq/false (size-hint us-size) hints)
+			(assq/false (size-hint size) hints)
+			default-size)))
+	  (adjust-size/hints hints (car size) (cdr size)))
+	default-size)))
 
 (define (desired-position/hints dpy window default-position)
-  (let* ((hints (get-wm-normal-hints dpy window)) ;; or group-leader?
-         (pos (or (assq/false (size-hint us-position) hints)
-                  (assq/false (size-hint position) hints)
-                  default-position)))
-    pos))
+  (let ((hints (get-wm-normal-hints dpy window))) ;; or group-leader?
+    (if hints
+	(or (assq/false (size-hint us-position) hints)
+	    (assq/false (size-hint position) hints)
+	    default-position)
+	default-position)))
 
 ;; returns width/height pair that conform to the defined
 ;; aspects/resize-inc etc. in hints, and are as close as possible to