Re: Script for creating Application Menu

[Matthew Love <matth love gmail com>]

Christopher Roy Bratusek <zanghar freenet de> writes:

> Ah yes, while you're at it, make sure it works in module format, you
> know:
>
> (define-structure sawfish.wm.ext.fdo-menu 
>
> (export mk-saw-menu)
>
> (open rep
>       rep.system) ;more?
>
> (define-structure-alias fdo sawfish.wm.ext.fdo-menu)
>
> (unless batch-mode 
>
> *script*
>
> ))
>
> then in sawfish.wm.menus:
>
> *snip*
>
> (open ...
>       ...
>       sawfish.wm.ext.fdo-menu)
>
> *snip*
>
> (defvar apps-menu *) ; replace this by the following block
> (unless batch-mode   
>   (write-saw-menu)
>   (require 'saw-menu)
>   (defvar apps-menu saw-apps-menu))
>  
> *snip*
>
> ah yes, sawfish.wm.gnome.menus will then be removed
> less GNOME-Specific code, instead let everyone benefit :)
>
> I'm pretty sure it won't out-of-the-box. You can use
> sawfish.wm.ext.beos-window-menu & co as reference.
>
> Thanks a lot for your efforts,
> Chris

OK, got this working here now.  Was having some trouble getting
variables working from .sawfish[/]rc, but is working now on my system.

Some changes,

file-name is changed to fdo-menu.jl

this file would go in lisp/sawfish/wm/ext/

