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

[Philippe Brochard]

Author: pbrochard
Date: Thu Sep  9 15:12:49 2010
New Revision: 314

Log:
src/clfswm-util.lisp (update-menus): Follow XDG specifications instead of the non-portable Debian update-menu.

Modified:
   clfswm/ChangeLog
   clfswm/TODO
   clfswm/src/clfswm-menu.lisp
   clfswm/src/clfswm-util.lisp
   clfswm/src/tools.lisp

Modified: clfswm/ChangeLog
==============================================================================
--- clfswm/ChangeLog	(original)
+++ clfswm/ChangeLog	Thu Sep  9 15:12:49 2010
@@ -1,3 +1,8 @@
+2010-09-09  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-util.lisp (update-menus): Follow XDG specifications
+	instead of the non-portable Debian update-menu.
+
 2010-09-07  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm.lisp (error-handler): New function do handle

Modified: clfswm/TODO
==============================================================================
--- clfswm/TODO	(original)
+++ clfswm/TODO	Thu Sep  9 15:12:49 2010
@@ -7,12 +7,15 @@
 ===============
 Should handle these soon.
 
-Nothing here :)
+- Use xdg menu spec instead of the Debian specific update-menu command.
+
+- Add a data slot to tell if a frame must hide or not its floating windows when its not selected.
+
 
 MAYBE
 =====
 
-- cd/pwd a la shell to navigate through frames. [Philippe]
+- cd/pwd a la shell to navigate through frames.
 
 - Zoom
 

Modified: clfswm/src/clfswm-menu.lisp
==============================================================================
--- clfswm/src/clfswm-menu.lisp	(original)
+++ clfswm/src/clfswm-menu.lisp	Thu Sep  9 15:12:49 2010
@@ -53,6 +53,14 @@
 	       (equal name (menu-name item)))
       (return-from find-menu item))))
 
