Re: [Patch] apps-menu filtering
- From: Matthew Love <matth love gmail com>
- To: sawfish-list gnome org
- Subject: Re: [Patch] apps-menu filtering
- Date: Fri, 03 Sep 2010 22:31:47 -0600
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]