No longer writes ~/.sawfish/lisp/saw-apps-menu.jl , but directly
assigns the apps-menu variable.  so, (write-saw-menu) is no longer used.
in your .sawfishrc use:
(require 'fdo-menu)
(update-saw-menu)
If applications get added/removed calling (update-saw-menu) will update
the menu, variable changes will also be updated.
desktop-directory, if not set will default to /usr/share/applications,
if set, will only use set directories, which must be set as a list.

sawfish must be re-compiled for this to work.

> then in sawfish.wm.menus:
>
> *snip*
>
> (open ...
>       ...
>       sawfish.wm.ext.fdo-menu)
>
> *snip*
>
> (defvar apps-menu *) ; replace this by the following block
> (unless batch-mode   
>         (update-saw-menu)

Changing the above will set the menu at compile time, using defaults.

Let me know if its working elsewhere

/r

-- 
Matthew Love


;-*-sawfish-*-
;; (fdo-menu.jl (v0.6.0) --- sawfish wm menu generation -- librep)

;; (c) 2009 Matthew Love
;; Christopher Bratusek

;; This file will be part of Sawfish

;;; Description:
;;
;; Create a sawfish wm menu from .desktop files
;; in your /usr/share/applications folder.

#| 

Usage:

Make sure the mk-saw-menu.jl is in your load path
(i.e. ~/.sawfish/lisp), then in your .sawfish[/]rc file add:

;; Optional Part, config bits, defaults listed below
;; can be savely skipped, if you're fine with the defaults

;; change xterm -e to your appropriate string (must have
;; a space at the end) 

(setq my-term-string "xterm -e ") 

;; what locale for localized strings to use, if available
;; eg.: set to de to read Dokumentbetrachter instead of Documentviewer

(setq my-lang-string '())

;; if your .desktop files are located somewhere else than
;; /usr/share/applications, then change the desktop-directory

(setq desktop-directory "/usr/share/applications"))

;; some entries are hidden from the menu, especially GNOME Apps
;; like eog, nautilus or evince & Co, if you want to have them
;; added to your menu, then replace '() by 't in the following

(setq ignore-no-display '())

;; if you don't want your menus to be sorted alphabetically
;; then replace 't by '() in the following

(setq want-alphabetize 't)

;; Necessary part, can't be skipped

;; load our script

(require 'fdo-menu)

;; generate and set the menu

(update-saw-menu)

|#

;;; TODO:

;; adhere to the desktop entry file specifications.
;; http://standards.freedesktop.org/desktop-entry-spec/latest/
;; add support for field codes: <a href="http://standards.freedesktop.org/desktop-entry-spec/latest/ar01s06.html";
;; add support for Comment=/Comment[lang]=
;; add support for Icon=

;;; Code:

(define-structure sawfish.wm.ext.fdo-menu

    (export write-saw-menu
	    update-saw-menu)
    
    (open rep
	  rep.io.files
	  rep.io.streams
	  rep.system
	  sawfish.wm
	  sawfish.wm.commands)

  (define-structure-alias fdo-menu sawfish.wm.ext.fdo-menu)

  (unless batch-mode

;  (defun update-vars
    ;; Some defaults
    (define my-name nil)
    ;;my-comm ()
    ;;my-icon ()
    (define my-disp nil)
    (define my-term nil)
    (define my-exec nil)
    (define desk-files nil)
    (define *loc-menu* nil)          
    (make-variable-special 'apps-menu)
        
    (defun map-desk-files (in-desk-files in-directory)
      (if in-desk-files
	  (cons (expand-file-name (car in-desk-files) in-directory)
		(map-desk-files (cdr in-desk-files) in-directory))))
    
    (defun map-dir-files (directories)
      (if 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)))))

    (defun flatten (input)
      (cond ((null input) nil)
	    ((atom input) (list input))
	    (t (append (flatten (car input))
		       (flatten (cdr input))))))

    ;; Variables that can be set in .sawfish[/]rc
    
    (if (not (boundp 'desktop-directory))
	(defvar desktop-directory '("/usr/share/applications")))

    (defvar desk-files (flatten (map-dir-files desktop-directory)))

    (if (not (boundp 'my-lang-string))
	(if (getenv "LANG")
	    (if (> (length (getenv "LANG")) 2)
		(defvar my-lang-string (substring (getenv "LANG") 0 5))
	      (defvar my-lang-string (substring (getenv "LANG") 0 2)))
	  (defvar my-lang-string nil)))
    
    (if my-lang-string
	(define name-string "Name[")
      (defvar name-string "Name="))
    
    (if (not (boundp 'ignore-no-display))
	(defvar ignore-no-display '()))
    
    (if (not (boundp 'want-alphabetize))
	(defvar want-alphabetize 't))
    
    (if (not (boundp 'my-term-string))
	(defvar my-term-string "xterm -e "))
;    )

    
    ;; The Master Category List
    (defvar menu-cat-alist
	  '(("Desktop" .  ("X-Desktop" "X-DesktopApplets" "X-DesktopCountry" \
			   "DesktopSettings" "GNOME" "KDE" "X-GNOME-PersonalSettings" \
			   "X-Xfce-Toplevel"))
	    ("Personal" . ("X-Personal" "X-PersonalUtility" "Calendar" "ContactManagement"))
	    ("Office" . ("Office" "WordProcessor" "Presentation" "X-Document" \
			 "TextEditor" "SpreadSheet" "Calculator" "X-Calculate" \
			 "Chart" "FlowChart" "Finance"))
	    ("Internet" . ("Telephony" "Network" "Dialup" "VideoConference" \
			   "RemoteAccess" "News" "HamRadio" "FileTransfer" \
			   "X-Internet" "P2P" "Email" "WebBrowser" "IRCClient" "Chat" \
			   "InstantMessaging" "Chat" "WebDevelopment"))
	    ("Games" . ("Game" "ActionGame" "AdventureGame" "ArcadeGame" "BoardGame" "Emulator"\
			"BlocksGame" "CardGame" "KidsGame" "LogicGame" "RolePlaying" "Simulation"))
	    ("Graphics" . ("RasterGraphics" "VectorGraphics" "X-GraphicUtility" \
			   "2DGraphics" "3dGraphics" "3DGraphics" "Scanning" "OCR" "Photography" \
			   "Viewer" "Publishing" "Art" "ImageProcessing"))
	    ("Media" . ("AudioVideo" "Audio", "Video" "Midi" "Mixer" "Sequencer" "Tuner" \
			"TV" "AudioVideoEditing" "Player" "Recorder" "DiscBurning" "Music"))
	    ("Science" . ("Science" "Astrology" "ArtificialIntelligence" "Astronomy" \
			  "Biology" "Chemistry" "ComputerScience" "DataVisualization" \
			  "Electricity" "Robotics" "Physics" "Math" "Education" "Geography"))
	    ("Development" . ("GUIDesigner" "IDE" "Profiling" "RevisionControl" \
			      "ProjectManagement" "Translation" "GTK" "Development" \
			      "Qt" "Development" "Documentation"))
	    ("Utility" . ("X-SystemMemory" "Security" "Utility" \
			  "X-SetupEntry" "X-SetupUtility" "X-SystemMemory" \
			  "TextTools" "TelephonyTools" "Accessibility" "Clock" \
			  "ConsoleOnly"))
	    ("Filesystem" .  ("X-FileSystemFind" "X-FileSystemUtility" "Archiving" \
			      "FileManager" "X-FileSystemMount" "Compression"))
	    ("System" . ("X-SystemSchedule" "System" "X-SystemMemory" \
			 "TerminalEmulator" "Dictionary" "Puppy" "Printing" "Monitor" "Security"))
	    ("Settings" . ("Settings" "HardwareSettings" "PackageManager"))))

    ;; Some file-verifiers
    (defun desktop-file-p (directory-file)
      (let ((this-file (open-file directory-file 'read)))
	(let ((this-line (read-line this-file)))
	  (if (string= this-line "[Desktop Entry]\012")
	      't
	    '()))))
    
    (defun backup-file-p (input-file-name)
      (if (or (string= "~" (substring input-file-name (- (length input-file-name) 1)))
	      (string= "#" (substring input-file-name 0 1)))
	  't
	'()))

    ;; Helper for (parse-desk-line) - specifically, for categories.
    (defun build-cat-list (line) ;; line must be excluding the \
      ;; categories= part -> (substring line 11)
      (if (> (length line) 1)
	  (let ((line-len (length line))
		(this-cat (prin1-to-string (read-from-string line))))
	    (cons this-cat (build-cat-list (substring line (+ 1 (length this-cat))))))))


    ;; Helper function for (fix-cats)
    (defun fix-sub-cats (cat-list loc-list)
      (if 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)))))


    ;; Second Part of process, after (parse-desktop-file) has run \
    ;; through and generated the *loc-menu*.
    ;; Will run through the Category alist and assign menu values accordingly, and \
    ;; will output the base of the menu, to \
    ;; be fed into (build-saw-menu)
    (defun fix-cats (cat-list)
      (if cat-list
	  (let ((cat-val (car (car cat-list)))
		(c-list (fix-sub-cats (car cat-list) *loc-menu*)))
	    (if (car c-list)
		(cons (cons cat-val c-list) (fix-cats (cdr cat-list)))
	      (fix-cats (cdr cat-list))))))

    ;; Helper for (parse-desk-line)
    ;; Determine best category to use... :|
    (defun parse-cat-list (cat-list)
      (if (cdr cat-list)
	  (let ((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"))
		(parse-cat-list (cdr cat-list))
	      ;; to do specific things for the above entries (uncomment below, \
	      ;; and comment out the above (parse-cat-list (cdr cat-list)):
	      ;;(let ((dm-specific this-cat))
	      ;;  (if (or (string= dm-specific "Application")
	      ;;      (string= dm-specific "Qt")
	      ;;      (string= dm-specific "GTK"))
	      ;;  (parse-cat-list (cdr cat-list))
	      ;;"Settings"))
	      this-cat))
	(car cat-list)))


    ;; Helper function for (create-menu), which will parse the string input there.
    ;; Will only give an output for specified lines (i.e. category, name, etc.)
    (defun parse-desk-line (line desk-value)
      (let ((line-len (length line)))
	(cond

	 ;; this section is for the multi-lingual name string
	 ((and (> line-len 7) 
	       my-lang-string
	       (string= desk-value (substring line 0 5))
	       (string= (substring line 4 5) "[")
	       (or (string= my-lang-string (substring line 5 (+ (length my-lang-string) 5)))
		   (string= (substring my-lang-string 0 2) (substring line 5 (+ (length my-lang-string) 5)))))
	  (substring line (+ 4 (length my-lang-string) 3) (- line-len 1)))

	 ;; this section is for the exec and default name strings
	 ((and (> line-len 5)
	       (string= (substring desk-value 0 4) (substring line 0 4))
	       (string= (substring line 4 5) "="))
	  (if (string= (aref line (- line-len 3)) 37)
	      (substring line 5 (- line-len 4))
	    (substring line 5 (- line-len 1))))

	 ;; this section is for the category string
	 ((and (> line-len 10) (string= desk-value (substring line 0 11)))
	  (let ((cat-string (parse-cat-list (build-cat-list (substring line 11)))))
	    cat-string))

	 ;; this section is for the terminal string
	 ((and (> line-len 8) (string= desk-value (substring line 0 9)))
	  (substring line 9 (- line-len 1)))
	 
	 ;; this section is for the nodisplay string
	 ((and (> line-len 9) (string= desk-value (substring line 0 10)))
	  (substring line 10 (- line-len 1))))))

    ;; begining of parsing for (parse-desktop-file), feed a .desktop file line into this.
    ;; (create-menu "Name=Emacs ") ==> "Emacs"
    ;; (create-menu "Categories=Development;TextEditor;") ==> "Development"
    (defun create-menu (line)
      (cond
       ((parse-desk-line line "Categories=")
	(define my-cat (parse-desk-line line "Categories=")))
       ((parse-desk-line line name-string)
	(define my-name (parse-desk-line line name-string)))
       ;;((parse-desk-line line "Comment=")
       ;; (setq my-comm (parse-desk-line line "Comment=")))
       ;;((parse-desk-line line "Icon=")
       ;; (setq my-icon (parse-desk-line line "Icon=")))
       ((parse-desk-line line "Exec=")
	(define my-exec (concat (parse-desk-line line "Exec=") " &")))
       ((parse-desk-line line "Terminal=")
	(define my-term (parse-desk-line line "Terminal=")))
       ((parse-desk-line line "NoDisplay=")
	(define my-disp (parse-desk-line line "NoDisplay=")))))


    ;; Parse a .desktop file into a list suitable for a menu
    ;; ex. (parse-desktop-file "emacs.desktop") ==> ("Development" "Emacs Text Editor" (system "emacs &"))

    (defun parse-desktop-file (desktop-file)
      (let ((desktop-file-name desktop-file))
	;;desktop-file-name
	(if (and (file-exists-p desktop-file-name)
		 (desktop-file-p desktop-file-name)
		 (not (file-directory-p desktop-file-name)))
	    ;;(not (backup-file-p desktop-file-name))
	    ;;(file-regular-p desktop-file-name))
	    (let ((new-file (open-file desktop-file-name 'read)))
	      (while (define file-line (read-line new-file))
		(create-menu file-line))
	      (if ignore-no-display
		  (setq my-disp '()))
	      (if (not (string= my-disp "true"))
		  (if (not (string= (string-downcase my-term) "true"))
		      (cons my-cat (cons my-name (cons (list 'system my-exec) nil)))
		    ;;(cons my-cat (cons my-icon (cons my-name (cons my-comm (cons (list 'system my-exec) nil)))))
		    (cons my-cat (cons my-name (cons (list 'system (concat my-term-string my-exec)) nil))))
		;;(cons my-cat (cons my-icon (cons my-name (cons my-comm (cons (list 'system (concat my-term-string my-exec)) nil))))))
		(setq my-disp ()))))))

    ;; Format the menu for sawfish
    (defun build-saw-menu (entry)
      `(defvar saw-apps-menu ',entry))

    ;; Alphabetize the entries in the category menus
    (defun alphabetize-entries (saw-menu)
      (if saw-menu
	  (cons (cons (car (car saw-menu)) 
		      (sort (cdr (car saw-menu)) string<)) 
		(alphabetize-entries (cdr saw-menu)))))

    ;; Write the sawfish menu to file
    (defun write-saw-menu ()
      (setq *loc-menu* nil)
      ;; generate a list (*loc-menu*) from a (parse-desktop-file) call on all the .desktop files
      (mapc (lambda (x)
	      (setq *loc-menu* (append *loc-menu* (list (parse-desktop-file x))))) desk-files)
      ;; check if ~/.sawfish/lisp exists, and if not, create it
      (if (not (file-exists-p "~/.sawfish/lisp"))
	  (if (file-exists-p "~/.sawfish")
	      (make-directory "~/.sawfish/lisp")
	    (lambda () (make-directory "~/.sawfish") (make-directory "~/.sawfish/lisp"))))
      (define menu-file (open-file "~/.sawfish/lisp/saw-menu.jl" 'write))
      ;; generate the sawfish compatible menu file from the *loc-menu* list
      (if want-alphabetize
	  (prin1 (build-saw-menu (alphabetize-entries (fix-cats menu-cat-alist))) menu-file)
	(prin1 (build-saw-menu (fix-cats menu-cat-alist)) menu-file))
      (close-file menu-file))

    (define (update-saw-menu)
      (setq *loc-menu* nil)
      (setq desk-files (flatten (map-dir-files desktop-directory)))
      (mapc (lambda (x)
	      (setq *loc-menu* (append *loc-menu* (list (parse-desktop-file x))))) desk-files)
      (if want-alphabetize
	  (setq apps-menu (alphabetize-entries (fix-cats menu-cat-alist)))
	(setq apps-menu (fix-cats menu-cat-alist))))
	
    (define-command 'update-saw-menu update-saw-menu)

))