+(defun find-toplevel-menu (name &optional (root *menu*))
+  (when (menu-p root)
+    (dolist (item (menu-item root))
+      (when (and (menu-item-p item)
+		 (menu-p (menu-item-value item)))
+	(when (equal name (menu-name (menu-item-value item)))
+	  (return (menu-item-value item)))))))
+
 
 (defun find-item-by-key (key &optional (root *menu*))
   (with-all-menu (root item)
@@ -87,9 +95,13 @@
   (let ((menu (find-menu menu-name root)))
     (add-item (make-menu-item :key (find-next-menu-key key menu) :value value) (find-menu menu-name root))))
 
-(defun add-sub-menu (menu-name key sub-menu-name &optional (doc "Sub menu") (root *menu*))
-  (let ((menu (find-menu menu-name root)))
-    (add-item (make-menu-item :key (find-next-menu-key key menu) :value (make-menu :name sub-menu-name :doc doc)) menu)))
+(defun add-sub-menu (menu-or-name key sub-menu-name &optional (doc "Sub menu") (root *menu*))
+  (let ((menu (if (or (stringp menu-or-name) (symbolp menu-or-name))
+		  (find-menu menu-or-name root)
+		  menu-or-name))
+	(submenu (make-menu :name sub-menu-name :doc doc)))
+    (add-item (make-menu-item :key (find-next-menu-key key menu) :value submenu) menu)
+    submenu))
 
 
 

Modified: clfswm/src/clfswm-util.lisp
==============================================================================
--- clfswm/src/clfswm-util.lisp	(original)
+++ clfswm/src/clfswm-util.lisp	Thu Sep  9 15:12:49 2010
@@ -1209,55 +1209,71 @@
 
 
 
-;;; Standard menu functions - Based on the 'update-menus' command
-(defun um-extract-value (name line)
-  (let* ((fullname (format nil "~A=\"" name))
-	 (pos (search fullname line)))
-    (when (numberp pos)
-      (let* ((start (+ pos (length fullname)))
-	     (end (position #\" line :start start)))
-	(when (numberp end)
-	  (subseq line start end))))))
-
-
-(defun um-create-section (menu section-list)
-  (if section-list
-      (let* ((sec (intern (string-upcase (first section-list)) :clfswm))
-	     (submenu (find-menu sec menu)))
-	(if submenu
-	    (um-create-section submenu (rest section-list))
-	    (progn
-	      (add-sub-menu (menu-name menu) :next sec (format nil "~A" sec) menu)
-	      (um-create-section (find-menu sec menu) (rest section-list)))))
-      menu))
+;;; Standard menu functions - Based on the XDG specifications
+(defparameter *xdg-section-list* (nconc '(TextEditor FileManager WebBrowser)
+					'(AudioVideo Audio Video Development Education Game Graphics Network Office Settings System Utility)
+					'(TerminalEmulator Archlinux))
+  "Config(Menu group): Standard menu sections")
+
+
+(defun um-create-xdg-section-list (menu)
+  (dolist (section *xdg-section-list*)
+    (add-sub-menu menu :next section (format nil "~A" section) menu)))
+
+(defun um-find-submenu (menu section-list)
+  (let ((acc nil))
+    (dolist (section section-list)
+      (awhen (find-toplevel-menu (intern (string-upcase section) :clfswm) menu)
+	(push it acc)))
+    (if acc
+	acc
+	(list (find-toplevel-menu 'Utility menu)))))
+
+
+(defun um-extract-value (line)
+  (second (split-string line #\=)))
+
+
+(defun um-add-desktop (desktop menu)
+  (let (name exec categories comment)
+    (when (probe-file desktop)
+      (with-open-file (stream desktop :direction :input)
+	(loop for line = (read-line stream nil nil)
+	   while line
+	   do
+	   (cond ((first-position "Name=" line) (setf name (um-extract-value line)))
+		 ((first-position "Exec=" line) (setf exec (um-extract-value line)))
+		 ((first-position "Categories=" line) (setf categories (um-extract-value line)))
+		 ((first-position "Comment=" line) (setf comment (um-extract-value line))))
+	   (when (and name exec categories)
+	     (let* ((sub-menu (um-find-submenu menu (split-string categories #\;)))
+		    (fun-name (intern name :clfswm)))
+	       (setf (symbol-function fun-name) (let ((do-exec exec))
+						  (lambda ()
+						    (do-shell do-exec)
+						    (leave-second-mode)))
+		     (documentation fun-name 'function) (format nil "~A~A" name (if comment
+										    (format nil " - ~A" comment)
+										    "")))
+	       (dolist (m sub-menu)
+		 (add-menu-key (menu-name m) :next fun-name m)))
+	     (setf name nil exec nil categories nil comment nil)))))))
 
 
 (defun update-menus (&optional (menu (make-menu :name 'main :doc "Main menu")))
-  (let ((output (do-shell "update-menus --stdout")))
-    (loop for line = (read-line output nil nil)
-	  while line
-	  do (let ((command (um-extract-value "command" line)))
-	       (when command
-		 (let* ((sub-menu (um-create-section menu (split-string (um-extract-value "section" line) #\/)))
-			(title (um-extract-value " title" line))
-			(doc (um-extract-value "description" line))
-			(name (intern title :clfswm)))
-		   (setf (symbol-function name) (lambda ()
-						  (do-shell command)
-						  (leave-second-mode))
-			 (documentation name 'function) (format nil "~A~A" title (if doc (format nil " - ~A" doc) "")))
-		   (add-menu-key (menu-name sub-menu) :next name sub-menu)))))
+  (um-create-xdg-section-list menu)
+  (let ((count 0)
+	(found (make-hash-table :test #'equal)))
+    (dolist (dir (remove-duplicates
+		  (split-string (getenv "XDG_DATA_DIRS") #\:) :test #'string-equal))
+      (dolist (desktop (directory (concatenate 'string dir "/applications/*.desktop")))
+	(unless (gethash (file-namestring desktop) found)
+	  (setf (gethash (file-namestring desktop) found) t)
+	  (um-add-desktop desktop menu)
+	  (incf count))))
     menu))
 
 
-(defun show-standard-menu ()
-  "< Standard menu >"
-  (let ((menu (update-menus)))
-    (if (menu-item menu)
-       (open-menu menu)
-       (info-mode '("Command 'update-menus' not found")))))
-
-
 
 ;;; Close/Kill focused window
 

Modified: clfswm/src/tools.lisp
==============================================================================
--- clfswm/src/tools.lisp	(original)
+++ clfswm/src/tools.lisp	Thu Sep  9 15:12:49 2010
@@ -311,7 +311,9 @@
   (intern (string-upcase (apply #'concatenate 'string names))))
 
 (defun number->char (number)
-  (code-char (+ (char-code #\a) number)))
+  (if (< number 26)
+      (code-char (+ (char-code #\a) number))
+      #\|))
 
 (defun simple-type-of (object)
   (let ((type (type-of object)))