Re: [Patch] apps-menu filtering



There was a small bug in the last patch, this one should be used
instead.  Only categories with a trailing ";" would be recognized 
before, it is fixed now :)

diff --git a/lisp/sawfish/wm/ext/apps-menu.jl b/lisp/sawfish/wm/ext/apps-menu.jl
index 5dc7405..49e32e2 100644
--- a/lisp/sawfish/wm/ext/apps-menu.jl
+++ b/lisp/sawfish/wm/ext/apps-menu.jl
@@ -29,7 +29,6 @@
 ;; 'fdo' in some names stands for "freedesktop.org".
 
 ;;; Todo:
-;;  * Acquisition of the locale is wrong.
 
 ;;; Notes: we don't handle non-utf8 encoding.
 
@@ -39,7 +38,16 @@
 
     (export generate-apps-menu
 	    init-apps-menu
-	    update-apps-menu)
+	    update-apps-menu
+	    parse-desktop-file
+	    ;; filtering
+	    fdo-filter-record
+	    fdo-nodisplay-filter
+	    fdo-hidden-filter
+	    fdo-onlyshowin-filter
+	    fdo-notshowin-filter
+	    fdo-default-filter
+	    fdo-some-filter)
 
     (open rep
 	  rep.io.files
@@ -62,11 +70,17 @@ and *.desktop files. If you set `apps-menu', then it won't happen anyway.")
     "Your own applications menu entries. It is followed by auto generated
 applications menu.")
 
-  (defvar apps-menu-show-all nil
-    "Some entries are hidden from the menu, especially GNOME Apps like
-eog, nautilus or evince. If you want to have them added to your menu,
-set this to non-nil.")
-  
+  (defvar apps-menu-filter 'default
+    "The filter to use while generating the `apps-menu'. The default filters
+include `fdo-nodisplay-filter' `fdo-hidden-filter' `fdo-onlyshowin-filter'
+and `fdo-notshowin-filter'.  Can also be set with 'default or 'some, both
+of which are combinations of the default filters, 'default uses them all
+and 'some only uses `fdo-notshowin-filter' and `fdo-onlyshowin-filter'.
+This can be set to 'nil or '() to perform no filtering on the `apps-menu'.")
+
+  (defvar apps-menu-associate-categories t
+    "Associate desktop entry categories with the category-master-list")
+
   (defvar desktop-directory '("/usr/share/applications")
     "List of directories to look for *.desktop files.")
 
@@ -77,46 +91,50 @@ set this to non-nil.")
     "Language for applications menu, in string. Default is set from locale.")
 
   (define this-line nil)
-  (define local-menu)
   (define name-string "Name[")
 
   ;; fdo-desktop-file-parsing
 
   (define (desktop-skip-line-p instring)
+    "Return `t' if `instring' should be skipped."
     (or (eq (aref instring 0) ?#)
 	(eq (aref instring 0) ?\n)))
-
+  
   (define (check-if-desktop-stream instream)
+    "Check for the `[Desktop Entry]' line in `instream'"
     (let ((line (read-line instream)))
       (when line
 	(if (string= line "[Desktop Entry]\n")
 	    't
 	  (when (desktop-skip-line-p line)
 	    (check-if-desktop-stream instream))))))
-
+  
   (define (desktop-file-p directory-file)
+    "Quickly check if `directory-file' is a `*.desktop' file."
     (condition-case nil
 	(let ((this-file (open-file directory-file 'read)))
 	  (check-if-desktop-stream this-file))
       ;; unreadable -> return nil
       (file-error)))
-
+  
   (define (desktop-group-p instring)
     (eq (aref instring 0) ?\[))
-
-  ;; returns (key . value)
+  
   (define (get-key-value-pair instring)
+    "Split a `*.desktop' file line into it's key-value pair.
+Returns (key . value)"
     ;; Sorry, \\s doesn't work. Why??
     (if (string-match "^([^ \t=]+)[ \t]*=[ \t]*([^\n]+)" instring)
 	(cons (expand-last-match "\\1") (expand-last-match "\\2"))
       ;; Ususally, it doesn't reach here.
       (cons "" "")))
-
+  
   (define (get-desktop-group instring)
     (substring instring 1 (- (length instring) 2)))
-
-  ;; Returns (group1 (key1 . value1) ... group2 (keyA . valueA) ...)
+  
   (define (parse-desktop-file-line infile)
+    "Parse a `*.desktop' file line.
+Returns (group1 (key1 . value1) ... group2 (keyA . valueA) ...)"
     (when (setq this-line (read-line infile))
       (if (not (desktop-skip-line-p this-line))
 	  (cons
@@ -127,23 +145,32 @@ set this to non-nil.")
 	(parse-desktop-file-line infile))))
 
   (define (parse-desktop-file infile)
-    (let ((d-file (open-file infile 'read)))
-      (parse-desktop-file-line d-file)))
-
-  ;; generic functions
-
-  (define (map-desk-files in-desk-files in-directory)
+    "Parse a `*.desktop' file and return an alist."
+    (when (desktop-file-p infile)
+      (let ((d-file (open-file infile 'read)))
+	(parse-desktop-file-line d-file))))
+  
+  ;; desktop-file mapping
+  
+  (define (map-desk-files in-desk-files in-directory #!optional (extension "."))
+    "Given a list of filenames and a directory, will expand those
+filenames to include the full path."
     (when in-desk-files
-      (cons (expand-file-name (car in-desk-files) in-directory)
-	    (map-desk-files (cdr in-desk-files) in-directory))))
-
-  (define (map-dir-files directories)
+      (if (string-match extension (car in-desk-files))
+	  (cons (expand-file-name (car in-desk-files) in-directory)
+		(map-desk-files (cdr in-desk-files) in-directory extension))
+	(map-desk-files (cdr in-desk-files) in-directory extension))))
+  
+  (define (map-dir-files directories #!optional (extension "."))
+    "Given a list of directory paths, will return a list of
+files in those direcories with their full pathnames.  Optionally
+`extension' may be set to show only files that match the regexp."
     (when directories
       (if (file-directory-p (car directories))
 	  (let ((desk0 (directory-files (car directories))))
-	    (cons (map-desk-files desk0 (car directories))
-		  (map-dir-files (cdr directories))))
-	(map-dir-files (cdr directories)))))
+	    (cons (map-desk-files desk0 (car directories) extension)
+		  (map-dir-files (cdr directories) extension)))
+	(map-dir-files (cdr directories) extension))))
 
   (define (flatten input)
     (cond ((null input) nil)
@@ -151,25 +178,19 @@ set this to non-nil.")
 	  (t (append (flatten (car input))
 		     (flatten (cdr input))))))
 
-  ;; Cut the string before % sign if present.
-  ;; In fact, %% means "escaped %". Let's forget :/
-  (define (trim-percent string)
-    (if (string-match "%" string)
-	(substring string 0 (match-start))
-      string))
-
   (defmacro simplify-mlang (mlang mlevel)
     `(and
-      ,(if (or (= 0 mlevel) (not mlevel))
-	   `(or (string-looking-at "([a-z]*)(_?)([A-Z]*?)(@)([A-Z]*[a-z]*)?" ,mlang)
-		(string-looking-at "([a-z]*)(_..)|([a-z]*)?" ,mlang)
-		(string-looking-at "([a-z]*)?" ,mlang))
-	 (if (= 1 mlevel)
-	     `(string-looking-at "([a-z]*)(_?)([A-Z]*?)(@)([A-Z]*[a-z]*)?" ,mlang)
-	   (if (= 2 mlevel)
-	       `(string-looking-at "([a-z]*)(_..)|([a-z]*)?" ,mlang)
-	     (if (= 3 mlevel)
-		 `(string-looking-at "([a-z]*)?" ,mlang)))))
+      ,(cond 
+	((or (= 0 mlevel) (not mlevel))
+	 `(or (string-looking-at "([a-z]*)(_?)([A-Z]*?)(@)([A-Z]*[a-z]*)?" ,mlang)
+	      (string-looking-at "([a-z]*)(_..)|([a-z]*)?" ,mlang)
+	      (string-looking-at "([a-z]*)?" ,mlang)))
+	((= 1 mlevel)
+	 `(string-looking-at "([a-z]*)(_?)([A-Z]*?)(@)([A-Z]*[a-z]*)?" ,mlang))
+	((= 2 mlevel)
+	 `(string-looking-at "([a-z]*)(_..)|([a-z]*)?" ,mlang))
+	((= 3 mlevel)
+	 `(string-looking-at "([a-z]*)?" ,mlang)))
       (expand-last-match "\&")))
 
   (define (find-lang-string)
@@ -222,58 +243,80 @@ set this to non-nil.")
       ("Settings" . ("Settings" "HardwareSettings" "PackageManager"))
       ("Exiles" . ("Exile"))))
 
-  ;; Get the correct Name entry based on language settings
-  (define (determine-desktop-name fdo-list)
-    (or (when apps-menu-lang
-	  (let ((mlang-1 (concat name-string (simplify-mlang apps-menu-lang 1) "]"))
-		(mlang-2 (concat name-string (simplify-mlang apps-menu-lang 2) "]"))
-		(mlang-3 (concat name-string (simplify-mlang apps-menu-lang 3) "]")))
-	    (or (cdr (assoc mlang-1 fdo-list))
-		(cdr (assoc mlang-2 fdo-list))
-		(cdr (assoc mlang-3 fdo-list)))))
-	(cdr (assoc "Name" fdo-list))))
-
   ;; Functions for categories
-  (define (fix-sub-cats cat-list loc-list)
-    (when cat-list
-      (let ((cat-val (car cat-list)))
-	(if (assoc cat-val loc-list)
-	    (cons (cdr (assoc cat-val loc-list))
-		  (fix-sub-cats cat-list (remove (assoc cat-val loc-list)
-						 loc-list)))
-	  (fix-sub-cats (cdr cat-list) loc-list)))))
-
-  ;; Associate values from the Master Category list with sub-categories
-  ;; from file
-  (define (fix-cats cat-list)
-    (when cat-list
-      (let ((cat-val (car (car cat-list)))
-	    (c-list (fix-sub-cats (car cat-list) local-menu)))
-	(if (car c-list)
-	    (cons (cons cat-val c-list) (fix-cats (cdr cat-list)))
-	  (fix-cats (cdr cat-list))))))
-
-  ;; Determine the best :| category to use. This will further be
-  ;; converted with fix-cats.
-  (define (determine-desktop-category line)
-    (let loop ((cat-list (string-split ";" line))
-	       this-cat)
-	 (if (cdr cat-list)
-	     (progn
-	       (setq this-cat (car cat-list))
-	       (if (or
-		    (string= this-cat "GNOME")
-		    (string= this-cat "GTK")
-		    (string= this-cat "KDE")
-		    (string= this-cat "Qt")
-		    (string= this-cat "X-XFCE")
-		    (string= this-cat "Application"))
-		   (loop (cdr cat-list) nil)
-		 this-cat))
-	   (car cat-list))))
-
-  ;; Alphabetize the entries in the category menus
+
+  (define (remove-duplicates input)
+    "Remove duplicate entries from `input'"
+    (do ((a '() (if (member (car input) a) a (cons (car input) a)))
+	 (input input (cdr input)))
+	((null input) (reverse a))))
+
+  (define (merge-list input delimiter)
+    "Merge a cons list `input' into a string separated by `delimiter'"
+    (when input
+      (concat (car input) delimiter 
+	      (merge-list (cdr input) delimiter))))
+
+  (define (associate-categories fdol)
+    "Associate the `Categories' value(s) with the category 
+master list.  Returns a modified desktop-file entry."
+    (when fdol
+      (let* ((these-categories 
+	     (remove "" (string-split ";" (cdr (assoc "Categories" fdol)))))
+	    (category-list (list these-categories)))
+	(let loop ((this-category these-categories))
+	     (if (null this-category)
+		 (progn (rplacd (assoc "Categories" fdol)
+				(merge-list (remove-duplicates category-list) ";"))
+			fdol)
+	       (progn (mapc (lambda (ent)
+			      (if (member (car this-category) ent)
+				  (setq category-list 
+					(append category-list (list (car ent))))))
+			    desktop-cat-alist)
+		      (loop (cdr this-category))))))))
+
+  (define (grab-category input cat)
+    "Remove duplicate categories from a generated apps-menu list by 
+category name."
+    (when input
+      (let ((cat-list '()))
+	(setq cat-list (append cat-list (list cat)))
+	(let loop ((this-line input))
+	     (if (not this-line) cat-list
+	       (progn (if (string= (caar this-line) cat)
+			  (setq cat-list (append cat-list (list (cdr (car this-line))))))
+		      (loop (cdr this-line))))))))
+
+
+  (define (make-category-list input)
+    "Return a list of the categories to be used in the menu."
+    (when input
+      (cons (caar input)
+	    (make-category-list (cdr input)))))
+  
+  (define (consolodate-menu input)
+    "Reduce the menu down so that each menu entry is inside a 
+single category."
+    (when input
+      (let ((cat-list (remove-duplicates (make-category-list input)))
+	    (out-menu nil))
+	(mapc (lambda (x)
+		(setq out-menu 
+		      (append out-menu
+			      (list (grab-category input x)))))
+	      cat-list)
+	out-menu)))
+
+  ;; In fact, %% means "escaped %". Let's forget :/
+  (define (trim-percent string)
+    "Cut the string begore % sign if present."
+    (if (string-match "%" string)
+	(substring string 0 (match-start))
+      string))
+
   (define (alphabetize-entries saw-menu)
+    "Alphabetize the entries in the category menus."
     (if saw-menu
 	(cons (cons (car (car saw-menu))
 		    (sort (cdr (car saw-menu)) 
@@ -303,9 +346,9 @@ with caution, file may be corrupt.\n"))
 	(setq fdo-list (append fdo-list (cons (cons "Name"
 						    "Unknown")))))
       (if (assoc "Categories" fdo-list)
-	  (rplacd (assoc "Categories" fdo-list) "Exile")
+	  (rplacd (assoc "Categories" fdo-list) "Exile;")
 	(setq fdo-list (append fdo-list (cons (cons "Categories"
-						    "Exile")))))
+						    "Exile;")))))
       fdo-list))
 
   (define (fdo-check-exile fdo-list)
@@ -321,86 +364,144 @@ exile it."
 	  (fdo-exile fdo-list)
 	fdo-list)))
 
+  (define (determine-desktop-name fdo-list)
+    "Get the correct Name[*] entry based on language settings."
+    (or (when apps-menu-lang
+	  (let ((mlang-1 (concat name-string (simplify-mlang apps-menu-lang 1) "]"))
+		(mlang-2 (concat name-string (simplify-mlang apps-menu-lang 2) "]"))
+		(mlang-3 (concat name-string (simplify-mlang apps-menu-lang 3) "]")))
+	    (or (cdr (assoc mlang-1 fdo-list))
+		(cdr (assoc mlang-2 fdo-list))
+		(cdr (assoc mlang-3 fdo-list)))))
+	(cdr (assoc "Name" fdo-list))))
+
   (define (determine-desktop-exec fdo-list)
     "Determine the correct `(system exec)' function from the given fdo alist"
-    (if (string= (cdr (assoc "Terminal" fdo-list))
-		 "true")
-	(list 'system
-	      (concat xterm-program " -e "
-		      (trim-percent (cdr (assoc "Exec" fdo-list)))
-		      " &"))
+    (if (assoc "Terminal" fdo-list)
+	(if (string-match "[Tt]" (cdr (assoc "Terminal" fdo-list)))
+	    (list 'system
+		  (concat xterm-program " -e "
+			  (trim-percent (cdr (assoc "Exec" fdo-list)))
+			  " &"))
+	  (list 'system
+		(concat (trim-percent (cdr (assoc "Exec" fdo-list)))
+			" &")))
       (list 'system
 	    (concat (trim-percent (cdr (assoc "Exec" fdo-list)))
 		    " &"))))
 
-  (define (desk-file->fdo-list desk-file)
-    (when (desktop-file-p desk-file)
-       (let ((fdo-list (fdo-check-exile (parse-desktop-file desk-file))))
-	 (let ((a (assoc "NoDisplay" fdo-list))
-	       (b (assoc "OnlyShowIn" fdo-list))
-	       (c (assoc "NotShowIn" fdo-list))
-	       (d (assoc "Hidden" fdo-list)))
-	   ;; 't
-	   (setq fdo-list (append fdo-list (cons (cons "apps-menu-display?" "true"))))
-	   ;; 'maybe
-	   (when (eq apps-menu-show-all 'maybe)
-	     (when b
-	       (if (string-match (concat (quote-regexp desktop-environment) "*")
-				 (string-downcase (cdr b)))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "true")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "false")))
-	     (when c
-	       (if (string-match (concat (quote-regexp desktop-environment) "*")
-				 (string-downcase (cdr c)))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "false")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "true"))))
-	   ;; 'nil
-	   (when (or (eq apps-menu-show-all 'nil) (not apps-menu-show-all))
-	     (when a
-	       (if (string-match "[Ff]" (cdr a))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "true")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "false")))
-	     (when d
-	       (if (string-match "[Ff]" (cdr d))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "true")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "false")))
-	     (when b
-	       (if (string-match (concat (quote-regexp desktop-environment) "*")
-				 (string-downcase (cdr b)))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "true")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "false")))
-	     (when c
-	       (if (string-match (concat (quote-regexp desktop-environment) "*")
-				 (string-downcase (cdr c)))
-		   (rplacd (assoc "apps-menu-display?" fdo-list) "false")
-		 (rplacd (assoc "apps-menu-display?" fdo-list) "true")))))
-	   fdo-list)))
-
-  ;; generate a sawfish menu entry from a .desktop file
+  ;; Apps-Menu Filtering
+
+  (define (fdo-nodisplay-filter fdol)
+    "Return the desktop-file-list if NoDisplay is False, or if NoDisplay is
+not present in the desktop-file-list"
+    (if (assoc "NoDisplay" fdol)
+	(if (string-match "[Ff]" (cdr (assoc "NoDisplay" fdol)))
+	    fdol)
+      fdol))
+  
+  (define (fdo-hidden-filter fdol)
+    "Return the desktop-file-list if Hidden is False, or if Hidden is
+not present in the desktop-file-list"
+    (if (assoc "Hidden" fdol)
+	(if (string-match "[Ff]" (string-downcase (cdr (assoc "OnlyShowIn" fdol))))
+	    fdol)
+      fdol))
+
+  (define (fdo-onlyshowin-filter fdol)
+    "Return the desktop-file-list if OnlyShowIn matches `desktop-environment', 
+or if OnlyShowIn is not present in the desktop-file-list"
+    (if (assoc "OnlyShowIn" fdol)
+	(if (string-match desktop-environment (string-downcase (cdr (assoc "OnlyShowIn" fdol))))
+	    fdol)
+      fdol))
+
+  (define (fdo-notshowin-filter fdol)
+    "Return the desktop-file-list if NotShowIn does not match `desktop-environment', 
+or if NotShowIn is not present in the desktop-file-list"
+    (if (assoc "NotShowIn" fdol)
+	(if (not (string-match desktop-environment (string-downcase (cdr (assoc "NotShowIn" fdol)))))
+	    fdol)
+      fdol))
+
+  (define (fdo-associate-categories-filter fdol)
+    (when fdol
+      (if apps-menu-associate-categories
+	  (associate-categories fdol)
+	fdol)))
+
+  (define (fdo-default-filter fdol)
+    (fdo-hidden-filter
+     (fdo-notshowin-filter
+      (fdo-onlyshowin-filter
+       (fdo-nodisplay-filter fdol)))))
+
+  (define (fdo-some-filter fdol)
+    (fdo-notshowin-filter
+     (fdo-onlyshowin-filter fdol)))
+
+  (define (fdo-filter-record fdol display-test)
+    "Return the result of `display-test' which can be a pre-set filter,
+such as `default' or `some' or it can be a pre-defined function of
+your choosing, which should either return the desktop-file-list or '(). 
+If `display-test' is not defined, will return the input desktop-file-list."
+    (cond 
+     ;; default filter is chosen
+     ((eq display-test 'default)
+      (fdo-default-filter fdol))
+     ;; some flter is chosen
+     ((eq display-test 'some)
+      (fdo-some-filter fdol))
+     ;; user filter is chosen
+     ((functionp display-test)
+      (condition-case nil
+	  (display-test fdol)
+	(error fdol)))
+     ((not display-test)
+      fdol)
+     (t
+      fdol)))
+
+  ;; Sawfish-menu generation
+
   (define (generate-menu-entry fdo-list)
     "Generate a menu entry to run the program specified in the the
 desktop file `desk-file'."
-    (when (and fdo-list
-	       (string= (cdr (assoc "apps-menu-display?" fdo-list)) "true"))
-      (list
-       (determine-desktop-category
-	(cdr (assoc "Categories" fdo-list)))
-       (determine-desktop-name fdo-list)
-       (determine-desktop-exec fdo-list))))
+    (when fdo-list
+      (let* ((this-exec (determine-desktop-exec fdo-list))
+	     (this-name (determine-desktop-name fdo-list))
+	     (these-categories (remove "" (string-split ";" (cdr (assoc "Categories" fdo-list)))))
+	     (this-entry '()))
+	(let loop ((this-category these-categories))
+	     (if (null this-category) this-entry
+	       (progn (setq this-entry 
+			    (append this-entry 
+				    (list (list (car this-category)
+						this-name
+						this-exec))))
+		      (loop (cdr this-category))))))))
+
 
   (define (generate-apps-menu)
     "Returns the list of applications menu which can be used for `apps-menu'."
     (unless apps-menu-lang
       (setq apps-menu-lang (find-lang-string)))
-    (setq local-menu nil)
-    (let ((desk-files (flatten (map-dir-files desktop-directory))))
-      (mapc (lambda (x)
-	      (setq local-menu
-		    (append local-menu
-			    (list (generate-menu-entry (desk-file->fdo-list x)))))) desk-files)
+    (let ((desk-files (flatten (map-dir-files desktop-directory ".desktop")))
+	  (local-menu nil))
+      (mapc 
+       (lambda (x)
+	 (setq local-menu
+	       (append local-menu
+		       (generate-menu-entry
+			(fdo-associate-categories-filter
+			 (fdo-filter-record
+			  (fdo-check-exile 
+			   (parse-desktop-file x))
+			  apps-menu-filter))))))
+       desk-files)
       (if apps-menu-alphabetize
-	  (alphabetize-entries (fix-cats desktop-cat-alist))
-	(fix-cats desktop-cat-alist))))
+	  (alphabetize-entries (consolodate-menu (sort (delete nil local-menu) string<)))
+	(consolodate-menu (sort (delete nil local-menu) string<)))))
 
   (define (init-apps-menu)
     "If `apps-menu' is nil, then call `update-apps-menu'. This function
@@ -417,4 +518,4 @@ append the auto generated one."
       (setq apps-menu user-apps-menu)))
 
   (define-command 'update-apps-menu update-apps-menu)
-  )
+  )
\ No newline at end of file

-- 
mrl


[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]