[clfswm-cvs] r171 - in clfswm: . src

[pbrochard at common-lisp.net]

Author: pbrochard
Date: Tue Sep 23 09:16:39 2008
New Revision: 171

Modified:
   clfswm/ChangeLog
   clfswm/src/clfswm-internal.lisp
   clfswm/src/clfswm-util.lisp
   clfswm/src/menu-def.lisp
Log:
ensure-unique-name/number: New function and menu entry.

Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog	(original)
+++ clfswm/ChangeLog	Tue Sep 23 09:16:39 2008
@@ -1,3 +1,9 @@
+2008-09-23  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-util.lisp (ensure-unique-name): New function and menu
+	entry.
+	(ensure-unique-number): New function and menu entry.
+
 2008-09-22  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm-nw-hooks.lisp (named-frame-nw-hook): New new window

Modified: clfswm/src/clfswm-internal.lisp
==============================================================================
--- clfswm/src/clfswm-internal.lisp	(original)
+++ clfswm/src/clfswm-internal.lisp	Tue Sep 23 09:16:39 2008
@@ -141,6 +141,22 @@
   "???")
 
 
+(defgeneric set-child-name (child name))
+
+(defmethod set-child-name ((child xlib:window) name)
+  (setf (xlib:wm-name child) name))
+
+(defmethod set-child-name ((child frame) name)
+  (setf (frame-name child) name))
+
+(defmethod set-child-name (child name)
+  (declare (ignore child name)))
+
+(defsetf child-name set-child-name)
+
+
+
+
 (defgeneric child-fullname (child))
 
 (defmethod child-fullname ((child xlib:window))

Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp	(original)
+++ clfswm/src/clfswm-util.lisp	Tue Sep 23 09:16:39 2008
@@ -1102,3 +1102,47 @@
   "Set a sloppy select policy for all frames."
     (set-focus-policy-generic-for-all :sloppy-select))
 
+
+
+;;; Ensure unique name/number functions
+(defun extract-number-from-name (name)
+  (when (stringp name)
+    (let* ((pos (1+ (or (position #\. name :from-end t) -1)))
+	   (number (parse-integer name :junk-allowed t :start pos)))
+      (values number
+	      (if number (subseq name 0 (1- pos)) name)))))
+    
+
+		   
+
+(defun ensure-unique-name ()
+  "Ensure that all children names are unique"
+  (with-all-children (*root-frame* child)
+    (multiple-value-bind (num1 name1)
+	(extract-number-from-name (child-name child))
+      (declare (ignore num1))
+      (when name1
+	(let ((acc nil))
+	  (with-all-children (*root-frame* c)
+	    (unless (equal child c))
+	    (multiple-value-bind (num2 name2)
+		(extract-number-from-name (child-name c))
+	      (when (string-equal name1 name2)
+		(push num2 acc))))
+	  (dbg acc)
+	  (when (> (length acc) 1)
+	    (setf (child-name child)
+		  (format nil "~A.~A" name1
+			  (1+ (find-free-number (loop for i in acc when i collect (1- i)))))))))))
+  (leave-second-mode))
+
+(defun ensure-unique-number ()
+  "Ensure that all children numbers are unique"
+  (let ((num -1))
+    (with-all-frames (*root-frame* frame)
+      (setf (frame-number frame) (incf num))))
+  (leave-second-mode))
+
+
+
+  
\ No newline at end of file

Modified: clfswm/src/menu-def.lisp
==============================================================================
--- clfswm/src/menu-def.lisp	(original)
+++ clfswm/src/menu-def.lisp	Tue Sep 23 09:16:39 2008
@@ -59,6 +59,8 @@
 
 
 (add-menu-key 'child-menu "r" 'rename-current-child)
+(add-menu-key 'child-menu "e" 'ensure-unique-name)
+(add-menu-key 'child-menu "n" 'ensure-unique-number)
 (add-menu-key 'child-menu "x" 'remove-current-child-from-tree)
 (add-menu-key 'child-menu "Delete" 'remove-current-child)
 (add-menu-key 'child-menu "h" 'hide-current-child)