Re: fdo-menu partial re-write

Ok, here is the module version, compilation errors are gone now.  Let me
know how it works for others, everything should be working fine, hopefully :)


Matthew Love

;; (fdo-menu.jl (v1.0.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.

;;; Code:

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

    (export update-saw-menu)
    (open rep

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

  (unless batch-mode

    (defvar this-line nil)
    (defvar *loc-menu* nil)
    (make-variable-special 'apps-menu)

    ;; fdo-desktop-file-parsing
    (defun desktop-file-p (directory-file)
      (let ((this-file (open-file directory-file 'read)))
	(string= (read-line this-file) "[Desktop Entry]\012")))

    (defun desktop-group-p (instring)
      (string= (substring instring 0 1) "["))

    (defun desktop-skip-line-p (instring)
      (or (not instring)
	  (string= (substring instring 0 1) "#")
	  (string= (substring instring 0 1) "\012")))

    (defun get-key-break (instring key)
      (if instring
	  (do ((mcount 0 (1+ mcount))) 
	      ((or (string= (substring instring mcount (+ mcount 1)) "\n")
		   (string= (substring instring mcount (+ mcount 1)) key)
		   (= mcount 398)) mcount))))

    (defun get-desktop-key (instring)
      (if (> (length instring) 3)
	  (let ((break-number (get-key-break instring "=")))
	    (if (< break-number 20)
		(substring instring 0 break-number)))))

    (defun get-desktop-value (instring)
      (if (> (length instring) 3)
	  (let ((break-number (get-key-break instring "=")))
	    (if (< break-number 20)
		(substring instring (+ 1 break-number))))))

    (defun get-desktop-group (instring)
      (substring instring 1 (- (length instring) 2)))

    (defun parse-desktop-file-line (infile)
      (if (setq this-line (read-line infile))
	  (if (not (desktop-skip-line-p this-line))
	       (if (desktop-group-p this-line)
		   (get-desktop-group this-line)
		 (if (not (desktop-group-p this-line))
		     (cons (get-desktop-key this-line) (get-desktop-value this-line))))
	       (parse-desktop-file-line infile))
	    (parse-desktop-file-line infile))))

    (defun parse-desktop-file (infile)
      (unless (not (desktop-file-p infile))
	(let ((d-file (open-file infile 'read)))
	  (parse-desktop-file-line d-file))))

    ;; generic functions
    (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))))))
    (defun trim-end (string)
       ((string= (aref string (- (length string) 3)) 37)
	(substring string 0 (- (length string) 4)))
	(substring string 0 (- (length string) 1)))))

    (defun find-lang-string ()
       ((getenv "LANGUAGE")
	(let ((mlang (getenv "LANGUAGE")))
	  (if (> (length mlang) 2)
	      (substring mlang 0 5)
	    (substring mlang 0 2))))
       ((getenv "LC_ALL")
	(let ((mlang (getenv "LC_ALL")))
	  (if (> (length mlang) 2)
	      (substring mlang 0 5)
	    (substring mlang 0 2))))
       ((getenv "LC_MESSAGES")
	(let ((mlang (getenv "LC_MESSAGES")))
	  (if (> (length mlang) 2)
	      (substring mlang 0 5)
	    (substring mlang 0 2))))
       ((getenv "LANG")
	(let ((mlang (getenv "LANG")))
	  (if (> (length mlang) 2)
	      (substring mlang 0 5)
	    (substring mlang 0 2))))))

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

    (if my-lang-string
	(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 "))

    (if (not (boundp 'use-fdo-menu))
	(defvar use-fdo-menu 't))

    ;; The Master Category List

    (defvar menu-cat-alist
      '(("Desktop" .  ("X-Desktop" "X-DesktopApplets" "X-DesktopCountry" \
		       "DesktopSettings" "GNOME" "KDE" "X-GNOME-PersonalSettings" \
	("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" \
	("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"))))

    ;; Get the correct Name value based on language settings
    (defun find-lang-in-desktop-file (fdo-list)
      (if (assoc (concat name-string my-lang-string "]") fdo-list)
	  (concat name-string my-lang-string "]")
	(if (assoc (concat name-string (substring my-lang-string 0 2) "]") fdo-list)
	    (concat name-string (substring my-lang-string 0 2) "]")

    ;; Functions for categories
    (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)))))

    ;; Associate values from the Master Category list with sub-categories from file
    (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))))))

    ;; Convert a Categories key value from ; delineated records to a list
    (defun build-cat-list (line) 
      (if (> (length line) 1)
	  (let ((this-cat (prin1-to-string (read-from-string line))))
	    (cons this-cat 
		  (if (< (length this-cat) (length line))
		      (build-cat-list (substring line (+ 1 (length this-cat)))))))))

    ;; 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))
	(car cat-list)))

    ;; 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)))))

    ;; generate a saw-fish menu entry from a .desktop file
    (defun generate-menu-entry (desk-file)
      (if (and (not (file-directory-p desk-file))
	       (desktop-file-p desk-file))
	  (let ((fdo-list (parse-desktop-file desk-file)))
	    (if (not (string= (cdr (assoc "NoDisplay" fdo-list)) "true\n"))
		(cons (parse-cat-list (build-cat-list (trim-end (cdr (assoc "Categories" fdo-list)))))
		      (cons (trim-end (cdr (assoc (find-lang-in-desktop-file fdo-list) fdo-list)))
			    (if (string= (cdr (assoc "Terminal" fdo-list)) "true\012")
				(cons (list 
				       'system (concat my-term-string (trim-end (cdr (assoc "Exec" fdo-list))) " &")))
			      (cons (list 'system (concat (trim-end (cdr (assoc "Exec" fdo-list))) " &"))))))))))

    ;; Update the menu
    (define (update-saw-menu)
      (unless (not use-fdo-menu)
	(setq *loc-menu* nil)
	(defvar desk-files (flatten (map-dir-files desktop-directory)))
	(mapc (lambda (x)
		(setq *loc-menu* (append *loc-menu* (list (generate-menu-entry 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)
    ;; END-FILE

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