File: menus.jl

package info (click to toggle)
sawfish 1%3A1.3.5.2-2
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 11,636 kB
  • ctags: 1,327
  • sloc: lisp: 22,765; ansic: 15,810; sh: 10,203; makefile: 675; perl: 19
file content (260 lines) | stat: -rw-r--r-- 8,639 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
;; gnome-menu.jl -- replace the apps-menu by the gnome menu tree
;; $Id: menus.jl,v 1.27 2003/02/04 05:43:19 jsh Exp $

;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk>

;; This file is part of sawmill.

;; sawmill is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; sawmill is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with sawmill; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

(define-structure sawfish.wm.gnome.menus

    (export gnome-menus-update
	    gnome-menus)

    (open rep
	  rep.system
	  rep.regexp
	  rep.io.files
	  sawfish.wm.commands)

  (define-structure-alias gnome-menu sawfish.wm.gnome.menus)

  (eval-when-compile (require 'sawfish.wm.menus))

;;; variables

  (defvar gnome-share-directory
    ;; search $PATH for a known GNOME binary..
    (catch 'out
      (let ((path (getenv "PATH"))
	    (point 0)
	    end tem)
	(while (< point (length path))
	  (setq end (if (string-match ":" path point)
			(match-start)
		      (length path)))
	  (setq tem (substring path point end))
	  (when (file-exists-p (expand-file-name "gnome-session" tem))
	    (throw 'out (expand-file-name "../share/gnome" tem)))
	  (setq point (1+ end))))
      ;; default to /usr/share/gnome, better than nothing at all
      "/usr/share/gnome"))

  (defvar gnome-menu-lang (let ((lang (or (getenv "LANGUAGE")
					  (getenv "LC_ALL")
					  (getenv "LC_MESSAGES")
					  (getenv "LANG")))
				(all '()))
			    (when (and lang (not (string= lang "en")))
			      (setq all (cons lang all))
			      (when (string-match "[.@]" lang)
				(setq lang (substring lang 0 (match-start)))
				(setq all (cons lang all)))
			      (when (string-match "_" lang)
				(setq lang (substring lang 0 (match-start)))
				(setq all (cons lang all))))
			    all)
    "List of language codes used when constructing GNOME menus.")

  (defvar gnome-menu-roots (list (expand-file-name
				  "apps" gnome-share-directory)
				 "/etc/X11/applnk"	;on RedHat systems
				 "/usr/share/applications"
				 "/var/lib/menu-xdg/applications/menu-xdg"
				 "~/.gnome/apps")
    "List of directories to read GNOME menu entries from.")

  ;; previously read menus
  (define gnome-cached-menus nil)

  ;; split $PATH
  (define cached-path)

;;; code

  ;; search $PATH for an executable file..
  (define (gnome-exec-in-path filename)
    (let ((get-path (lambda ()
		      (unless cached-path
			(let ((path (getenv "PATH"))
			      (point 0)
			      out end)
			  (while (< point (length path))
			    (setq end (if (string-match ":" path point)
					  (match-start)
					(length path)))
			    (setq out (cons (substring path point end) out))
			    (setq point (1+ end)))
			  (setq cached-path (nreverse out))))
		      cached-path)))
      (catch 'out
	(mapc (lambda (d)
		(when (file-exists-p (expand-file-name filename d))
		  (throw 'out (expand-file-name filename d)))) (get-path))
	nil)))

  (define (gnome-menu-read-desktop-entry filename)
    (let ((file (condition-case nil
		    (open-file filename 'read)
		  (file-error nil)))
	  (section nil)
	  name exec tryexec terminal
	  line)
      (when file
	(unwind-protect
	    (while (setq line (read-line file))
	      (cond ((string-looking-at "\\[Desktop Entry\\]" line 0 t)
		     (setq section 'desktop-entry))
		    ((string-looking-at "\\s*$" line)
		     (setq section nil))
		    ((and (eq section 'desktop-entry)
			  (string-looking-at "Name=(.*)\n" line 0 t))
		     (setq name (expand-last-match "\\1")))
		    ((and (eq section 'desktop-entry) gnome-menu-lang
			  (string-looking-at "Name\\[([^]]+)\\]=(.*)\n" line 0 t)
			  (member (expand-last-match "\\1") gnome-menu-lang))
		     (setq name (expand-last-match "\\2")))
		    ((and (eq section 'desktop-entry)
			  (string-looking-at "Exec=(.*)\n" line 0 t))
		     (setq exec (expand-last-match "\\1")))
		    ((and (eq section 'desktop-entry)
			  (string-looking-at "TryExec=(.*)\n" line 0 t))
		     (setq tryexec (expand-last-match "\\1")))
		    ((and (eq section 'desktop-entry)
			  (string-looking-at "Terminal=(.*)\n" line 0 t))
		     (setq terminal (expand-last-match "\\1"))
		     (setq terminal (not (string-match
					  "^0|false$" terminal 0 t))))))
	  (close-file file))
	(cond ((string= (file-name-nondirectory filename) ".directory")
	       (let ((menus (gnome-menu-read-directory
			     (file-name-directory filename))))
		 (when menus
		   `(,(or name filename) ,@menus))))
	      ((and exec (or (not tryexec) (gnome-exec-in-path tryexec)))
	       ;; create a menu item
	       `(,(or name exec)
		 (system ,(concat (if terminal
				      (concat "x-terminal-emulator -e " exec)
				    exec) " &"))))))))

  (define (gnome-menu-read-order filename)
    (let ((file (condition-case nil
		    (open-file filename 'read)
		  (file-error nil))))
      (when file
	(unwind-protect
	    (let
		(order tem)
	      (while (setq tem (read-line file))
		(when (string-match "\\S+" tem)
		  (setq tem (substring tem (match-start) (match-end))))
		(setq order (cons tem order)))
	      (nreverse order))
	  (close-file file)))))

  (define (gnome-menu-read-item dirname file)
    (unless (= (aref file 0) ?.)
      (setq file (expand-file-name file dirname))
      (cond
       ((file-regular-p file)
	(gnome-menu-read-desktop-entry file))
       ((file-directory-p file)
	(if (file-exists-p (expand-file-name ".directory" file))
	    (gnome-menu-read-desktop-entry
	     (expand-file-name ".directory" file))
	  (let
	      ((menus (gnome-menu-read-directory file)))
	    (when menus
	      (cons (file-name-nondirectory file) menus))))))))

  (define (gnome-menu-read-directory dirname)
    (let ((order (and (file-exists-p (expand-file-name ".order" dirname))
		      (gnome-menu-read-order
		       (expand-file-name ".order" dirname))))
	  menus unordered item)
      (mapc (lambda (file)
	      (when (file-exists-p (expand-file-name dirname file))
		(when (setq item (gnome-menu-read-item dirname file))
		  (setq menus (cons item menus)))))
	    order)
      (mapc (lambda (file)
	      (unless (or (= (aref file 0) ?.) (member file order))
		(when (setq item (gnome-menu-read-item dirname file))
		  (setq unordered (cons item unordered)))))
	    (directory-files dirname))
      (when (or menus unordered)
	(nconc (nreverse menus)
	       (sort unordered (lambda (x y)
				 (string-lessp (car x) (car y))))))))
  
  (define (gnome-menus-merge-dups menus)
    (let (ptr inner-ptr item tem)
      (setq ptr menus)
      (while ptr
	(setq item (car ptr))
	(when (and item (consp (cdr item)) (not (functionp (cdr item))))
	  (setq inner-ptr (cdr ptr))
	  (while inner-ptr
	    (setq tem (car inner-ptr))
	    (setq inner-ptr (cdr inner-ptr))
	    (when (and tem (string= (car item) (car tem))
		       (consp (cdr tem)) (not (functionp (cdr tem))))
	      ;; we've found a later occurrence of this sub-menu
	      (setq menus (delq tem menus))
	      (nconc item (cdr tem)))))
	(setq ptr (cdr ptr)))
      ;; now we've uniqued the top-level, recurse through any sub-menus
      (setq ptr menus)
      (while ptr
	(setq item (car ptr))
	(setq ptr (cdr ptr))
	(when (and item (consp (cdr item)) (not (functionp (cdr item))))
	  (rplacd item (gnome-menus-merge-dups (cdr item)))))
      menus))

  (define (gnome-menus-update)
    (setq gnome-cached-menus nil)
    (mapc (lambda (dir)
	    (when (and (stringp dir) (file-directory-p dir))
	      (setq gnome-cached-menus
		    (nconc gnome-cached-menus
			   (gnome-menu-read-directory dir)))))
	  gnome-menu-roots)
    (setq gnome-cached-menus (gnome-menus-merge-dups gnome-cached-menus))
    gnome-cached-menus)

  (define-command 'gnome-menus-update gnome-menus-update)

  (define (gnome-menus)
    (unless gnome-cached-menus
      (gnome-menus-update))
    gnome-cached-menus)

;;; init

  ;; take over the applications submenu of the root window menu

  (make-variable-special 'apps-menu)
  (setq apps-menu gnome-menus)

  ;; load the menus when we idle, it reduces the latency of the first
  ;; menu popup

  (letrec ((gnome-on-idle (lambda ()
			    (gnome-menus)
			    (remove-hook 'idle-hook gnome-on-idle))))
    (add-hook 'idle-hook gnome-on-idle)))